トップ > 備忘録 > 選択オブジェクトを画像で保存

選択オブジェクトを画像で保存2012.11.25   [更新日]2024.12.22

Win32APIを用い、選択セル範囲やオートシェイプ等のオブジェクトを、PNGやJPG形式の画像として保存するサンプルコードです。


ポイント

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


【お薦め】マクロ・プロシージャを管理する無料のツール!
 Excelマクロ管理ツール

サンプルコード

セル範囲やオートシェイプ等のオブジェクトを、PNGやJPG形式の画像として保存するサンプルコード。

' ***(宣言セクションに記述)***  Excel2010以降対応
'-------------------------------------
' 定数
'-------------------------------------
' GDI+トークンのポインタ
Private pr_GDIplusToken      As LongPtr

'-------------------------------------
' 構造体
'-------------------------------------
'《GdiplusStartupInput 構造体》
' https://learn.microsoft.com/ja-jp/windows/win32/api/gdiplusinit/ns-gdiplusinit-gdiplusstartupinput
Private Type GdiplusStartupInput
    GdiplusVersion           As Long      ' GDI+ のバージョンを指定  1 にする必要あり
    DebugEventCallback       As LongPtr   ' コールバック関数のポインタ  既定 0
    SuppressBackgroundThread As Long      ' GDI+ バックグラウンド スレッドを抑制するかどうかの指定
    SuppressExternalCodecs   As Long      ' GDI+ で外部イメージ コーデックを抑制するかどうかの指定
End Type

'《Guid 構造体》
' https://learn.microsoft.com/ja-jp/dotnet/api/system.guid?view=net-8.0
' GUID:データを一意に識別するために用いられる識別子
Private Type GUID
    Data1                    As Long
    Data2                    As Integer
    Data3                    As Integer
    Data4(0 To 7)            As Byte
End Type

'-------------------------------------
' Win32API
'-------------------------------------
'*** クリップボード関連 ***
'《クリップボードを開く》
' クリップボードを開き 他のアプリケーションがクリップボードの内容を変更できないようにする
' https://learn.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-openclipboard
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
                                        ByVal hwnd As LongPtr) As Long
                                        
'《指定した形式でクリップボードからデータを取得》
' クリップボード開かれている必要あり
' https://learn.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-getclipboarddata
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
                                        ByVal uFormat As LongPtr) As Long
                     
'《クリップボードを閉じる》
' https://learn.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-closeclipboard
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long

'*** GDI+関連 ***
'《Windows GDI+ を初期化》
' GDI+ の使用が完了したら GdiplusShutdown を呼び出す
' https://learn.microsoft.com/ja-jp/windows/win32/api/gdiplusinit/nf-gdiplusinit-gdiplusstartup
Private Declare PtrSafe Function GdiplusStartup Lib "Gdiplus.dll" ( _
                                        ByRef token As LongPtr, _
                                        ByRef inputBuf As GdiplusStartupInput, _
                               Optional ByVal outputBuf As LongPtr = 0) As Long

'《Windows GDI+ で使用されるリソースをクリーンアップ》
' GdiplusStartup とペアで使用する
' https://learn.microsoft.com/ja-jp/windows/win32/api/gdiplusinit/nf-gdiplusinit-gdiplusshutdown
Private Declare PtrSafe Sub GdiplusShutdown Lib "Gdiplus.dll" ( _
                                        ByVal token As LongPtr)

'《ビットマップオブジェクトの作成》
' GDIビットマップへのハンドルとGDIパレットへのハンドルに基づいて作成
' https://learn.microsoft.com/ja-jp/windows/win32/gdiplus/-gdiplus-bitmap-flat
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "Gdiplus.dll" ( _
                                        ByVal hbm As LongPtr, _
                                        ByVal hpal As LongPtr, _
                                        ByRef bitmap As LongPtr) As Long
                                        
'《Image オブジェクトで使用されるリソースを解放》
' https://learn.microsoft.com/ja-jp/windows/win32/gdiplus/-gdiplus-image-flat
Private Declare PtrSafe Function GdipDisposeImage Lib "Gdiplus.dll" ( _
                                        ByVal image As LongPtr) As Long

'《イメージの幅をピクセル単位で取得》
' https://learn.microsoft.com/ja-jp/windows/win32/gdiplus/-gdiplus-image-flat
Private Declare PtrSafe Function GdipGetImageWidth Lib "GDIPlus" ( _
                                        ByVal image As LongPtr, _
                                        ByRef Width As LongPtr) As Long
                                        
