GDI+_SavePic

 Option Explicit

 Private Const UnitPixel                  As Long =
 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 =
     EncoderParameterValueTypeASCII =
     EncoderParameterValueTypeShort =
     EncoderParameterValueTypeLong =
     EncoderParameterValueTypeRational =
     EncoderParameterValueTypeLongRange =
     EncoderParameterValueTypeUndefined =
     EncoderParameterValueTypeRationalRange =
 End Enum

 Private Type EncoderParameter
     GUID( To )        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( To )     As Long
     FormatID( To )    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 = ) 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 =
     Jpg =
     Png =
     Gif =
 End Enum

 Public Function SaveStdPicToFile(Stdpic As StdPicture, ByVal FileName As String, _
                               Optional ByVal FileFormat As ImageFileFormat = Jpg, _
                               Optional ByVal JpgQuality As Long = , _
                               Optional Resolution As Single) As Boolean

     Dim CLSID()        As Long
     Dim Bitmap          As Long
     Dim Token           As Long
     Dim Gsp             As GdiplusStartupInput

     Gsp.GdiplusVersion =                       'GDI+ 1.0版本
     GdiplusStartup Token, Gsp                   '初始化GDI+
     GdipCreateBitmapFromHBITMAP Stdpic.Handle, Stdpic.hPal, Bitmap
     If Bitmap <>  Then                          '说明我们成功的将StdPic对象转换为GDI+的Bitmap对象了
         GdipBitmapSetResolution Bitmap, Resolution, Resolution
         Select Case FileFormat
         Case ImageFileFormat.Bmp
             If Not GetEncoderClsID("Image/bmp", CLSID) = - Then
                 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(), ByVal ) = )
             End If
         Case ImageFileFormat.Jpg                    'JPG格式可以设置保存的质量
             Dim aEncParams()        As Byte
             Dim uEncParams          As EncoderParameters
             If GetEncoderClsID("Image/jpeg", CLSID) <> - Then
                 uEncParams.Count =                                         ' 设置自定义的编码参数，这里为1个参数
                 If JpgQuality <  Then
                     JpgQuality =
                 ElseIf JpgQuality >  Then
                     JpgQuality =
                 End If
                 ReDim aEncParams( To Len(uEncParams))
                 With uEncParams.Parameter
                     .NumberOfValues =
                     .Type = EncoderParameterValueTypeLong                   ' 设置参数值的数据类型为长整型
                     Call CLSIDFromString(StrPtr(EncoderQuality), .GUID())  ' 设置参数唯一标志的GUID，这里为编码品质
                     .Value = VarPtr(JpgQuality)                                ' 设置参数的值：品质等级，最高为100，图像文件大小与品质成正比
                 End With
                 CopyMemory aEncParams(), uEncParams, Len(uEncParams)
                 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(), aEncParams()) = )
             End If
         Case ImageFileFormat.Png
             If Not GetEncoderClsID("Image/png", CLSID) = - Then
                 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(), ByVal ) = )
             End If
         Case ImageFileFormat.Gif
             If Not GetEncoderClsID("Image/gif", CLSID) = - Then                '如果原始的图像是24位，则这个函数会调用系统的调色板来将图像转换为8位，转换的效果会不尽人意,但也有可能系统不自动转换，保存失败
                 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(), ByVal ) = )
             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 = -
     GdipGetImageEncodersSize Num, Size               '得到解码器数组的大小
     If Size <>  Then
        ReDim Info( To Num) As ImageCodecInfo       '给数组动态分配内存
        ReDim Buffer( To Size) As Byte
        GdipGetImageEncoders Num, Size, Buffer()            '得到数组和字符数据
        CopyMemory Info(), Buffer(), (Len(Info()) * Num)     '复制类头
        For I =  To Num             '循环检测所有解码
            If (StrComp(PtrToStrW(Info(I).MimeType), strMimeType, vbTextCompare) = ) Then         '必须把指针转换成可用的字符
                CopyMemory ClassID(), Info(I).ClassID(),   '保存类的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 >  Then
         Out = StrConv(String$(Length, vbNullChar), vbUnicode)
         CopyMemory ByVal Out, ByVal lpsz, Length *
         PtrToStrW = StrConv(Out, vbFromUnicode)
     End If
 End Function