Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _

                    Optional ByVal quality As Byte = 80, _

                    Optional ByVal TIFF_ColorDepth As Long = 24, _

                    Optional ByVal TIFF_Compression As Long = 6)

                    

   Screen.MousePointer = vbHourglass

   Dim tSI As GdiplusStartupInput

   Dim lRes As Long

   Dim lGDIP As Long

   Dim lBitmap As Long

   Dim aEncParams() As Byte

   On Error GoTo ErrHandle:

   tSI.GdiplusVersion = 1   ' 初始化 GDI+

   lRes = GdiplusStartup(lGDIP, tSI)

   If lRes = 0 Then     ' 从句柄创建 GDI+ 图像

      lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)

      If lRes = 0 Then

         Dim tJpgEncoder As GUID

         Dim tParams As EncoderParameters    '初始化解码器的GUID标识

         Select Case PicType

         Case ".jpg"

            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder

            tParams.count = 1                               ' 设置解码器参数

            With tParams.Parameter ' Quality

               CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID    ' 得到Quality参数的GUID标识

               .NumberOfValues = 1

               .type = 4

               .Value = VarPtr(quality)

            End With

            ReDim aEncParams(1 To Len(tParams))

            Call CopyMemory(aEncParams(1), tParams, Len(tParams))

        Case ".png"

             CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder

             ReDim aEncParams(1 To Len(tParams))

        Case ".gif"

             CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder

             ReDim aEncParams(1 To Len(tParams))

        Case ".tiff"

             CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder

             tParams.count = 2

             ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))

             With tParams.Parameter

                .NumberOfValues = 1

                .type = 4

                 CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID    ' 得到ColorDepth参数的GUID标识

                .Value = VarPtr(TIFF_Compression)

            End With

            Call CopyMemory(aEncParams(1), tParams, Len(tParams))

            With tParams.Parameter

                .NumberOfValues = 1

                .type = 4

                 CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID    ' 得到Compression参数的GUID标识

                .Value = VarPtr(TIFF_ColorDepth)

            End With

            Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))

        Case ".bmp"                                               '可以提前写保存为BMP的代码，因为并没有用GDI+

            SavePicture pict, FileName

            Screen.MousePointer = vbDefault

            Exit Sub

        End Select

         lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1))           '保存图像

         GdipDisposeImage lBitmap       ' 销毁GDI+图像

      End If

      GdiplusShutdown lGDIP              '销毁 GDI+

   End If

   Screen.MousePointer = vbDefault

   Erase aEncParams

   Exit Sub

ErrHandle:

    Screen.MousePointer = vbDefault

    MsgBox "在保存图片的过程中发生错误:" & vbCrLf & vbCrLf & "错误号:  " & Err.Number & vbCrLf & "错误描述:  " & Err.Description, vbInformation Or vbOKOnly, "错误"

End Sub