VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています(切り貼りとも言います)。
  1. ホーム
  2. GDI+
  3. クリップボードのbitmapをjpeg保存


クリップボードのbitmapをjpeg保存【XL2010 OK】

クリップボードのbitmap形式の画像データをjpeg形式で保存します

Public Enum GDIPlusStatusConstants
    Ok = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
    ProfileNotFound = 21
End Enum

Private Type Guid
        Data1          As Long
        Data2          As Integer
        Data3          As Integer
        Data4(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(15) As EncoderParameter
End Type

Private Type PICTDESC
        cbSizeofstruct As Long
        picType        As Long
        hImage         As Long
        Option1        As Long
        Option2        As Long
End Type

' // Declareations --------------------------------------------------
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
        ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
        ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
        ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
        ByRef lpPictDesc As PICTDESC, _
        ByRef RefIID As Guid, _
        ByVal fPictureOwnsHandle As Long, _
        ByRef IPic As IPicture) As Long
Private Declare Function CopyImage Lib "user32.dll" _
    (ByVal hImage As Long, ByVal uType As Long, ByVal cxDesired As Long, _
    ByVal cyDesired As Long, ByVal fuFlags As Long) As Long
'GDI+
Private Declare Function GdiplusStartup Lib "gdiplus.dll" _
    (ByRef token As Long, ByRef inputBuf As GdiplusStartupInput, ByVal outputBuf As Long) As GDIPlusStatusConstants
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" _
    (ByVal hbm As Long, ByVal hpal As Long, ByRef bitmap As Long) As GDIPlusStatusConstants
Private Declare Function GdipDisposeImage Lib "gdiplus.dll" _
    (ByVal Image As Long) As GDIPlusStatusConstants
Private Declare Function GdipSaveImageToFile Lib "gdiplus.dll" _
    (ByVal Image As Long, ByVal filename As Long, ByRef clsidEncoder As Guid, ByVal encoderParams As Long) As GDIPlusStatusConstants
Private Declare Function CLSIDFromString Lib "ole32" _
    (ByVal lpszCLSID As Long, ByRef pclsid As Guid) As Long
        
' // Constants ------------------------------------------------------
Private Const CF_BITMAP      As Long = 2
Private Const CF_PALETTE     As Long = 9

Private Const CLSID_PNG = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_JPEG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_QUALITY = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

'使用例
Sub saveCBtoJPEG()
    Dim myStdPicture As StdPicture
    Dim gdipRet As GDIPlusStatusConstants
    
    Set myStdPicture = CreatePictureFromClipboard
    gdipRet = SavePictureJpg(myStdPicture, "c:\cb2jpeg.jpg", 85)
End Sub

' // クリップボードのビットマップデータから Picture オブジェクトを作成
'http://okwave.jp/qa/q2885043.html
'KenKen_SPさん
Public Function CreatePictureFromClipboard() As StdPicture
    Dim hImg      As Long
    Dim hPalette As Long
    Dim uPictDesc As PICTDESC
    Dim uGUID     As Guid
  
    Set CreatePictureFromClipboard = Nothing
    ' 終了条件:: クリップボードに該当データが無い
    If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then Exit Function
    ' 終了条件:: クリップボードからイメージハンドルが取得できない
    If OpenClipboard(0&) <> 0 Then
        hImg = GetClipboardData(CF_BITMAP)
        hPalette = GetClipboardData(CF_PALETTE)
        Call CloseClipboard
    End If
    If hImg = 0 Then Exit Function
    With uPictDesc
        .cbSizeofstruct = Len(uPictDesc)
        .picType = 1
        .hImage = hImg
        .Option1 = hPalette
    End With
    With uGUID
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    Call OleCreatePictureIndirect(uPictDesc, _
                                  uGUID, _
                                  0&, _
                                  CreatePictureFromClipboard)
End Function

'http://hpcgi1.nifty.com/MADIA/VBBBS2/wwwlng.cgi?print+200708/07080012.txt
'紅閃光さん
Public Function SavePicturePng(ByVal PicObj As IPictureDisp, ByVal FName As String) As GDIPlusStatusConstants
    Dim GdiPStartupInput    As GdiplusStartupInput
    Dim Ret                 As GDIPlusStatusConstants
    Dim GDIPToken           As Long
    Dim GdipBmpHdl          As Long
    
    ' ピクチャーオブジェクトが無い
    If PicObj Is Nothing Then
        SavePicturePng = GDIPlusStatusConstants.UnknownImageFormat
        Exit Function
    End If
    ' GDIスタートアップ構造体初期化
    GdiPStartupInput.GdiplusVersion = 1
    ' GDI+ライブラリ初期化して失敗なら終了
    If GdiplusStartup(GDIPToken, GdiPStartupInput, 0&) <> 0 Then Exit Function
    ' ピクチャーからGDI+BITMAPを作成
    Ret = GdipCreateBitmapFromHBITMAP(PicObj.Handle, 0&, GdipBmpHdl)
    ' 変換成功
    If Ret = GDIPlusStatusConstants.Ok Then
        ' PNG変換で保存
        SavePicturePng = GdipSaveImageToFile(GdipBmpHdl, StrPtr(FName), ConvCLSID(CLSID_PNG), 0)
        ' GDI+BITMAPを廃棄
        GdipDisposeImage GdipBmpHdl
    End If
    ' GDI+ライブラリ開放
    GdiplusShutdown GDIPToken
End Function

Public Function SavePictureJpg(ByVal PicObj As IPictureDisp, ByVal FName As String, ByVal Quality As Long) As GDIPlusStatusConstants
    Dim GdiPStartupInput    As GdiplusStartupInput
    Dim Ret                 As GDIPlusStatusConstants
    Dim GDIPToken           As Long
    Dim GdipBmpHdl          As Long
    Dim EncodParameters     As EncoderParameters
    
    ' 圧縮品質設定範囲のチェック
    If Quality > 100 Then Quality = 100
    If Quality < 25 Then Quality = 25
    ' ピクチャーオブジェクトが無い
    If PicObj Is Nothing Then
        SavePictureJpg = GDIPlusStatusConstants.UnknownImageFormat
        Exit Function
    End If
    ' GDIスタートアップ構造体初期化
    GdiPStartupInput.GdiplusVersion = 1
    ' GDI+ライブラリ初期化して失敗なら終了
    If GdiplusStartup(GDIPToken, GdiPStartupInput, 0&) <> 0 Then Exit Function
    ' ピクチャーからGDI+BITMAPを作成
    Ret = GdipCreateBitmapFromHBITMAP(PicObj.Handle, 0&, GdipBmpHdl)
    If Ret = GDIPlusStatusConstants.Ok Then
        ' エンコーダパラメータ設定
        EncodParameters.Count = 1
        With EncodParameters.Parameter(0)
            .Guid = ConvCLSID(CLSID_QUALITY)
            .NumberOfValues = 1
            ' 4=EncoderParameterValueTypeLong
            .Type = 4
            ' 圧縮品質
            .Value = VarPtr(Quality)
        End With
        ' JPG変換で保存
        SavePictureJpg = GdipSaveImageToFile(GdipBmpHdl, StrPtr(FName), ConvCLSID(CLSID_JPEG), VarPtr(EncodParameters))
        ' GDI+BITMAPを廃棄
        GdipDisposeImage GdipBmpHdl
    End If
    ' GDI+ライブラリ開放
    GdiplusShutdown GDIPToken
End Function

Private Function ConvCLSID(ByVal sGuid As String) As Guid
    CLSIDFromString StrPtr(sGuid), ConvCLSID
End Function