Option Explicit 
'http://www.cnng.net
'石陆软件屋
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 Sub Command1_Click() 
 Dim ret As Boolean 
  
 Picture1.Picture = LoadPicture(App.Path & "\Bliss.bmp") 
  
 ret = PictureBoxSaveJPG(Picture1, App.Path & "\test1.jpg") 
 If ret = False Then 
 MsgBox "保存失败" 
 End If 
End Sub 

Private Sub Command2_Click() 
 Dim ret As Boolean 

 ret = BMPFiletoJPG(App.Path & "\Bliss.bmp", App.Path & "\test2.jpg") 
 If ret = False Then 
 MsgBox "保存失败" 
 End If 
End Sub 

Private Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean 
 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 Function BMPFiletoJPG(ByVal srcfilename As String, ByVal destfilename As String, Optional ByVal quality As Byte = 80) As Boolean 
 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 = GdipCreateBitmapFromFile(StrPtr(srcfilename), 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(destfilename), tJpgEncoder, tParams) 
  
 '销毁GDI+图像 
 GdipDisposeImage lBitmap 
 End If 
  
 '销毁 GDI+ 
 GdiplusShutdown lGDIP 
 End If 
  
 If lRes Then 
 BMPFiletoJPG = False 
 Else 
 BMPFiletoJPG = True 
 End If 
End Function