選択オブジェクトを画像で保存2012.11.25
Win32APIを用い、選択セル範囲やオートシェイプ等のオブジェクトを、PNGやJPG形式の画像として保存するサンプルコードとメモです。
次のサイト様を参考にさせていただきました。
出典元:VBAからGDI+を使う資料集(サイトは終了したようです)
ポイント
・クリップボードからビットマップデータを取得
・GDI+(WinAPI)
Excelマクロ管理ツール
サンプルコード
セル範囲やオートシェイプ等のオブジェクトを、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メソッド
[ 参照 ]