選択オブジェクトを画像で保存

選択オブジェクトを画像で保存

 Win32APIを用い、選択セル範囲やオートシェイプ等のオブジェクトを、PNGやJPG形式の画像として保存するサンプルコードとメモです。
 次のサイト様を参考にさせていただきました。
 出典元:VBAからGDI+を使う資料集  

ポイント

 ・クリップボードからビットマップデータを取得
 ・GDI+(WinAPI)


サンプルコード

セル範囲やオートシェイプ等のオブジェクトを、PNGやJPG形式の画像として保存するサンプルコード。
※64bit版のExcelに対応
※下記のコードをVBEに貼り付ると、一部赤く表示される場合があるが、エラーではない。
※次のコードを利用したソフト:「選択セル範囲を画像で保存」アドイン

'///宣言セクションに記述///
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 Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

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

#If VBA7 And Win64 Then
    'クリップボード関係
    Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
            ByVal hWnd As Long) As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
            ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
    'GDI+関係
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus.dll" ( _
            ByRef token As Long, _
            ByRef inputBuf As GdiplusStartupInput, _
            ByVal outputBuf As Long) As Long
    Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus.dll" ( _
            ByVal token As Long)
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" ( _
            ByVal hbm As Long, _
            ByVal hpal As Long, _
            bitmap As Long) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus.dll" ( _
            ByVal image As Long) As Long
    Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus.dll" ( _
            ByVal image As Long, _
            ByVal filename As LongPtr, _
            ByRef clsidEncoder As GUID, _
            ByVal encoderParams As Any) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" ( _
            ByVal lpszCLSID As LongPtr, _
            ByRef pCLSID As GUID) As Long
    Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus.dll" ( _
            ByVal image As Long, _
            Height As Long) As Long
    Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus.dll" ( _
            ByVal image As Long, _
            Width As Long) As Long
    Private Type EncoderParameter
        GUID As GUID
        NumberOfValues As Long
        TypeAPI As Long
        Value As LongPtr
    End Type
    Private Type EncoderParameters
        Count As Long
        Parameter(0 To 15) As EncoderParameter
    End Type
