保存StdPicture到JPG图片文件的函数

tmtony · 发表于 2008-1-5 16:40:21

Private Type Guid
      Data1 As Long
      Data2 As Integer
      Data3 As Integer
      Data4(0 To 7)    As Byte
  End Type

  Private Type GdiplusStartupInput
      GdiPlusVersion As Long
      DebugEventCallback As Long
      SuppressBackgroundThread As Long
      SuppressExternalCodecs As Long
  End Type

  Private Type EncoderParameter
      Guid As Guid
      NumberOfValues As Long
      type As Long
      Value As Long
  End Type

  Private Type EncoderParameters
      Count As Long
      Parameter As EncoderParameter
  End Type

  Private Declare Function GdiplusStartup Lib "gdiplus" ( _
      token As Long, _
      inputbuf As GdiplusStartupInput, _
      Optional ByVal outputbuf As Long = 0) As Long

  Private Declare Function GdiplusShutdown Lib "gdiplus" ( _
      ByVal token 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 GdipDisposeImage Lib "gdiplus" ( _
      ByVal image As Long) As Long

  Private Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
      ByVal image As Long, _
      ByVal FileName As Long, _
      clsidEncoder As Guid, _
      encoderParams As Any) As Long

  Private Declare Function CLSIDFromString Lib "ole32" ( _
      ByVal str As Long, _
      id As Guid) As Long

  ' ----==== SaveJPG ====----

  Public Sub SaveJPG( _
      ByVal pict As StdPicture, _
      ByVal FileName As String, _
      Optional ByVal quality As Byte = 80)
  Dim tSI    As GdiplusStartupInput
  Dim lRes    As Long
  Dim lGDIP    As Long
  Dim lBitmap    As Long

      ' Initialize GDI+
      tSI.GdiPlusVersion = 1
      lRes = GdiplusStartup(lGDIP, tSI)

      If lRes = 0 Then

            ' Create the GDI+ bitmap
            ' from the image handle
            lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)

            If lRes = 0 Then
                  Dim tJpgEncoder    As Guid
                  Dim TParams    As EncoderParameters

                  ' Initialize the encoder GUID
                  CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), _
                                                tJpgEncoder

                  ' Initialize the encoder parameters
                  TParams.Count = 1
                  With TParams.Parameter    ' Quality
                        ' Set the Quality GUID
                        CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB3505E7EB}"), .Guid
                        .NumberOfValues = 1
                        .type = 1
                        .Value = VarPtr(quality)
                  End With

                  ' Save the image
                  lRes = GdipSaveImageToFile( _
                                    lBitmap, _
                                    StrPtr(FileName), _
                                    tJpgEncoder, _
                                    TParams)

                  ' Destroy the bitmap
                  GdipDisposeImage lBitmap

            End If

            ' Shutdown GDI+
            GdiplusShutdown lGDIP

      End If

      If lRes Then
            Err.Raise 5, , "Cannot save the image. GDI+ Error:" & lRes
      End If

  End Sub