- ホーム
- GDI+
- CBのbitmapをリサイズして保存（Pctureオブジェクト非使用版）
クリップボードのbitmapをリサイズして保存（Pctureオブジェクトを介さない）
Pictureを介する版もどうも不安定なので、本ルーチンを用いてテンポラリファイルを用いて、
ActiveSheet.Pictures.Insert(filePath)で、貼り付けようかとも考えている。
Public Enum GDIPlusStatusConstants
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
ProfileNotFound = 21
End Enum
Public Enum InterpolationMode ' 補間方法
InterpolationModeInvalid = -1
InterpolationModeDefault = 0
InterpolationModeLowQuality = 1
InterpolationModeHighQuality = 2
InterpolationModeBilinear = 3
InterpolationModeBicubic = 4
InterpolationModeNearestNeighbor = 5
InterpolationModeHighQualityBilinear = 6
InterpolationModeHighQualityBicubic = 7
End Enum
'
''http://okwave.jp/qa/q5124395.html
'KenKenSPさん
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 PICTDESC
cbSizeofstruct As Long
picType As Long
hImage As Long
Option1 As Long
Option2 As Long
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
' // クリップボード関係
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
Private Const CF_DIB = 8
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
' // 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
'GetImageHeight
Private Declare Function GdipGetImageHeight Lib "gdiplus" _
(ByVal image As Long, Height As Long) As Long
'GetImageWidth
Private Declare Function GdipGetImageWidth Lib "gdiplus" _
(ByVal image As Long, Width As Long) As Long
'GetImageGraphicsContext
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" _
(ByVal image As Long, graphics As Long) As Long
'CreateBitmapFromGraphics
Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" _
(ByVal Width As Long, ByVal Height As Long, _
ByVal Target As Long, bitmap As Long) As Long
'SetInterpolationMode 補間モード設定
Private Declare Function GdipSetInterpolationMode Lib "gdiplus" _
(ByVal graphics As Long, _
ByVal nInterpolationMode As InterpolationMode) As Long
'DeleteGraphics
Private Declare Function GdipDeleteGraphics Lib "gdiplus" _
(ByVal graphics As Long) As Long
'DrawImageRectI
Private Declare Function GdipDrawImageRectI Lib "gdiplus" _
(ByVal graphics As Long, ByVal image As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal Width As Long, ByVal Height As Long) As Long
'CreatHBITMAPFromBitmap
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
(ByVal bitmap As Long, hbmReturn As Long, _
ByVal background As Long) As Long
Sub test()
Call cb2file_resized_withoutPicture("c:\testCB2CB.jpg", 150)
End Sub
'保存はできるのだが、クリップボードに書き戻せない
Sub cb2file_resized_withoutPicture(filePath As String, outPutHeight As Long)
Dim hBmp As OLE_HANDLE
Dim nCount As Long
Dim GdipBmpHdl As Long
Dim ret As Long
Dim lngWidth As Long, lngHeight As Long
Dim hClone As Long
Dim pGraphics As Long
Dim hBmp2 As Long
Dim InterpolationMode As InterpolationMode
Dim pDstBmp As Long
Dim aspectRatio As Double
' GDI+ を初期化する
If GDIplus_Initialize() = False Then
MsgBox "GDI+ を初期化できません", vbCritical
Exit Sub
End If
' クリップボードのBitmap のハンドルを取得
hBmp = pvGetHBitmapFromClipboard()
If hBmp = 0 Then Exit Sub
'GDI+BITMAPを作成
ret = GdipCreateBitmapFromHBITMAP(hBmp, 0&, GdipBmpHdl)
' 変換成功
' コピー先Bitmap作成
ret = GdipGetImageWidth(GdipBmpHdl, lngWidth)
ret = GdipGetImageHeight(GdipBmpHdl, lngHeight)
ret = GdipGetImageGraphicsContext(GdipBmpHdl, pGraphics)
aspectRatio = lngWidth / lngHeight
lngHeight = outPutHeight
lngWidth = CLng(lngHeight * aspectRatio)
ret = GdipCreateBitmapFromGraphics( _
lngWidth, lngHeight, pGraphics, pDstBmp)
GdipDeleteGraphics pGraphics
' コピー用Graphics作成
If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
' 補間方法の設定
InterpolationMode = InterpolationModeBicubic
ret = GdipSetInterpolationMode(pGraphics, InterpolationMode)
' イメージのコピー
ret = GdipDrawImageRectI(pGraphics, GdipBmpHdl, 0, 0, lngWidth, lngHeight)
'bitmapオブジェクトのハンドルを取得
ret = GdipCreateHBITMAPFromBitmap(pDstBmp, hBmp2, 0&)
GdipDeleteGraphics pGraphics
End If
'保存る
Call SaveImageToFile(hBmp2, filePath, "JPG", 85)
'クリップボードに書き戻す
If OpenClipboard(0&) <> 0 Then
EmptyClipboard
SetClipboardData CF_BITMAP, hBmp2
CloseClipboard
End If
' GDI+BITMAPを廃棄
GdipDisposeImage GdipBmpHdl
terminate:
' 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
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
Else
pvGetHBitmapFromClipboard = 0
End If
End Function
' // 文字列から CLSID を取得する
Private Function pvToCLSID(ByVal S As String) As GUID
CLSIDFromString StrPtr(S), pvToCLSID
End Function