- ホーム
- GDI+
- CBのbitmapをリサイズしてCBに書き戻す（その２）
クリップボードのbitmapをリサイズしてクリップボードに書き戻す
どうも不安定なので、再度Pictureを生成してからClipboardに貼り付ける方法に変更しました。
冗長だとは思いますが。
Public Enum InterpolationMode ' 補間方法
InterpolationModeInvalid = -1
InterpolationModeDefault = 0
InterpolationModeLowQuality = 1
InterpolationModeHighQuality = 2
InterpolationModeBilinear = 3
InterpolationModeBicubic = 4
InterpolationModeNearestNeighbor = 5
InterpolationModeHighQualityBilinear = 6
InterpolationModeHighQualityBicubic = 7
End Enum
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
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
Guid As Guid
NumberOfValues As Long
Type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type
Private Type PICTDESC
cbSizeofstruct As Long
picType As Long
hImage As Long
Option1 As Long
Option2 As Long
End Type
Const PICTYPE_BITMAP = 1
' // Declareations --------------------------------------------------
'Clipboard
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Long) 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 Declare Function CopyImage Lib "user32.dll" _
(ByVal hImage As Long, ByVal uType As Long, ByVal cxDesired As Long, _
ByVal cyDesired As Long, ByVal fuFlags As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP As Long = 2
Private Const CF_PALETTE As Long = 9
'GDI+
'CreateBitmapFromHBITMAP
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" _
(ByVal hbm As Long, ByVal hpal As Long, ByRef bitmap As Long) As GDIPlusStatusConstants
'CreateBitmapFromGraphics
Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" _
(ByVal Width As Long, ByVal Height As Long, _
ByVal Target As Long, bitmap As Long) As Long
'CreatHBITMAPFromBitmap
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
(ByVal bitmap As Long, hbmReturn As Long, _
ByVal background As Long) As Long
'DeleteGraphics
Private Declare Function GdipDeleteGraphics Lib "gdiplus" _
(ByVal graphics As Long) As Long
'DisposeImage
Private Declare Function GdipDisposeImage Lib "gdiplus.dll" _
(ByVal image As Long) As GDIPlusStatusConstants
'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
'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
'SetInterpolationMode 補間モード設定
Private Declare Function GdipSetInterpolationMode Lib "gdiplus" _
(ByVal graphics As Long, _
ByVal nInterpolationMode As InterpolationMode) As Long
'SaveImageToFile
Private Declare Function GdipSaveImageToFile Lib "gdiplus.dll" _
(ByVal image As Long, ByVal filename As Long, ByRef clsidEncoder As Guid, ByVal encoderParams As Long) As GDIPlusStatusConstants
'Startup
Private Declare Function GdiplusStartup Lib "gdiplus.dll" _
(ByRef token As Long, ByRef inputBuf As GdiplusStartupInput, ByVal outputBuf As Long) As GDIPlusStatusConstants
'Shutdown
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)
'その他
Private Declare Function CLSIDFromString Lib "ole32" _
(ByVal lpszCLSID As Long, ByRef pclsid As Guid) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef lpPictDesc As PICTDESC, _
ByRef RefIID As Guid, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) As Long
'使用例 Vix等でトリミングした画像を、サイズ指定でエクセルのシートに貼り付けたかったのが
'発端です。
Sub test()
Dim myStdPicture As StdPicture
Dim gdipRet As GDIPlusStatusConstants
Set myStdPicture = CreatePictureFromClipboard
gdipRet = cb2cb_resized(myStdPicture, Range("A2").Value, InterpolationModeHighQualityBicubic)
If gdipRet = GDIPlusStatusConstants.Ok Then ActiveSheet.Paste
End Sub
Public Function cb2cb_resized( _
ByVal PicObj As IPictureDisp, _
Optional ByVal outputHeight As Long = 200, _
Optional ByVal InterpolationMode As InterpolationMode _
= InterpolationModeHighQualityBicubic _
) As GDIPlusStatusConstants
Dim GdiPStartupInput As GdiplusStartupInput
Dim Ret As GDIPlusStatusConstants
Dim GDIPToken As Long, lngStatus As Long
Dim GdipBmpHdl As Long
Dim lngHeight As Long, lngWidth As Long
Dim pGraphics As Long, pDstBmp As Long
Dim EncodParameters As EncoderParameters
Dim hBmp As Long
Dim aspectRatio As Double
Dim uPictDesc As PICTDESC
Dim uGUID As Guid
Dim objPicture As StdPicture
' ピクチャーオブジェクトが無い
If PicObj Is Nothing Then
cb2cb_resized = GDIPlusStatusConstants.UnknownImageFormat
Exit Function
End If
' GDIスタートアップ構造体初期化
GdiPStartupInput.GdiplusVersion = 1
' GDI+ライブラリ初期化して失敗なら終了
If GdiplusStartup(GDIPToken, GdiPStartupInput, 0&) <> 0 Then Exit Function
' ピクチャーからGDI+BITMAPを作成
Ret = GdipCreateBitmapFromHBITMAP(PicObj.Handle, 0&, GdipBmpHdl)
' 変換成功
If Ret <> GDIPlusStatusConstants.Ok Then GoTo terminate
' 元画像サイズの取得 'OK
GdipGetImageWidth GdipBmpHdl, lngWidth
GdipGetImageHeight GdipBmpHdl, lngHeight
aspectRatio = lngWidth / lngHeight
' サイズの変更
lngWidth = CLng(outputHeight * aspectRatio)
lngHeight = outputHeight
If GdipGetImageGraphicsContext(GdipBmpHdl, pGraphics) = 0 Then
' コピー先Bitmap作成
lngStatus = GdipCreateBitmapFromGraphics( _
lngWidth, lngHeight, pGraphics, pDstBmp)
GdipDeleteGraphics pGraphics
If lngStatus = 0 Then
' コピー用Graphics作成
If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
' 補間方法の設定
InterpolationMode = InterpolationModeBicubic
GdipSetInterpolationMode pGraphics, InterpolationMode
' イメージのコピー
GdipDrawImageRectI pGraphics, GdipBmpHdl, 0, 0, lngWidth, lngHeight
'bitmapオブジェクトのハンドルを取得
GdipCreateHBITMAPFromBitmap pDstBmp, hBmp, 0&
End If
GdipDisposeImage pDstBmp
End If
End If
' GDI+BITMAPを廃棄
GdipDisposeImage GdipBmpHdl
' 以降はOLEのPictureオブジェクト作成処理
With uGUID
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPictDesc
.cbSizeofstruct = Len(uPictDesc)
.picType = PICTYPE_BITMAP
.hImage = hBmp
End With
If OleCreatePictureIndirect(uPictDesc, uGUID, 1, objPicture) < 0 Then DeleteObject hBmp
Call CopyBitmapPictureToCB(ByVal objPicture)
' GDI+ライブラリ開放
terminate:
GdiplusShutdown GDIPToken
'下記のコードだと安定して貼り付けられない(pDstBmpを削除しないでも）
' If OpenClipboard(0&) <> 0 Then
' EmptyClipboard
' SetClipboardData CF_BITMAP, hBmp
' CloseClipboard
' cb2cb_resized = GDIPlusStatusConstants.Ok
' Else
' cb2cb_resized = GDIPlusStatusConstants.Aborted
' End If
End Function
' // クリップボードのビットマップデータから Picture オブジェクトを作成
'http://okwave.jp/qa/q2885043.html
'KenKen_SPさん
Public Function CreatePictureFromClipboard() As StdPicture
Dim hImg As Long
Dim hPalette As Long
Dim uPictDesc As PICTDESC
Dim uGUID As Guid
Set CreatePictureFromClipboard = Nothing
' 終了条件:: クリップボードに該当データが無い
If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then Exit Function
' 終了条件:: クリップボードからイメージハンドルが取得できない
If OpenClipboard(0&) <> 0 Then
hImg = GetClipboardData(CF_BITMAP)
hPalette = GetClipboardData(CF_PALETTE)
Call CloseClipboard
Else
MsgBox "cannot get bitmap from CB"
Exit Function
End If
If hImg = 0 Then
MsgBox "cannot get bitmap from CB"
Exit Function
End If
With uPictDesc
.cbSizeofstruct = Len(uPictDesc)
.picType = PICTYPE_BITMAP
.hImage = hImg
.Option1 = hPalette
End With
With uGUID
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
Call OleCreatePictureIndirect(uPictDesc, _
uGUID, _
0&, _
CreatePictureFromClipboard)
End Function
Private Function ConvCLSID(ByVal sGuid As String) As Guid
CLSIDFromString StrPtr(sGuid), ConvCLSID
End Function
' ビットマップ形式のPictureをクリップボードにコピー
Private Function CopyBitmapPictureToCB(ByVal pic As Object) As Boolean
Dim hBmp As Long
If pic Is Nothing Then Exit Function
If pic.Type <> PICTYPE_BITMAP Then Exit Function
hBmp = pic.Handle
hBmp = CopyImage(hBmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
If hBmp = 0 Then Exit Function
If OpenClipboard(0) Then
EmptyClipboard
If SetClipboardData(CF_BITMAP, hBmp) Then
hBmp = 0
CopyBitmapPictureToCB = True
End If
CloseClipboard
End If
If hBmp Then DeleteObject hBmp
End Function