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


WS上のshapeをJPEG保存


現在CB→画像保管等に、Pictureを経由しているが、その冗長さをなくせるかも

'http://okwave.jp/qa/q5124395.html
'KenKenSPさん
' // クリップボード関係
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 Const CF_BITMAP   As Long = 2

' // GDI+関係
Private Declare Function GdiplusStartup Lib "gdiplus" ( _
        ByRef token As Long, _
        ByRef inputBuf As GdiplusStartupInput, _
        ByVal outputBuf As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" ( _
        ByVal token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" ( _
        ByVal hbm As Long, _
        ByVal hpal As Long, _
        ByRef 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, _
        ByRef clsidEncoder As GUID, _
        ByVal encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
        ByVal lpszCLSID As Long, _
        ByRef pCLSID As GUID) As Long

Private Type GdiplusStartupInput
        GdiplusVersion           As Long    ' UINT32 GdiplusVersion
        DebugEventCallback       As Long    ' DebugEventProc DebugEventCallback
        SuppressBackgroundThread As Long    ' BOOL SuppressBackgroundThread
        SuppressExternalCodecs   As Long    ' BOOL SuppressExternalCodecs
End Type
Private Type GUID
        Data1                    As Long    ' unsigned long Data1
        Data2                    As Integer ' unsigned short Data2
        Data3                    As Integer ' unsigned short Data3
        Data4(7)                 As Byte    ' unsigned char Data4[8]
End Type
Private Type EncoderParameter
        GUID                     As GUID    ' GUID Encoder Guid
        NumberOfValues           As Long    ' ULONG NumberOfValues
        TypeAPI                  As Long    ' ULONG Type
        Value                    As Long    ' VOID* Value
End Type
Private Type EncoderParameters
        count          As Long              ' UINT Count
        Parameter(15) As EncoderParameter   ' EncoderParameter Parameter[l]
End Type

Private Const QUALITY_PARAMS As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const ENCODER_BMP    As String = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_JPG    As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_GIF    As String = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_TIF    As String = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_PNG    As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"

Private m_GDIplusToken As Long

' // GDI+ 初期化
Private Function GDIplus_Initialize() As Boolean
  
    Dim uGdiStartupInput As GdiplusStartupInput
    Dim nStatus          As Long
  
    If m_GDIplusToken Then Call Gdiplus_Shutdown
    With uGdiStartupInput
        .GdiplusVersion = 1
        .DebugEventCallback = 0
        .SuppressBackgroundThread = 0
        .SuppressExternalCodecs = 0
    End With
    nStatus = GdiplusStartup(m_GDIplusToken, uGdiStartupInput, 0&)
    GDIplus_Initialize = CBool(nStatus = 0)

End Function

' // GDI+ 終了
Private Function Gdiplus_Shutdown() As Long
    If m_GDIplusToken Then
        Call GdiplusShutdown(m_GDIplusToken)
        m_GDIplusToken = 0
    End If
End Function

' // GDI+ hBitmap からファイルへ書き出し
Public Function SaveImageToFile( _
    ByVal hBmp As OLE_HANDLE, _
    ByVal sFilename As String, _
    Optional ByVal sFormat As String = "JPG", _
    Optional ByVal nQuarity As Long = 60 _
) As Boolean

    '@ sFormat : BMP, JPG, GIF, TIF, PNG
    '@ nQuality: 0-100(0:高圧縮低画質, 100:低圧縮高画質, Jpg のみ有効)

    If hBmp = 0 Then Exit Function
  
    Dim sEncoderStr As String
    Select Case UCase$(sFormat)
        Case "JPG": sEncoderStr = ENCODER_JPG
        Case "GIF": sEncoderStr = ENCODER_GIF
        Case "TIF": sEncoderStr = ENCODER_TIF
        Case "PNG": sEncoderStr = ENCODER_PNG
        Case Else: sEncoderStr = ENCODER_BMP
    End Select

    Dim uEncoderParams   As EncoderParameters
    ' Jpeg のクオリティー設定
    If UCase$(sFormat) = "JPG" Then
        nQuarity = Abs(nQuarity)
        If nQuarity > 100 Then nQuarity = 100
        uEncoderParams.count = 1
        With uEncoderParams.Parameter(0)
            .GUID = pvToCLSID(QUALITY_PARAMS)
            .TypeAPI = 4 ' Type Long
            .Value = VarPtr(nQuarity)
            .NumberOfValues = 1
        End With
    End If
  
    ' 保存処理
    Dim nStatus   As Long
    Dim pNewImage As Long
    nStatus = GdipCreateBitmapFromHBITMAP(hBmp, 0&, pNewImage)
    If nStatus = 0 Then
        If UCase$(sFormat) = "JPG" Then
            nStatus = GdipSaveImageToFile(pNewImage, _
                                          StrPtr(sFilename), _
                                          pvToCLSID(sEncoderStr), _
                                          VarPtr(uEncoderParams))
        Else
            nStatus = GdipSaveImageToFile(pNewImage, _
                                          StrPtr(sFilename), _
                                          pvToCLSID(sEncoderStr), _
                                          ByVal 0&)
        End If
        SaveImageToFile = CBool(nStatus = 0)
        Call GdipDisposeImage(pNewImage)
    End If
  
End Function

' // クリップボード hBitmap を取得する
Private Function pvGetHBitmapFromClipboard() As OLE_HANDLE
    If OpenClipboard(0&) <> 0 Then
        pvGetHBitmapFromClipboard = GetClipboardData(CF_BITMAP)
        Call CloseClipboard
    End If
End Function

' // 文字列から CLSID を取得する
Private Function pvToCLSID(ByVal S As String) As GUID
    CLSIDFromString StrPtr(S), pvToCLSID
End Function


' // サンプル: Active シート内のシェープを Jpeg で保存する
Sub Sample()
  
    Dim shp    As Shape
    Dim hBmp   As OLE_HANDLE
    Dim nCount As Long
  
    ' シート内のシェープを選択する
    nCount = 0
    For Each shp In ActiveSheet.Shapes
        ' shp.Type プロパティーの値で選択するか決める
        Select Case shp.Type
            Case msoFormControl, msoOLEControlObject
            Case Else
                shp.Select Replace:=False
                nCount = nCount + 1
        End Select
    Next
  
    If nCount > 0 Then
        ' GDI+ を初期化する
        If GDIplus_Initialize() = False Then
            MsgBox "GDI+ を初期化できません", vbCritical
            Exit Sub
        End If
        ' クリップボードにコピーする
        Selection.CopyPicture xlScreen, xlBitmap
        ' Bitmap のハンドル(メモリ上のアドレスみたいなもの)を取得
        hBmp = pvGetHBitmapFromClipboard()
        ' 保存(JPEG でクオリティー30の場合)
        If SaveImageToFile(hBmp, "C:\sample.jpg", "jpg", 30) = False Then
            MsgBox "保存に失敗", vbCritical
        Else
            MsgBox "保存に成功", vbInformation
        End If
        ' GDI+ を終了させる(必ず呼び出すこと)
        Call Gdiplus_Shutdown
    Else
        MsgBox "保存すべきものがない", vbCritical
    End If

End Sub