#Else
    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 GdiplusStartup Lib "gdiplus.dll" ( _
            ByRef token As Long, _
            ByRef inputBuf As GdiplusStartupInput, _
            ByVal outputBuf As Long) As Long
    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, _
            bitmap As Long) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus.dll" ( _
            ByVal image As Long) As Long
    Private Declare Function GdipSaveImageToFile Lib "gdiplus.dll" ( _
            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 Declare Function GdipGetImageHeight Lib "gdiplus.dll" ( _
            ByVal image As Long, _
            Height As Long) As Long
    Private Declare Function GdipGetImageWidth Lib "gdiplus.dll" ( _
            ByVal image As Long, _
            Width As Long) As Long
    Private Type EncoderParameter
        GUID As GUID
        NumberOfValues As Long
        TypeAPI As Long
        Value As Long
    End Type
    Private Type EncoderParameters
        Count As Long
        Parameter(0 To 15) As EncoderParameter
    End Type
#End If

Public m_GDIplusToken
Private Const CF_BITMAP As Long = 2 'クリップボードのデータタイプ
'///ここまで///
'-------------------------------------------------------------------------------------------------------

Sub Sample_WithoutPicture()
    Dim strExt As String
    Dim strSep As String
    Dim strSelFilePath As String
    Dim varOption As Variant
    strSelFilePath = STI_Select_Path()
    If Len(strSelFilePath) = 0 Then Exit Sub
    If InStrRev(strSelFilePath, ".", , vbBinaryCompare) = 0 Then Exit Sub
    strExt = LCase$(Mid$(strSelFilePath, InStrRev(strSelFilePath, ".", , vbBinaryCompare) + 1))
    On Error Resume Next
        Application.Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        If Err.Number <> 0 Then
            MsgBox Err.Description, vbExclamation + vbOKOnly
            Err.Clear
            Exit Sub
        End If
    On Error GoTo 0
    Call Selection_WithoutPicture(strSelFilePath, strExt, 85)
End Sub
'-------------------------------------------------------------------------------------------------------

Private Function STI_Select_Path() As String '保存場所とファイル名の指定
    Const strFilter As String = "PNG,*.png,JPG,*.jpg,GIF,*.gif,BMP,*.bmp,TIFF,*.tif"
    Dim lngLD As Long
    Dim strIFN As String
    Dim strFilePath As String
    With Excel.Application
        strIFN = Date_Time_FN() '日時からファイル名を作成
        strFilePath = .GetSaveAsFilename(InitialFileName:=strIFN, FileFilter:=strFilter)
        If UCase$(strFilePath) = "FALSE" Then Exit Function
        If Dir(strFilePath) <> "" Then
            If MsgBox("上書きしますか?", vbQuestion + vbYesNo, "確認") = vbNo Then
                Exit Function
            End If
        End If
        STI_Select_Path = strFilePath
    End With
End Function
'-------------------------------------------------------------------------------------------------------

Private Function Date_Time_FN() As String '日時からファイル名を作成
    Dim datTime As Date
    Dim datToday As Date
    Dim strFileName(0 To 8) As String
    datToday = Date: datTime = Time
    strFileName(0) = Mid$(CStr(Year(datToday)), 3)
    strFileName(1) = "_"
    strFileName(2) = Format$(datToday, "mm")
    strFileName(3) = Format$(datToday, "dd")
    strFileName(4) = "_"
    strFileName(5) = Format$(datTime, "hh")
    strFileName(6) = Format$(datTime, "nn")
    strFileName(7) = "_"
    strFileName(8) = Format$(datTime, "ss")
    Date_Time_FN = Join$(strFileName, vbNullString)
End Function
'-------------------------------------------------------------------------------------------------------

Private Sub Selection_WithoutPicture(ByVal filePath As String, _
                                    ByVal strExt As String, ByVal lngQ As Long)
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim strReceive As String
    Dim objGdipBmp
    Dim hBmp As OLE_HANDLE
    If GDIplus_Initialize() = False Then 'GDI+初期化
        MsgBox "GDI+ を初期化できません", vbCritical: Exit Sub
    End If
    hBmp = pvGetHBitmapFromClipboard() 'クリップボードのBitmap ハンドル取得
    If hBmp = 0 Then GoSub FINGDIP
    'BitmapハンドルからBitmapオブジェクト(イメージ)を作成。objGdipBmpは作成されたイメージ
    If GdipCreateBitmapFromHBITMAP(hBmp, 0&, objGdipBmp) = 0 Then
        Call GdipGetImageWidth(objGdipBmp, lngWidth) '幅取得
        Call GdipGetImageHeight(objGdipBmp, lngHeight) '高さ取得
        If Not (lngWidth <= 3200 And lngHeight <= 3200) Then
            MsgBox "イメージが大きすぎます", vbExclamation + vbOKOnly
            GoSub TERMINATE
        End If
        Call SaveImageToFile(objGdipBmp, filePath, strExt, lngQ) '保存
    End If
TERMINATE: 'イメージの廃棄
    Call GdipDisposeImage(objGdipBmp)
FINGDIP: 'GDI+終了
    Call Gdiplus_Shutdown
End Sub
'-------------------------------------------------------------------------------------------------------

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

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

'GDI+からファイルへ書き出し
Private Sub SaveImageToFile(ByVal objBmp, ByVal sFilename As String, _
                                ByVal sFormat As String, ByVal nQuarity As Long)
    Dim strEncoder As String
    Dim uEncoderParams As EncoderParameters
    Select Case UCase$(sFormat)
        Case "JPG": strEncoder = ENCODER_JPG
        Case "GIF": strEncoder = ENCODER_GIF
        Case "TIF": strEncoder = ENCODER_TIF
        Case "PNG": strEncoder = ENCODER_PNG
        Case Else: strEncoder = ENCODER_BMP
    End Select
    If UCase$(sFormat) = "JPG" Then 'JPEGのクオリティー設定
        nQuarity = Abs(nQuarity)
        If nQuarity = 0 Or 100 < nQuarity Then nQuarity = 100
        uEncoderParams.Count = 1
        With uEncoderParams.Parameter(0)
            .GUID = pvToCLSID(QUALITY_PARAMS)
            .TypeAPI = 4
            .NumberOfValues = 1
            .Value = VarPtr(nQuarity)
        End With
    End If
    If UCase$(sFormat) = "JPG" Then
        Call GdipSaveImageToFile(objBmp, StrPtr(sFilename), _
                pvToCLSID(strEncoder), VarPtr(uEncoderParams))
    Else
        Call GdipSaveImageToFile(objBmp, StrPtr(sFilename), _
                pvToCLSID(strEncoder), ByVal 0&)
    End If
End Sub
'-------------------------------------------------------------------------------------------------------

 'クリップボードのBitmap取得
Private Function pvGetHBitmapFromClipboard() As OLE_HANDLE
    If OpenClipboard(0&) <> 0 Then
        pvGetHBitmapFromClipboard = GetClipboardData(CF_BITMAP)
    Else
        pvGetHBitmapFromClipboard = 0
    End If
    Call CloseClipboard
End Function
'-------------------------------------------------------------------------------------------------------

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

メモ

 サンプルコードでは、選択しているオブジェクトをクリップボードにコピーし、そのビットマップデータを取得し画像に保存している。

◆クリップボードからビットマップデータを取得

 WinAPIを用いてクリップボードからビットマップデータを取得している。以下はサンプルコードで用いたクリップボード関連のWinAPI

 ・OpenClipboard関数:クリップボードを開く
 ・GetClipboardData関数:クリップボードのデータを取得
 ・CloseClipboard関数:クリップボードを閉じる

◆GDI+での画像処理

 GDI+とは、Windowsでグラフィックス処理を行うGDI(Graphics Device Interface:グラフィクス・デバイス・インタフェイス)を拡張したもの。以下はサンプルコードで用いたGDI+関連のAPI

 ・GdiplusStartup関数:GDI+を初期化
 ・GdiplusShutdown関数:GDI+を終了
 ・GdipCreateBitmapFromHBITMAP関数:Bitmapハンドルから、Bitmap(イメージ)を作成
 ・GdipDisposeImage関数:イメージオブジェクトを破棄
 ・GdipSaveImageToFile関数:イメージを画像として保存
 ・GdipGetImageHeight関数:イメージの高さを取得
 ・GdipGetImageWidth関数:イメージの幅を取得

◆その他WinAPI

 ・CLSIDFromString関数:CLSID の文字列形式に変換

◆VBA関連

 ・ファイル名の自動作成
 [ 参照 ]

 ・GetSaveAsFilenameメソッド
 [ 参照 ]

Excel Tips for Teachers

Copyright (C) 2009- 坂江 保 All Rights Reserved.