图片格式转换的代码

　　想在自己的程序中将图片随心所欲地转换成各种主流格式吗？没问题，本代码就让你实现这个心愿！
　　本代码能够将图像保存为５种主流格式：bmp、jpg、png、gif、tif。代码很简炼，就不多作解释了。需要说明的是转换后的gif格式是单张图像，而不是gif动画。
　　新建一个窗体，在上面添加一个图片框和一个按纽。窗体和图片框的ScaleMode属性都设置为３，图片框的名称改为pic3（呵呵，这是因为在我的程序中，它就是这个名称，当然你可以改为任意名称，但有关代码必须也要相应改动）。
　　代码如下：

Option Explicit

Private Enum EncoderParameterValueType
  EncoderParameterValueTypeByte = 1
  EncoderParameterValueTypeASCII = 2
  EncoderParameterValueTypeShort = 3
  EncoderParameterValueTypeLong = 4
  EncoderParameterValueTypeRational = 5
  EncoderParameterValueTypeLongRange = 6
  EncoderParameterValueTypeUndefined = 7
  EncoderParameterValueTypeRationalRange = 8
End Enum

Private Type GdiplusStartupInput
  GdiplusVersion           As Long
  DebugEventCallback       As Long
  SuppressBackgroundThread As Long
  SuppressExternalCodecs   As Long
End Type

Private Type EncoderParameter1
  GUID(0 To 3)      As Long
  NumberOfvalues    As Long
  Type              As EncoderParameterValueType
  Value             As Long
End Type
Private Type EncoderParameters1
  Count             As Long
  Parameter         As EncoderParameter1
End Type

Private Type ImageCodecInfo
  ClassID(0 To 3)   As Long
  FormatID(0 To 3)  As Long
  CodecName         As Long
  DllName           As Long
  FormatDescription As Long
  FilenameExtension As Long
  MimeType          As Long
  Flags             As Long
  Version           As Long
  SigCount          As Long
  SigSize           As Long
  SigPattern        As Long
  SigMask           As Long
End Type

Private Type GUID
  Data1  As Long
  Data2  As Integer
  Data3  As Integer
  Data4(0 To 7) As Byte
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 Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal hImage As Long, ByVal sFilename As Long, clsidEncoder As Any, encoderParams As Any) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image 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 GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As Long
Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus.dll" (ByVal hdc As Long, ByRef graphics As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
Private Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal Bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long

Private Enum ImageFileFormat
  Bmp = 1
  Jpg = 2
  Png = 3
  Gif = 4
End Enum

Private Sub Command1_Click()
On Error GoTo 100
Dim OpenName As String
Dim dlg As Object
Set dlg = CreateObject("MSComDlg.CommonDialog")

With dlg
  .DialogTitle = "打开"
  .Flags = &H1000
  .CancelError = True
  .Filter = "图片 bmp,jpg,gif,png,wmf,tif|*.bmp;*.jpg;*.gif;*.png;*.wmf;*.tif"
  .showopen
  OpenName = .FileName
End With

Pic3.Picture = LoadPicture(OpenName)
SavePic Pic3, "C:\Users\Administrator\Desktop\100.bmp", 1
SavePic Pic3, "C:\Users\Administrator\Desktop\100.jpg", 2
SavePic Pic3, "C:\Users\Administrator\Desktop\100.png", 3
SavePic Pic3, "C:\Users\Administrator\Desktop\100.gif", 4
SaveTif Pic3, "C:\Users\Administrator\Desktop\100.tif"
MsgBox "转换并保存完毕"
100
End Sub

'输入参数：1.对象，2.文件名，3.tif颜色深度，4.tif压缩比
Private Function SaveTif(ByVal pict As StdPicture, SaveName As String, Optional ByVal TIF_ColorDepth As Long = 24, Optional ByVal TIF_Compression As Long = 6) As Integer
On Error GoTo 100
Dim lBitmap As Long
Dim aEncParams() As Byte
Dim m_lngGraphics As Long
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters '初始化解码器的GUID标识
Dim udtData As GdiplusStartupInput
Dim lGDIP As Long

udtData.GdiplusVersion = 1 'GDI+初始化
GdiplusStartup lGDIP, udtData, 0
If GdipCreateFromHDC(Pic3.hdc, m_lngGraphics) Then MsgBox "未能创建 Graphics 对象": Exit Function
If GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap) Then Exit Function '从句柄创建 GDI+ 图像
   
CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
tParams.Count = 2
ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))

With tParams.Parameter
  .NumberOfvalues = 1
  .Type = 4
  CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID  '得到颜色深度的GUID标识
  .Value = VarPtr(TIF_Compression)
