GDI+_SavePic

Posted 2021-02-08 lingqingxue

  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