1 Option Explicit 2 3 Private Const UnitPixel As Long = 2 4 Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}" 5 6 Private Type GdiplusStartupInput 7 GdiplusVersion As Long 8 DebugEventCallback As Long 9 SuppressBackgroundThread As Long 10 SuppressExternalCodecs As Long 11 End Type 12 13 Private Enum EncoderParameterValueType 14 EncoderParameterValueTypeByte = 1 15 EncoderParameterValueTypeASCII = 2 16 EncoderParameterValueTypeShort = 3 17 EncoderParameterValueTypeLong = 4 18 EncoderParameterValueTypeRational = 5 19 EncoderParameterValueTypeLongRange = 6 20 EncoderParameterValueTypeUndefined = 7 21 EncoderParameterValueTypeRationalRange = 8 22 End Enum 23 24 Private Type EncoderParameter 25 GUID(0 To 3) As Long 26 NumberOfValues As Long 27 Type As EncoderParameterValueType 28 Value As Long 29 End Type 30 31 Private Type EncoderParameters 32 Count As Long 33 Parameter As EncoderParameter 34 End Type 35 36 Private Type ImageCodecInfo 37 ClassID(0 To 3) As Long 38 FormatID(0 To 3) As Long 39 CodecName As Long 40 DllName As Long 41 FormatDescription As Long 42 FilenameExtension As Long 43 MimeType As Long 44 Flags As Long 45 Version As Long 46 SigCount As Long 47 SigSize As Long 48 SigPattern As Long 49 SigMask As Long 50 End Type 51 52 Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long 53 Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long) 54 Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal hImage As Long, ByVal sFilename As Long, clsidEncoder As Any, encoderParams As Any) As Long 55 Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long 56 Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long 57 Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As Long 58 Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long 59 60 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 61 Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long 62 Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long 63 Private Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal Bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long 64 65 66 Public Enum ImageFileFormat 67 Bmp = 1 68 Jpg = 2 69 Png = 3 70 Gif = 4 71 End Enum 72 73 Public Function SaveStdPicToFile(Stdpic As StdPicture, ByVal FileName As String, _ 74 Optional ByVal FileFormat As ImageFileFormat = Jpg, _ 75 Optional ByVal JpgQuality As Long = 80, _ 76 Optional Resolution As Single) As Boolean 77 78 Dim CLSID(3) As Long 79 Dim Bitmap As Long 80 Dim Token As Long 81 Dim Gsp As GdiplusStartupInput 82 83 Gsp.GdiplusVersion = 1 'GDI+ 1.0版本 84 GdiplusStartup Token, Gsp '初始化GDI+ 85 GdipCreateBitmapFromHBITMAP Stdpic.Handle, Stdpic.hPal, Bitmap 86 If Bitmap <> 0 Then '说明我们成功的将StdPic对象转换为GDI+的Bitmap对象了 87 GdipBitmapSetResolution Bitmap, Resolution, Resolution 88 Select Case FileFormat 89 Case ImageFileFormat.Bmp 90 If Not GetEncoderClsID("Image/bmp", CLSID) = -1 Then 91 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0) 92 End If 93 Case ImageFileFormat.Jpg 'JPG格式可以设置保存的质量 94 Dim aEncParams() As Byte 95 Dim uEncParams As EncoderParameters 96 If GetEncoderClsID("Image/jpeg", CLSID) <> -1 Then 97 uEncParams.Count = 1 ' 设置自定义的编码参数，这里为1个参数 98 If JpgQuality < 0 Then 99 JpgQuality = 0 100 ElseIf JpgQuality > 100 Then 101 JpgQuality = 100 102 End If 103 ReDim aEncParams(1 To Len(uEncParams)) 104 With uEncParams.Parameter 105 .NumberOfValues = 1 106 .Type = EncoderParameterValueTypeLong ' 设置参数值的数据类型为长整型 107 Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0)) ' 设置参数唯一标志的GUID，这里为编码品质 108 .Value = VarPtr(JpgQuality) ' 设置参数的值：品质等级，最高为100，图像文件大小与品质成正比 109 End With 110 CopyMemory aEncParams(1), uEncParams, Len(uEncParams) 111 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), aEncParams(1)) = 0) 112 End If 113 Case ImageFileFormat.Png 114 If Not GetEncoderClsID("Image/png", CLSID) = -1 Then 115 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0) 116 End If 117 Case ImageFileFormat.Gif 118 If Not GetEncoderClsID("Image/gif", CLSID) = -1 Then '如果原始的图像是24位，则这个函数会调用系统的调色板来将图像转换为8位，转换的效果会不尽人意,但也有可能系统不自动转换，保存失败 119 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0) 120 End If 121 End Select 122 End If 123 GdipDisposeImage Bitmap '注意释放资源 124 GdiplusShutdown Token '关闭GDI+。 125 End Function 126 127 128 Private Function GetEncoderClsID(strMimeType As String, ClassID() As Long) As Long 129 Dim Num As Long 130 Dim Size As Long 131 Dim I As Long 132 Dim Info() As ImageCodecInfo 133 Dim Buffer() As Byte 134 GetEncoderClsID = -1 135 GdipGetImageEncodersSize Num, Size '得到解码器数组的大小 136 If Size <> 0 Then 137 ReDim Info(1 To Num) As ImageCodecInfo '给数组动态分配内存 138 ReDim Buffer(1 To Size) As Byte 139 GdipGetImageEncoders Num, Size, Buffer(1) '得到数组和字符数据 140 CopyMemory Info(1), Buffer(1), (Len(Info(1)) * Num) '复制类头 141 For I = 1 To Num '循环检测所有解码 142 If (StrComp(PtrToStrW(Info(I).MimeType), strMimeType, vbTextCompare) = 0) Then '必须把指针转换成可用的字符 143 CopyMemory ClassID(0), Info(I).ClassID(0), 16 '保存类的ID 144 GetEncoderClsID = I '返回成功的索引值 145 Exit For 146 End If 147 Next 148 End If 149 End Function 150 151 Private Function PtrToStrW(ByVal lpsz As Long) As String 152 Dim Out As String 153 Dim Length As Long 154 Length = lstrlenW(lpsz) 155 If Length > 0 Then 156 Out = StrConv(String$(Length, vbNullChar), vbUnicode) 157 CopyMemory ByVal Out, ByVal lpsz, Length * 2 158 PtrToStrW = StrConv(Out, vbFromUnicode) 159 End If 160 End Function