Memorandum

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

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
    #If VBA7 Then
        GdiplusVersion As Long
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    #Else
        GdiplusVersion As Long
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    #End If
End Type

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

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

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, lngHeight 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(ENCODER_JPG) .TypeAPI = 4 .NumberOfValues = 1 .Value = VarPtr(nQuarity) End With End If If UCase$(sFormat) = "JPG" Then Call GdipSaveImageToFile(objBmp, StrPtr(sFilename), _ pvToCLSID(strEncoder), 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メソッド

[ 参照 ]

ページトップへ戻る
Copyright(C) 2009- 坂江 保 All Rights Reserved.