VB Bmp图片转换Jpg压缩处理模块:
VB Bmp图片转换压缩处理模块: Option Explicit '图片转换压缩处理模块 'PictureBoxSaveJPG: '1. = LoadPicture("C:\test.bmp") '载入图片 'If PictureBoxSaveJPG(1, "c:\test.", 100) = True Then MsgBox "操作成功!" 'PictureBox,文件路径,图片质量:100(默认:80) 'BmpFileToJpg: 'If BmpFileToJpg("C:\test.bmp", "C:\test.", 100) = True Then MsgBox "操作成功!" 'Bmp文件路径,文件路径,图片质量:100(默认:80) 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 GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal OutFile 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 OutFile As Long, Bitmap As Long) As Long 'BmpFileToJpg 用到 Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long 'PictureBoxSaveJPG 用到 Public Function PictureBoxSaveJPG(ByVal Pict As StdPicture, ByVal OutFile As String, Optional ByVal Quality As Byte = 80) As Boolean 'PictureBox保存为文件:PictureBox,文件路径,图片质量(默认:80) On Error GoTo Over Dim TSI As GdiplusStartupInput, LRes As Long, lGDIP As Long, lBitmap As Long TSI.GdiplusVersion = 1 '初始化 GDI+ LRes = GdiplusStartup(lGDIP, TSI, 0) If LRes = 0 Then LRes = GdipCreateBitmapFromHBITMAP(Pict.Handle, 0, lBitmap) '从句柄创建 GDI+ 图像 If LRes = 0 Then Dim tJpgEncoder As GUID, tParams As EncoderParameters CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder '初始化解码器的GUID标识 tParams.Count = 1 '设置解码器参数 With tParams.Parameter '图片质量 CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID '得到Quality参数的GUID标识 .NumberOfValues = 1 .type = 4 .Value = VarPtr(Quality) End With LRes = GdipSaveImageToFile(lBitmap, StrPtr(OutFile), tJpgEncoder, tParams) '保存图像 GdipDisposeImage lBitmap '销毁GDI+图像 End If GdiplusShutdown lGDIP '销毁 GDI+ End If If LRes Then PictureBoxSaveJPG = False Else PictureBoxSaveJPG = True '判断执行成功还是失败 Exit Function '退出过程 Over: PictureBoxSaveJPG = False '执行失败 End Function Public Function BmpFileToJpg(ByVal BmpFile As String, ByVal OutFile As String, Optional ByVal Quality As Byte = 80) As Boolean 'Bmp文件转换为文件:Bmp文件路径,文件路径,图片质量(默认:80) On Error GoTo Over Dim TSI As GdiplusStartupInput, LRes As Long, lGDIP As Long, lBitmap As Long TSI.GdiplusVersion = 1 '初始化 GDI+ LRes = GdiplusStartup(lGDIP, TSI, 0) If LRes = 0 Then LRes = GdipCreateBitmapFromFile(StrPtr(BmpFile), lBitmap) '从句柄创建 GDI+ 图像 If LRes = 0 Then Dim tJpgEncoder As GUID, tParams As EncoderParameters CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder '初始化解码器的GUID标识 tParams.Count = 1 '设置解码器参数 With tParams.Parameter '图片质量 CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID '得到Quality参数的GUID标识 .NumberOfValues = 1 .type = 4 .Value = VarPtr(Quality) End With LRes = GdipSaveImageToFile(lBitmap, StrPtr(OutFile), tJpgEncoder, tParams) '保存图像 GdipDisposeImage lBitmap '销毁GDI+图像 End If GdiplusShutdown lGDIP '销毁 GDI+ End If If LRes Then BmpFileToJpg = False Else BmpFileToJpg = True '判断执行成功还是失败 Exit Function '退出过程 Over: BmpFileToJpg = False '执行失败 End Function