選択オブジェクトを画像で保存2012.11.25 ［更新日］2024.12.22
Win32APIを用い、選択セル範囲やオートシェイプ等のオブジェクトを、PNGやJPG形式の画像として保存するサンプルコードです。
ポイント
・クリップボードからビットマップデータを取得
・GDI+(WinAPI)
【お薦め】マクロ・プロシージャを管理する無料のツール！
Excelマクロ管理ツール
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
