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
    nGUID As GUID
    NumberOfValues As Long
    Type As Long
    Value As Long
End Type
Private Type EncoderParameters
    Count As Long
    Parameter As EncoderParameter
End Type
Enum PicType
   p_BMP
   p_JPG
   p_GIF
   p_PNG
   p_TIFF
End Enum
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) 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 CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long

Public Function SavePicToFile(ByVal nPic As StdPicture, ByVal FileName As String, _
   Optional ByVal nType As PicType = p_JPG, Optional ByVal Quality As Byte = 80, _
   Optional ByVal TIFF_ColorDepth As Long = 24, Optional ByVal TIFF_Compression As Long = 6) As String
   '功能：把圖象保存為 BMP、JPG、GIF、PNG、TIFF 格式。成功返回空字符串，失敗返回錯(cuò)誤信息
   '如果保存的文件名無擴(kuò)展名，則自動(dòng)添加相應(yīng)的擴(kuò)展名
   'StdPicture)          圖象句柄
   'FileName             保存文件名
   'nType                文件格式：0 BMP 1 JPG 2 GIF 3 PNG 4 TIFF
   'Quality              JPG 圖象質(zhì)量
   'TIFF_ColorDepth      TTF 格式的顏色深度
   'TIFF_Compression     TTF 格式的壓縮比
   Dim dl As Long, nGDIP As Long, nBMP As Long
   Dim nGSI As GdiplusStartupInput, B() As Byte
  
   On Error GoTo Cuo
   nGSI.GdiplusVersion = 1   ' 初始化 GDI+
   dl = GdiplusStartup(nGDIP, nGSI)
   If dl <> 0 Then SavePicToFile = "無法創(chuàng)建 GDI 圖像": Exit Function
  
   dl = GdipCreateBitmapFromHBITMAP(nPic.Handle, 0, nBMP)
   If dl <> 0 Then GdiplusShutdown nGDIP: SavePicToFile = "不支持圖片格式": Exit Function
  
   Dim mGUID As GUID, mEP As EncoderParameters '初始化解碼器的 GUID 標(biāo)識(shí)
   Select Case nType
   Case p_JPG
     If LCase(Right(FileName, 4)) <> ".jpg" Then FileName = FileName & ".jpg"
      CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), mGUID
      mEP.Count = 1     ' 設(shè)置解碼器參數(shù)
      With mEP.Parameter
         CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .nGUID '得到 GUID 標(biāo)識(shí)
         .NumberOfValues = 1
         .Type = 4
         .Value = VarPtr(Quality)
      End With
      ReDim B(1 To Len(mEP))
      Call CopyMemory(B(1), mEP, Len(mEP))
   Case p_GIF
      If LCase(Right(FileName, 4)) <> ".gif" Then FileName = FileName & ".gif"
      CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), mGUID
      ReDim B(1 To Len(mEP))
   Case p_PNG
      If LCase(Right(FileName, 4)) <> ".png" Then FileName = FileName & ".png"
      CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), mGUID
      ReDim B(1 To Len(mEP))
   Case p_TIFF
      If LCase(Right(FileName, 5)) <> ".tiff" Then FileName = FileName & ".tiff"
      CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), mGUID
      mEP.Count = 2
      ReDim B(1 To Len(mEP) + Len(mEP.Parameter))
      With mEP.Parameter
         .NumberOfValues = 1
         .Type = 4
          CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .nGUID
         .Value = VarPtr(TIFF_Compression)
       End With
       Call CopyMemory(B(1), mEP, Len(mEP))
       With mEP.Parameter
           .NumberOfValues = 1
           .Type = 4
            CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .nGUID
           .Value = VarPtr(TIFF_ColorDepth)
       End With
       Call CopyMemory(B(Len(mEP) + 1), mEP.Parameter, Len(mEP.Parameter))
   Case Else 'p_BMP 沒有使用 GDI+
       If LCase(Right(FileName, 4)) <> ".bmp" Then FileName = FileName & ".bmp"
       SavePicture nPic, FileName
       Exit Function
   End Select
   dl = GdipSaveImageToFile(nBMP, StrPtr(FileName), mGUID, B(1)) '保存到文件
   GdipDisposeImage nBMP       '銷毀 GDI+ 圖像
   GdiplusShutdown nGDIP       '銷毀 GDI+
   Exit Function

Cuo:
   SavePicToFile = "錯(cuò)誤 " & Err.Number & "：" & Err.Description
End Function

Private Sub Form_Load()
   Me.Caption = "圖片格式轉(zhuǎn)換": Command1.Caption = "轉(zhuǎn)換"
   Text1.Text = "E:\MyPic.bmp"
End Sub

Private Sub Command1_Click()
   Dim nStr As String, F As String
   Picture1.AutoSize = True: Command1.ZOrder
   F = Trim(Text1.Text)
   Picture1.Picture = LoadPicture(F)
   '默認(rèn)保存為 JPG 格式，如果無擴(kuò)展名，則自動(dòng)添加擴(kuò)展名。成功返回空字符串
   F = NoKuo(F) '去掉原擴(kuò)展名
   nStr = SavePicToFile(Picture1.Picture, F)
   If nStr <> "" Then MsgBox nStr
End Sub

Private Function NoKuo(F As String) As String
   Dim I As Long
   For I = Len(F) To 1 Step -1
      If Mid(F, I, 1) = "." Then NoKuo = Left(F, I - 1): Exit Function
   Next
   NoKuo = F
End Function