End With
       
Call CopyMemory(aEncParams(1), tParams, Len(tParams))
       
With tParams.Parameter
  .NumberOfvalues = 1
  .Type = 4
  CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID  '得到压缩比的GUID标识
  .Value = VarPtr(TIF_ColorDepth)
End With
       
Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))
GdipSaveImageToFile lBitmap, StrPtr(SaveName), tJpgEncoder, aEncParams(1) '保存图像
GdipDisposeImage lBitmap '销毁GDI+图像
Erase aEncParams

100
GdiplusShutdown lGDIP
SaveTif = Err.Number
End Function

Private Function SavePic(Stdpic As StdPicture, ByVal FileName As String, Optional ByVal FileFormat As ImageFileFormat = Jpg, Optional ByVal JpgQuality As Long = 85, Optional ByVal TIF_ColorDepth As Long = 24, Optional ByVal TIF_Compression As Long = 6) As Boolean
Dim CLSID(3) As Long
Dim Bitmap   As Long
Dim Token    As Long
Dim Gsp      As GdiplusStartupInput

Gsp.GdiplusVersion = 1    'GDI+ 1.0版本
GdiplusStartup Token, Gsp '初始化GDI+
GdipCreateBitmapFromHBITMAP Stdpic.Handle, Stdpic.hPal, Bitmap '将StdPic对象转换为GDI+的Bitmap对象
If Bitmap <> 0 Then
  GdipBitmapSetResolution Bitmap, 0, 0
  Select Case FileFormat
   
    Case ImageFileFormat.Bmp
      If Not GetEncoderClsID("Image/bmp", CLSID) = -1 Then
        SavePic = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)
      End If

    Case ImageFileFormat.Jpg
      Dim aEncParams() As Byte
      Dim uEncParams   As EncoderParameters1
      If GetEncoderClsID("Image/jpeg", CLSID) <> -1 Then
        uEncParams.Count = 1       '设置编码参数为1个
        JpgQuality = 85
        ReDim aEncParams(1 To Len(uEncParams))
        With uEncParams.Parameter
          .NumberOfvalues = 1
          .Type = EncoderParameterValueTypeLong  '设置参数值的数据类型为长整型
          Call CLSIDFromString(StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID(0)) '设置编码品质
          .Value = VarPtr(JpgQuality)            '设置品质等级，最高为100，图像文件大小与品质成正比
        End With
        CopyMemory aEncParams(1), uEncParams, Len(uEncParams)
        SavePic = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), aEncParams(1)) = 0)
      End If

    Case ImageFileFormat.Png
      If Not GetEncoderClsID("Image/png", CLSID) = -1 Then
        SavePic = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)
      End If

    Case ImageFileFormat.Gif
      If Not GetEncoderClsID("Image/gif", CLSID) = -1 Then '如果原始图像是24位，这个函数会调用系统的调色板转为8位，有可能不自动转换，导致保存失败
        SavePic = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)
      End If
 
  End Select
End If
GdipDisposeImage Bitmap '释放资源
GdiplusShutdown Token   '关闭GDI+
End Function

Private Function GetEncoderClsID(strMimeType As String, ClassID() As Long) As Long
Dim Num      As Long
Dim Size     As Long
Dim I        As Long
Dim Info()   As ImageCodecInfo
Dim Buffer() As Byte

GetEncoderClsID = -1
GdipGetImageEncodersSize Num, Size       '得到解码器数组的大小
If Size <> 0 Then
  ReDim Info(1 To Num) As ImageCodecInfo '给数组动态分配内存
  ReDim Buffer(1 To Size) As Byte
  GdipGetImageEncoders Num, Size, Buffer(1)           '得到数组和字符数据
  CopyMemory Info(1), Buffer(1), (Len(Info(1)) * Num) '复制类头
  For I = 1 To Num        '循环检测所有解码
    If (StrComp(PtrToStrW(Info(I).MimeType), strMimeType, vbTextCompare) = 0) Then '把指针转换成可用的字符
      CopyMemory ClassID(0), Info(I).ClassID(0), 16   '保存类ID
      GetEncoderClsID = I '如果成功返回索引值
      Exit For
    End If
  Next
End If
End Function

Private Function PtrToStrW(ByVal lpsz As Long) As String
Dim Out    As String
Dim Length As Long

Length = lstrlenW(lpsz)
If Length > 0 Then
  Out = StrConv(String$(Length, vbNullChar), vbUnicode)
  CopyMemory ByVal Out, ByVal lpsz, Length * 2
  PtrToStrW = StrConv(Out, vbFromUnicode)
End If
End Function