VB6.0用GDI+保存图像为BMP\JPG\PNG\GIF格式终结版。
鉴于之前在http://blog.csdn.net/laviewpbt/article/details/756547发布的代码很匆忙，也存在不少错误，现发布比较完美版的解决方案。
Option Explicit Private Const UnitPixel As Long = 2 Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}" Private Type GdiplusStartupInput GdiplusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As Long End Type Private Enum EncoderParameterValueType EncoderParameterValueTypeByte = 1 EncoderParameterValueTypeASCII = 2 EncoderParameterValueTypeShort = 3 EncoderParameterValueTypeLong = 4 EncoderParameterValueTypeRational = 5 EncoderParameterValueTypeLongRange = 6 EncoderParameterValueTypeUndefined = 7 EncoderParameterValueTypeRationalRange = 8 End Enum Private Type EncoderParameter GUID(0 To 3) As Long NumberOfValues As Long Type As EncoderParameterValueType Value As Long End Type Private Type EncoderParameters Count As Long Parameter As EncoderParameter 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 Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token 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 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 Public Enum ImageFileFormat Bmp = 1 Jpg = 2 Png = 3 Gif = 4 End Enum Public Function SaveStdPicToFile(Stdpic As StdPicture, ByVal FileName As String, _ Optional ByVal FileFormat As ImageFileFormat = Jpg, _ Optional ByVal JpgQuality As Long = 80, _ Optional Resolution As Single) 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 If Bitmap <> 0 Then '说明我们成功的将StdPic对象转换为GDI+的Bitmap对象了 GdipBitmapSetResolution Bitmap, Resolution, Resolution Select Case FileFormat Case ImageFileFormat.Bmp If Not GetEncoderClsID("Image/bmp", CLSID) = -1 Then SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0) End If Case ImageFileFormat.Jpg 'JPG格式可以设置保存的质量 Dim aEncParams() As Byte Dim uEncParams As EncoderParameters If GetEncoderClsID("Image/jpeg", CLSID) <> -1 Then uEncParams.Count = 1 ' 设置自定义的编码参数，这里为1个参数 If JpgQuality < 0 Then JpgQuality = 0 ElseIf JpgQuality > 100 Then JpgQuality = 100 End If ReDim aEncParams(1 To Len(uEncParams)) With uEncParams.Parameter .NumberOfValues = 1 .Type = EncoderParameterValueTypeLong ' 设置参数值的数据类型为长整型 Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0)) ' 设置参数唯一标志的GUID，这里为编码品质 .Value = VarPtr(JpgQuality) ' 设置参数的值：品质等级，最高为100，图像文件大小与品质成正比 End With CopyMemory aEncParams(1), uEncParams, Len(uEncParams) SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), aEncParams(1)) = 0) End If Case ImageFileFormat.Png If Not GetEncoderClsID("Image/png", CLSID) = -1 Then SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0) End If Case ImageFileFormat.Gif If Not GetEncoderClsID("Image/gif", CLSID) = -1 Then '如果原始的图像是24位，则这个函数会调用系统的调色板来将图像转换为8位，转换的效果会不尽人意,但也有可能系统不自动转换，保存失败 SaveStdPicToFile = (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
