VB批量合并若干大小图片

'首先新建一个工程,添加两个picturebox插件
Option Explicit

Private Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(0 To 7) As Byte

End Type

Private Type GdiplusStartupInput

GdiplusVersion As Long

DebugEventCallback As Long

SuppressBackgroundThread As Long

SuppressExternalCodecs As Long

End Type

Private Type EncoderParameter

GUID As GUID

NumberOfValues As Long

type As Long

Value As Long

End Type

Private Type EncoderParameters

Count As Long

Parameter As EncoderParameter

End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long

Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long

Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long

Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long

Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long

Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long

Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long

Private Declare Function GdiTransparentBlt Lib "gdi32" (ByVal hdc1 As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal W1 As Long, ByVal H1 As Long, ByVal Hdc2 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal W2 As Long, ByVal H2 As Long, ByVal Color As Long) As Long

'---------------------------------------------------------------------------------

Private Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 100) As Boolean '这里的100是指图片的压缩率,越低压缩程度越高,若使用VB自带的保存函数,生成的BMP图片格式会大4倍以上

Dim tSI As GdiplusStartupInput

Dim lRes As Long

Dim lGDIP As Long

Dim lBitmap As Long

'初始化 GDI+

tSI.GdiplusVersion = 1

lRes = GdiplusStartup(lGDIP, tSI, 0)

If lRes = 0 Then

'从句柄创建 GDI+ 图像

lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)

If lRes = 0 Then

Dim tJpgEncoder As GUID

Dim tParams As EncoderParameters

'初始化解码器的GUID标识

CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder

'设置解码器参数

tParams.Count = 1

With tParams.Parameter ' Quality

'得到Quality参数的GUID标识

CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID

.NumberOfValues = 1

.type = 4

.Value = VarPtr(quality)

End With

'保存图像

lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)

'销毁GDI+图像

GdipDisposeImage lBitmap

End If

'销毁 GDI+

GdiplusShutdown lGDIP

End If

If lRes Then

PictureBoxSaveJPG = False

Else

PictureBoxSaveJPG = True

End If

End Function
Private Sub Form_Load()
Dim I As Long

Dim J As Long

Me.ScaleMode = 3

Picture1.ScaleMode = 3

Picture2.ScaleMode = 3

Picture2.AutoRedraw = True

Picture1.AutoRedraw = True

Picture1.AutoSize = True

Picture1.BorderStyle = 0

Picture2.BorderStyle = 0

Set Picture1.Picture = LoadPicture(App.Path & "\1-1.jpg")


Picture2.Width = Picture1.ScaleWidth * 5
'设置合成的总宽度

Picture2.Height = Picture1.ScaleHeight * 5
'设置合成的总高度

For I = 1 To 5

    For J = 1 To 5

            Set Picture1.Picture = LoadPicture(App.Path & "\" & CStr(I) & "-" & CStr(J) & ".jpg")
'这里按照从左上角到右下角的顺序拼接,左上角是1-1,右下角是5-5
            Picture2.PaintPicture Picture1.Picture, J * Picture1.ScaleWidth, I * Picture1.ScaleHeight
'最后两个参数是图片的位置,若另有所需可以适当调整
    Next

Next


 
 


PictureBoxSaveJPG Picture2.Image, App.Path & "\Combination.jpg"
'合并的图片输出到当前目录
End Sub


                                    
发布了11 篇原创文章 · 获赞 1 · 访问量 5076
展开阅读全文

没有更多推荐了,返回首页

©️2019 CSDN 皮肤主题: 编程工作室 设计师: CSDN官方博客

分享到微信朋友圈

×

扫一扫,手机浏览