'《イメージの高さをピクセル単位で取得》
' https://learn.microsoft.com/ja-jp/windows/win32/gdiplus/-gdiplus-image-flat
Private Declare PtrSafe Function GdipGetImageHeight Lib "Gdiplus.dll" ( _
                                        ByVal image As LongPtr, _
                                        ByRef Height As LongPtr) As Long
                                                                                
'《イメージをファイルに保存》
' https://learn.microsoft.com/ja-jp/windows/win32/gdiplus/-gdiplus-image-flat
Private Declare PtrSafe Function GdipSaveImageToFile Lib "Gdiplus.dll" ( _
                                        ByVal image As LongPtr, _
                                        ByVal filename As LongPtr, _
                                        ByRef clsidEncoder As GUID, _
                                        ByRef encoderParams As Any) As Long
' *** ここまで ***

Sub 選択オブジェクトを画像で保存() '--------------------------------------- ' ファイル名生成 '--------------------------------------- Dim strFileName As String strFileName = Format$(Now(), "yyyymmdd_hhnnss") '--------------------------------------- ' ダイアログボックス表示 '--------------------------------------- Dim varFileName As Variant '《名前をつけて保存ダイアログボックス》 varFileName = Application.GetSaveAsFilename(strFileName, _ "PNG,*.png,JPG,*.jpg,GIF,*.gif,BMP,*.bmp,TIFF,*.tif") '[キャンセル]ボタンをクリックした場合は抜ける If VarType(varFileName) = vbBoolean Then Exit Sub '--------------------------------------- ' ファイルの存在確認 '--------------------------------------- If Dir(varFileName, vbNormal) <> "" Then ' ファイルが存在する場合は上書き確認 If MsgBox("上書きしますか?", vbQuestion + vbYesNo, "確認") = vbNo Then Exit Sub End If '--------------------------------------- ' クリップボードへコピー '--------------------------------------- ' 選択オブジェクトをクリップボードへピクチャ (画像) としてコピー Application.Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap '--------------------------------------- ' イメージ出力 '--------------------------------------- Dim lngReturnValue As Long '《クリップボードのイメージを出力》 lngReturnValue = exportImageFromClipboard(varFileName) If Err.Number <> 0 Then GoTo LBL_ERROR Dim strMessage As String If lngReturnValue = 0 Then strMessage = "画像を出力しました" & vbLf & varFileName Else strMessage = "画像の出力に失敗しました" End If MsgBox strMessage, vbInformation Exit Sub LBL_ERROR: MsgBox "エラー番号:" & Err.Number & vbLf & _ "エラー内容:" & Err.Description, vbExclamation + vbOKOnly, _ "エラー" End Sub
'----------------------------------------------------------------- ' クリップボードのイメージを出力 '----------------------------------------------------------------- '[引数] ' FilePath:ファイルフルパス(ファイルの保存名) '[戻り値] ' 成功:0 ' 失敗:0以外 '[作成日]2012.11.25 [更新日]2024.12.22 ' https://excel.syogyoumujou.com/memorandum/without_picture.html '----------------------------------------------------------------- Function exportImageFromClipboard(ByVal FilePath As String) As Long On Error Resume Next '--------------------------------------- ' クリップボードのBitmap取得 '--------------------------------------- Dim hdlBitmap As OLE_HANDLE hdlBitmap = uGetHBitmapFromClipboard() If hdlBitmap = 0 Then MsgBox "クリップボードのBitmapを取得できません", vbCritical exportImageFromClipboard = 1 Exit Function End If '--------------------------------------- ' GDI+ 関連処理 '--------------------------------------- '《GDI+初期化》 If Not initializeGDIplus() Then MsgBox "GDI+ を初期化できません", vbCritical exportImageFromClipboard = 2 GoTo LBL_FINALLY End If Dim lngReturnValue As Long Dim objGdipBmp As LongPtr '《ビットマップオブジェクトの作成》 ' ・ 引数1:GDI ビットマップへのハンドル ' ・ 引数2:GDI パレットへのハンドル ' ・ 引数3:作成されるビットマップオブジェクトへのポインタ ' 戻り値 :成功:0 失敗:0以外 lngReturnValue = GdipCreateBitmapFromHBITMAP(hdlBitmap, 0&, objGdipBmp) If lngReturnValue <> 0 Then GoTo LBL_TERMINATE Dim lngWidth As LongPtr '《イメージの幅をピクセル単位で取得》 ' ・ 引数1:対象のイメージ ' ・ 引数2:イメージの幅を受け取る変数 Call GdipGetImageWidth(objGdipBmp, lngWidth) Dim lngHeight As LongPtr '《イメージの幅をピクセル単位で取得》 ' ・ 引数1:対象のイメージ ' ・ 引数2:イメージの高さを受け取る変数 Call GdipGetImageHeight(objGdipBmp, lngHeight) ' イメージが想定より大きい場合は終了する If Not (lngWidth <= 3200 And lngHeight <= 3200) Then MsgBox "イメージが大きすぎます" & vbLf & _ "対応ピクセル範囲:3200×3200", vbExclamation exportImageFromClipboard = 3 GoSub LBL_TERMINATE End If '--------------------------------------- ' イメージ出力 '--------------------------------------- Dim lngStatus As Long '《GDP+ イメージをファイルに保存》 ' ・ 引数1:対象ビットマップオブジェクトへのポインタ ' ・ 引数2:ファイルパス lngStatus = saveImageToFile(objGdipBmp, FilePath) ' 出力に失敗 If lngStatus <> 0 Then exportImageFromClipboard = -1 LBL_TERMINATE: '《Imageオブジェクトで使用されるリソースを解放》 Call GdipDisposeImage(objGdipBmp) LBL_FINALLY: '《GDI+ シャットダウン》 Call shutdownGdiplus End Function
'----------------------------------------------------------------- ' クリップボードのBitmap取得 '----------------------------------------------------------------- '[引数] ' なし '[戻り値] ' 成功:クリップボードのビットマップのハンドル ' 失敗:0 '[作成日]2012.11.25 [更新日]2024.12.21 ' https://excel.syogyoumujou.com/memorandum/without_picture.html '----------------------------------------------------------------- Private Function uGetHBitmapFromClipboard() As OLE_HANDLE '《標準クリップボード形式》 ' https://learn.microsoft.com/ja-jp/windows/win32/dataxchg/standard-clipboard-formats Const CF_BITMAP As Long = 2 ' ビットマップへのハンドル Dim lngReturnValue As Long '《クリップボードを開く》 ' ・ 引数1:開いているクリップボードに関連付けるウィンドウのハンドル ' 0 の場合は現在のタスクに関連付けられる ' 戻り値 :成功:0 以外 失敗:0 lngReturnValue = OpenClipboard(0&) If lngReturnValue <> 0 Then '《指定した形式でクリップボードからデータを取得》 ' ・ 引数1:クリップボード形式 ' 戻り値 :成功:指定した形式のクリップボード オブジェクトのハンドル ' 失敗:0 uGetHBitmapFromClipboard = GetClipboardData(CF_BITMAP) Else uGetHBitmapFromClipboard = 0 End If '《クリップボードを閉じる》 Call CloseClipboard End Function
'----------------------------------------------------------------- ' GDI+初期化 '----------------------------------------------------------------- '[引数] ' なし '[戻り値] ' 成功:True ' 失敗:False '[作成日]2012.11.25 [更新日]2024.12.21 ' https://excel.syogyoumujou.com/memorandum/without_picture.html '----------------------------------------------------------------- Private Function initializeGDIplus() As Boolean '---------------------------------------- ' GDI+ をシャットダウン '---------------------------------------- Call shutdownGdiplus '---------------------------------------- ' GDI+ を初期化 '---------------------------------------- ' パラメーター設定 Dim uGdiStartupInput As GdiplusStartupInput With uGdiStartupInput .GdiplusVersion = 1 .DebugEventCallback = 0 .SuppressBackgroundThread = 0 .SuppressExternalCodecs = 0 End With Dim lngStatus As Long '《Windows GDI+ を初期化》 ' ・ 引数1:トークンのポインタ (GDP+ シャットダウンではこのトークンを渡す) ' ・ 引数2:GdiplusStartupInput 構造体へのポインタ ' ・ 引数3:GdiplusStartupOutput 構造体へのポインタ ' 入力パラメーターの SuppressBackgroundThread が False(0) の場合は 0 ' 戻り値 :成功:0 失敗:0以外(Status列挙体の要素) ' ※ Status列挙体 ' https://learn.microsoft.com/ja-jp/windows/win32/api/gdiplustypes/ne-gdiplustypes-status lngStatus = GdiplusStartup(pr_GDIplusToken, uGdiStartupInput, 0&) '---------------------------------------- ' 戻り値設定 '---------------------------------------- initializeGDIplus = CBool(lngStatus = 0) End Function
'----------------------------------------------------------------- ' GDI+ シャットダウン '----------------------------------------------------------------- '[引数] ' なし '[作成日]2012.11.25 [更新日]2024.12.21 ' https://excel.syogyoumujou.com/memorandum/without_picture.html '----------------------------------------------------------------- Private Sub shutdownGdiplus() ' トークンが 0 以外の場合は GDI+ をシャットダウン If pr_GDIplusToken <> 0 Then '《Windows GDI+ で使用されるリソースをクリーンアップ》 Call GdiplusShutdown(pr_GDIplusToken) pr_GDIplusToken = 0 End If End Sub
'----------------------------------------------------------------- ' GDP+ イメージをファイルに保存 '----------------------------------------------------------------- '[引数] ' objGdipBmp:対象ビットマップオブジェクトへのポインタ ' FilePath :ファイルフルパス(ファイルの保存名) '[戻り値] ' GdipSaveImageToFileのステータス 成功:0 失敗:0以外 '[作成日]2012.11.25 [更新日]2024.12.22 ' https://excel.syogyoumujou.com/memorandum/without_picture.html '----------------------------------------------------------------- Private Function saveImageToFile(ByVal objGdipBmp As LongPtr, _ ByVal FilePath As String) As Long '--------------------------------------- ' 拡張子取得 '--------------------------------------- Dim strExtention As String strExtention = CreateObject("Scripting.FileSystemObject").GetExtensionName(FilePath) '--------------------------------------- ' CLSID 設定 '--------------------------------------- '[参考]CLSID形式の各フォーマットエンコーダー ' bmp:{557CF400-1A04-11D3-9A73-0000F81EF32E} ' jpg:{557CF401-1A04-11D3-9A73-0000F81EF32E} ' gif:{557CF402-1A04-11D3-9A73-0000F81EF32E} ' tif:{557CF405-1A04-11D3-9A73-0000F81EF32E} ' png:{557CF406-1A04-11D3-9A73-0000F81EF32E} Dim lngFormat As Long Select Case UCase$(strExtention) Case "BMP": lngFormat = &H557CF400 Case "JPG": lngFormat = &H557CF401 Case "GIF": lngFormat = &H557CF402 Case "TIF": lngFormat = &H557CF405 Case "PNG": lngFormat = &H557CF406 Case Else: lngFormat = &H557CF400 End Select Dim uCLSID As GUID With uCLSID .Data1 = lngFormat .Data2 = &H1A04 .Data3 = &H11D3 .Data4(0) = &H9A .Data4(1) = &H73 .Data4(2) = &H0 .Data4(3) = &H0 .Data4(4) = &HF8 .Data4(5) = &H1E .Data4(6) = &HF3 .Data4(7) = &H2E End With '--------------------------------------- ' 画像を出力 '--------------------------------------- '《イメージをファイルに保存》 ' ・ 引数1:対象のイメージ ' ・ 引数2:ファイル名 ※ファイルパスへのポインタ ' ・ 引数3:GUID構造体形式の CLSID エンコーダー ' ・ 引数4:エンコーダーパラメーター ' 戻り値 :ステータス ' 成功 :0 ' エラー:0以外 saveImageToFile = GdipSaveImageToFile(objGdipBmp, StrPtr(FilePath), uCLSID, ByVal 0&) End Function

