- ホーム
- GDI+
- 画像にshapeを合成して保存１
WS上の画像の上にshapeを書き加えて、画像ファイルとして保存（その１）
okwaveで、ワークシート上に貼り付けた画像の上にshapeを書き加えて、画像ファイルとして保存したいというお題が出され、
PrtScして、グラフィックソフトで保存するという至極真っ当なsolutionで閉じられてしまいましたが、
VBAでやる方法はないかと模索してみました。
その１．Bitmap形式でCopyPicureして、Bitmap系の形式で保存する方法
結果的には、PrtSc相当だと思いますが。
'http://okwave.jp/qa/q5124395.html
'KenKenSPさんの投稿をアレンジ
' // クリップボード関係
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 Const CF_BITMAP As Long = 2
' // GDI+関係
Private Declare Function GdiplusStartup Lib "gdiplus" ( _
ByRef token As Long, _
ByRef inputBuf As GdiplusStartupInput, _
ByVal outputBuf As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" ( _
ByVal token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" ( _
ByVal hbm As Long, _
ByVal hpal As Long, _
ByRef bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
ByVal image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
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 Type GdiplusStartupInput
GdiplusVersion As Long ' UINT32 GdiplusVersion
DebugEventCallback As Long ' DebugEventProc DebugEventCallback
SuppressBackgroundThread As Long ' BOOL SuppressBackgroundThread
SuppressExternalCodecs As Long ' BOOL SuppressExternalCodecs
End Type
Private Type GUID
Data1 As Long ' unsigned long Data1
Data2 As Integer ' unsigned short Data2
Data3 As Integer ' unsigned short Data3
Data4(7) As Byte ' unsigned char Data4[8]
End Type
Private Type EncoderParameter
GUID As GUID ' GUID Encoder Guid
NumberOfValues As Long ' ULONG NumberOfValues
TypeAPI As Long ' ULONG Type
Value As Long ' VOID* Value
End Type
Private Type EncoderParameters
count As Long ' UINT Count
Parameter(15) As EncoderParameter ' EncoderParameter Parameter[l]
End Type
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 m_GDIplusToken As Long
' //選択範囲のビットマップ画像、オートシェープ・テキストボックス等を
' //JPEG画像として保存
' //ワークシート上の画像サイズに応じて画質は変化する（エクセルがリサイズして表示している
' //状態を反映させるらしい。一種のPrtScr?
Sub Sample()
Dim shp As Shape
Dim hBmp As OLE_HANDLE
' GDI+ を初期化する
If GDIplus_Initialize() = False Then
MsgBox "GDI+ を初期化できません", vbCritical
Exit Sub
End If
' クリップボードにコピーする
' 2007では下記のxlBitmapのオプションが機能しないで、xlPicture(EMF)になるという記事あり
Call Selection.CopyPicture(xlScreen, xlBitmap)
' Call Selection.CopyPicture(xlPrinter, xlBitmap) '画質が上がるかと思ったがエラーになる
' Bitmap のハンドル(メモリ上のアドレスみたいなもの)を取得
hBmp = pvGetHBitmapFromClipboard()
' 保存(JPEG でクオリティー30の場合）
If SaveImageToFile(hBmp, "C:\sample.jpg", "jpg", 90) = False Then
MsgBox "保存に失敗", vbCritical
Else
MsgBox "保存に成功", vbInformation
End If
' GDI+ を終了させる（必ず呼び出すこと）
Call Gdiplus_Shutdown
End Sub
' // GDI+ 初期化
Private Function GDIplus_Initialize() As Boolean
Dim uGdiStartupInput As GdiplusStartupInput
Dim nStatus As Long
If m_GDIplusToken Then Call Gdiplus_Shutdown
With uGdiStartupInput
.GdiplusVersion = 1
.DebugEventCallback = 0
.SuppressBackgroundThread = 0
.SuppressExternalCodecs = 0
End With
nStatus = GdiplusStartup(m_GDIplusToken, uGdiStartupInput, 0&)
GDIplus_Initialize = CBool(nStatus = 0)
End Function
' // GDI+ 終了
Private Function Gdiplus_Shutdown() As Long
If m_GDIplusToken Then
Call GdiplusShutdown(m_GDIplusToken)
m_GDIplusToken = 0
End If
End Function
' // GDI+ hBitmap からファイルへ書き出し
Public Function SaveImageToFile( _
ByVal hBmp As OLE_HANDLE, _
ByVal sFilename As String, _
Optional ByVal sFormat As String = "JPG", _
Optional ByVal nQuarity As Long = 60 _
) As Boolean
Dim sEncoderStr As String
Dim uEncoderParams As EncoderParameters
'@ sFormat : BMP, JPG, GIF, TIF, PNG
'@ nQuality: 0-100(0:高圧縮低画質, 100:低圧縮高画質, Jpg のみ有効)
If hBmp = 0 Then Exit Function
Select Case UCase$(sFormat)
Case "JPG": sEncoderStr = ENCODER_JPG
Case "GIF": sEncoderStr = ENCODER_GIF
Case "TIF": sEncoderStr = ENCODER_TIF
Case "PNG": sEncoderStr = ENCODER_PNG
Case Else: sEncoderStr = ENCODER_BMP
End Select
' Jpeg のクオリティー設定
If UCase$(sFormat) = "JPG" Then
nQuarity = Abs(nQuarity)
If nQuarity > 100 Then nQuarity = 100
uEncoderParams.count = 1
With uEncoderParams.Parameter(0)
.GUID = pvToCLSID(QUALITY_PARAMS)
.TypeAPI = 4 ' Type Long
.Value = VarPtr(nQuarity)
.NumberOfValues = 1
End With
End If
' 保存処理
Dim nStatus As Long
Dim pNewImage As Long
nStatus = GdipCreateBitmapFromHBITMAP(hBmp, 0&, pNewImage)
If nStatus = 0 Then
If UCase$(sFormat) = "JPG" Then
nStatus = GdipSaveImageToFile(pNewImage, _
StrPtr(sFilename), _
pvToCLSID(sEncoderStr), _
VarPtr(uEncoderParams))
Else
nStatus = GdipSaveImageToFile(pNewImage, _
StrPtr(sFilename), _
pvToCLSID(sEncoderStr), _
ByVal 0&)
End If
SaveImageToFile = CBool(nStatus = 0)
Call GdipDisposeImage(pNewImage)
End If
End Function
' // クリップボード hBitmap を取得する
Private Function pvGetHBitmapFromClipboard() As OLE_HANDLE
If OpenClipboard(0&) <> 0 Then
pvGetHBitmapFromClipboard = GetClipboardData(CF_BITMAP)
Call CloseClipboard
End If
End Function
' // 文字列から CLSID を取得する
Private Function pvToCLSID(ByVal S As String) As GUID
CLSIDFromString StrPtr(S), pvToCLSID
End Function