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