VBAコードをカラーで印刷・Web掲載するためのツールはこちら


サンプルコードを利用した画像の連続出力

サンプルコード内の関数を利用すると「セル範囲をPNG形式の画像として連続で出力する」といったことができる。
次のコードは、サンプルコードの exportImageFromClipboard 関数を呼び出し、セル範囲をPNG形式の画像として連続出力するマクロの例である。

'-----------------------------------------------------------------
' exportImageFromClipboard 関数の使用例
'-----------------------------------------------------------------
' exportImageFromClipboard 関数は
' クリップボードのBitmapを任意のフォーマットで出力する
'
'[作成日]2024.12.21
' https://excel.syogyoumujou.com/memorandum/without_picture.html
'-----------------------------------------------------------------
Sub exportImageFromClipboardの使用例()
    ' ファイルのフォーマット
    Const strFormat As String = "png"

    ' デスクトップのパスを取得
    Dim strDesktopPath As String
    strDesktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    strDesktopPath = strDesktopPath & Application.PathSeparator

    ' デスクトップにシートの選択範囲の画像10枚をPNG形式で出力する
    Dim i As Long
    For i = 1 To 10
        ' アクティブシートのセルを選択する(起点のセルから10×10)
        ActiveSheet.Cells((i - 1) * 10 + 1, "A").Resize(10, 10).Select
        
        ' 選択オブジェクトをクリップボードへピクチャ (画像) としてコピー
        Application.Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    
        '《クリップボードのイメージを出力》
        Call exportImageFromClipboard(strDesktopPath & i & "." & strFormat)
        
        ' 1 秒待機
        Application.Wait Now() + TimeValue("00:00:01")
    Next

    MsgBox "処理終了"
End Sub

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