- ホーム
- GDI+
- CBのbitmapをリサイズしてjpeg保存
クリップボードのbitmapをリサイズしてjpeg保存
本当はクリップボードに戻したいのだが、うまくいっていません
clipbrd.exeで確認すると、「クリップブックでは、現在の形式の情報は表示されないか、
またはメモリ不足のため情報が表示されません。アプリケーションをいくつか終了して、 使用可能なメモリを増やせ」
というエラーが出てNG。VIXに貼り付けると暴走しました。
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
' // Declareations --------------------------------------------------
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 OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef lpPictDesc As PICTDESC, _
ByRef RefIID As Guid, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) 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
'GDI+
Private Declare Function GdiplusStartup Lib "gdiplus.dll" _
(ByRef token As Long, ByRef inputBuf As GdiplusStartupInput, ByVal outputBuf As Long) As GDIPlusStatusConstants
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" _
(ByVal hbm As Long, ByVal hpal As Long, ByRef bitmap As Long) As GDIPlusStatusConstants
Private Declare Function GdipDisposeImage Lib "gdiplus.dll" _
(ByVal image As Long) As GDIPlusStatusConstants
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
Private Declare Function CLSIDFromString Lib "ole32" _
(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
'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
'DeleteGraphics
Private Declare Function GdipDeleteGraphics Lib "gdiplus" _
(ByVal graphics As Long) As Long
'CreatHBITMAPFromBitmap
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
(ByVal bitmap As Long, hbmReturn As Long, _
ByVal background 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
' // Constants ------------------------------------------------------
Private Const CF_BITMAP As Long = 2
Private Const CF_PALETTE As Long = 9
Private Const CLSID_PNG = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_JPEG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_QUALITY = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
'使用例
Sub saveCBtoJPEG()
Dim myStdPicture As StdPicture
Dim gdipRet As GDIPlusStatusConstants
Set myStdPicture = CreatePictureFromClipboard
gdipRet = SaveResizedPictureJpg(myStdPicture, "c:\cb2jpeg.jpg", 30, InterpolationModeHighQualityBicubic, 90)
End Sub
Public Function SaveResizedPictureJpg( _
ByVal PicObj As IPictureDisp, _
ByVal FName As String, _
Optional ByVal scalerate As Long = 100, _
Optional ByVal InterpolationMode As InterpolationMode _
= InterpolationModeHighQualityBicubic, _
Optional ByVal jpegQuality As Long = 85 _
) 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
' ピクチャーオブジェクトが無い
If PicObj Is Nothing Then
SaveResizedPictureJpg = 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
' サイズの変更
lngWidth = lngWidth * scalerate \ 100
lngHeight = lngHeight * scalerate \ 100
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
'クリップブックでは、現在の形式の情報は表示されないか、または
'メモリ不足のため情報が表示されません。アプリケーションをいくつか終了して、
'使用可能なメモリを増や －というエラーが出てCBにコピーできない
' GdipCreateHBITMAPFromBitmap pDstBmp, hBmp, 0&
'hBmpは0でない値を戻すが、CB貼り付けでエラーになる
GdipDeleteGraphics pGraphics
' エンコーダパラメータ設定
EncodParameters.Count = 1
jpegQuality = 85
With EncodParameters.Parameter(0)
.Guid = ConvCLSID(CLSID_QUALITY)
.NumberOfValues = 1
' 4=EncoderParameterValueTypeLong
.Type = 4
' 圧縮品質 定数で与えると誤動作する？
.Value = VarPtr(jpegQuality)
End With
' JPG変換で保存
Call GdipSaveImageToFile(pDstBmp, StrPtr(FName), ConvCLSID(CLSID_JPEG), VarPtr(EncodParameters))
End If
GdipDisposeImage pDstBmp
End If
End If
' GDI+BITMAPを廃棄
GdipDisposeImage GdipBmpHdl
' GDI+ライブラリ開放
terminate:
GdiplusShutdown GDIPToken
' If OpenClipboard(0&) <> 0 Then
' EmptyClipboard
' SetClipboardData CF_BITMAP, hBmp
' CloseClipboard
' 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 = 1
.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