- ホーム
- GDI+
- クリップボードのbitmapをjpeg保存
クリップボードのbitmapをjpeg保存【XL2010 OK】
クリップボードのbitmap形式の画像データをjpeg形式で保存します
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
' // 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 = SavePictureJpg(myStdPicture, "c:\cb2jpeg.jpg", 85)
End Sub
' // クリップボードのビットマップデータから 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
End If
If hImg = 0 Then Exit Function
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
'http://hpcgi1.nifty.com/MADIA/VBBBS2/wwwlng.cgi?print+200708/07080012.txt
'紅閃光さん
Public Function SavePicturePng(ByVal PicObj As IPictureDisp, ByVal FName As String) As GDIPlusStatusConstants
Dim GdiPStartupInput As GdiplusStartupInput
Dim Ret As GDIPlusStatusConstants
Dim GDIPToken As Long
Dim GdipBmpHdl As Long
' ピクチャーオブジェクトが無い
If PicObj Is Nothing Then
SavePicturePng = 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
' PNG変換で保存
SavePicturePng = GdipSaveImageToFile(GdipBmpHdl, StrPtr(FName), ConvCLSID(CLSID_PNG), 0)
' GDI+BITMAPを廃棄
GdipDisposeImage GdipBmpHdl
End If
' GDI+ライブラリ開放
GdiplusShutdown GDIPToken
End Function
Public Function SavePictureJpg(ByVal PicObj As IPictureDisp, ByVal FName As String, ByVal Quality As Long) As GDIPlusStatusConstants
Dim GdiPStartupInput As GdiplusStartupInput
Dim Ret As GDIPlusStatusConstants
Dim GDIPToken As Long
Dim GdipBmpHdl As Long
Dim EncodParameters As EncoderParameters
' 圧縮品質設定範囲のチェック
If Quality > 100 Then Quality = 100
If Quality < 25 Then Quality = 25
' ピクチャーオブジェクトが無い
If PicObj Is Nothing Then
SavePictureJpg = 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
' エンコーダパラメータ設定
EncodParameters.Count = 1
With EncodParameters.Parameter(0)
.Guid = ConvCLSID(CLSID_QUALITY)
.NumberOfValues = 1
' 4=EncoderParameterValueTypeLong
.Type = 4
' 圧縮品質
.Value = VarPtr(Quality)
End With
' JPG変換で保存
SavePictureJpg = GdipSaveImageToFile(GdipBmpHdl, StrPtr(FName), ConvCLSID(CLSID_JPEG), VarPtr(EncodParameters))
' GDI+BITMAPを廃棄
GdipDisposeImage GdipBmpHdl
End If
' GDI+ライブラリ開放
GdiplusShutdown GDIPToken
End Function
Private Function ConvCLSID(ByVal sGuid As String) As Guid
CLSIDFromString StrPtr(sGuid), ConvCLSID
End Function