Public Enum InterpolationMode ' 補間方法
InterpolationModeInvalid = -1
InterpolationModeDefault = 0
InterpolationModeLowQuality = 1
InterpolationModeHighQuality = 2
InterpolationModeBilinear = 3
InterpolationModeBicubic = 4
InterpolationModeNearestNeighbor = 5
InterpolationModeHighQualityBilinear = 6
InterpolationModeHighQualityBicubic = 7
End Enum
Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Public Type PICTDESC
cbSizeofstruct As Long
picType As Long
hbitmap As Long
hpal As Long
unused_wmf_yExt As Long
End Type
Public Type EncoderParameter
GUID As GUID
NumberOfValues As Long
Type As Long
Value As Long
End Type
Public Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type
Enum MatrixOrder
MatrixOrderPrepend = 0
MatrixOrderAppend = 1
End Enum
Public Type POINTAPI
x As Long
y As Long
End Type
'画像ファイル保存関係
Public Const CLSID_BMP As String = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Public Const CLSID_JPEG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Public Const CLSID_QUALITY As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
'同じもの
Public Const QUALITY_PARAMS As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Public Const ENCODER_BMP As String = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Public Const ENCODER_JPG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Public Const ENCODER_GIF As String = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Public Const ENCODER_TIF As String = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Public Const ENCODER_PNG As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Public Const PICTYPE_BITMAP = 1
Public Const UnitWorld = 0 ' World coordinate (non-physical unit)
Public Const UnitDisplay = 1 ' Variable -- for PageTransform only
Public Const UnitPixel = 2 ' Each unit is one device pixel.
Public Const UnitPoint = 3 ' Each unit is a printer's point, or 1/72 inch.
Public Const UnitInch = 4 ' Each unit is 1 inch.
Public Const UnitDocument = 5 ' Each unit is 1/300 inch.
Public Const UnitMillimeter = 6 ' Each unit is 1 millimeter.
Public Const PixelFormatIndexed As Long = &H10000 ' Indexes into a palette
Public Const PixelFormatGDI As Long = &H20000 ' Is a GDI-supported format
Public Const PixelFormatAlpha As Long = &H40000 ' Has an alpha component
Public Const PixelFormatPAlpha As Long = &H80000 ' Pre-multiplied alpha
Public Const PixelFormatExtended As Long = &H100000 ' Extended color 16 bits/channel
Public Const PixelFormatCanonical As Long = &H200000
Public Const PixelFormatUndefined As Long = 0
Public Const PixelFormatDontCare As Long = 0
'クリップボード関係
Public Const CF_BITMAP = 2
Public Const CF_DIB = 8
Public Const CF_DIF = 5
Public Const CF_DSPBITMAP = &H82
Public Const CF_DSPENHMETAFILE = &H8E
Public Const CF_DSPMETAFILEPICT = &H83
Public Const CF_DSPTEXT = &H81
Public Const CF_ENHMETAFILE = 14
Public Const CF_GDIOBJFIRST = &H300
Public Const CF_GDIOBJLAST = &H3FF
Public Const CF_METAFILEPICT = 3
Public Const CF_OEMTEXT = 7
Public Const CF_OWNERDISPLAY = &H80
Public Const CF_PALETTE = 9
Public Const CF_PENDATA = 10
Public Const CF_PublicFIRST = &H200
Public Const CF_PublicLAST = &H2FF
Public Const CF_RIFF = 11
Public Const CF_SYLK = 4
Public Const CF_TEXT = 1
Public Const CF_TIFF = 6
Public Const CF_UNICODETEXT = 13
Public Const CF_WAVE = 12
'追加
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
'CloneImage Imageの複写
Public Declare Function GdipCloneImage Lib "gdiplus.dll" (ByVal pImage As Long, ByRef cloneImage As Long) As Long
'CreateBitmapFromFile
Public Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
(FileName As Any, bitmap As Long) As Long
'CreateBitmapFromGraphics
Public Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" _
(ByVal Width As Long, ByVal Height As Long, _
ByVal Target As Long, bitmap As Long) As Long
'CreateBitmapFromScan0 メモリ上にBitmapを生成
Public Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus.dll" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, nBitmap As Long) As Long
'CreatHBITMAPFromBitmap
Public Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
(ByVal bitmap As Long, hbmReturn As Long, _
ByVal background As Long) As Long
'CreateSolidFill
Public Declare Function GdipCreateSolidFill Lib "gdiplus.dll" (ByVal pColor As Long, ByRef brush As Long) As Long
'DeleteBrush GDI+のブラシ削除
Public Declare Function GdipDeleteBrush Lib "gdiplus.dll" (ByVal brush As Long) As Long
'DeleteGraphics
Public Declare Function GdipDeleteGraphics Lib "gdiplus" _
(ByVal graphics As Long) As Long
'DisposeImage
Public Declare Function GdipDisposeImage Lib "gdiplus" _
(ByVal image As Long) As Long
'DrawImageRectI
Public 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
'DrawImageRectRectI 原寸のままでGraphicsにImageを貼付
Public Declare Function GdipDrawImageRectRectI Lib "gdiplus.dll" (ByVal graphics As Long, ByVal nImage As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcWidth As Long, ByVal srcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long, Optional ByVal pCALLBACK As Long, Optional ByVal callbackData As Long) As Long
'FillRectangle 塗りつぶし四角形を描画
Public Declare Function GdipFillRectangle Lib "gdiplus.dll" (ByVal graphics As Long, ByVal brush As Long, ByVal x As Single, ByVal y As Single, ByVal nWidth As Single, ByVal nHeight As Single) As Long
'GetImageGraphicsContext
Public Declare Function GdipGetImageGraphicsContext Lib "gdiplus" _
(ByVal image As Long, graphics As Long) As Long
'GetInterpolationMode
Public Declare Function GdipGetInterpolationMode Lib "gdiplus" _
(ByVal graphics As Long, _
pInterpolationMode As InterpolationMode) As Long
'GetImageHeight
Public Declare Function GdipGetImageHeight Lib "gdiplus" _
(ByVal image As Long, Height As Long) As Long
'GetImageThumbnail
Public Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, ByVal callback As Long, callbackData As Any) As Long
'GetImageWidth
Public Declare Function GdipGetImageWidth Lib "gdiplus" _
(ByVal image As Long, Width As Long) As Long
'LoadImageFromFile
Public Declare Function GdipLoadImageFromFile Lib "gdiplus" _
(FileName As Any, image As Long) As Long
'RotateWorldTransform 座標変換－回転
Public Declare Function GdipRotateWorldTransform Lib "gdiplus" (ByVal graphics As Long, ByVal angle As Single, ByVal order As MatrixOrder) As Long
'SaveImageToFile
Public Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
ByVal image As Long, _
ByVal FileName As Long, _
ByRef clsidEncoder As GUID, _
ByVal encoderParams As Any) As Long
'SetInterpolationMode 補間モード設定
Public Declare Function GdipSetInterpolationMode Lib "gdiplus" _
(ByVal graphics As Long, _
ByVal nInterpolationMode As InterpolationMode) As Long
'Shutdown
Public Declare Sub GdiplusShutdown Lib "gdiplus" _
(ByVal token As Long)
'Startup
Public Declare Function GdiplusStartup Lib "gdiplus" _
(token As Long, pInput As GdiplusStartupInput, _
pOutput As Any) As Long
'TranslateWorldTransform 座標変換
Public Declare Function GdipTranslateWorldTransform Lib "gdiplus.dll" (ByVal graphics As Long, ByVal dx As Single, ByVal dy As Single, ByVal order As Long) As Long
'------ GDI+以外 -----
'DeleteObject
Public Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
'OleCreatePictureIndirect
Public Declare Function OleCreatePictureIndirect Lib "olepro32" _
(lpPictDesc As PICTDESC, riid As GUID, _
ByVal fOwn As Long, lplpvObj As Any) As Long
Public Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpszCLSID As Long, _
ByRef pCLSID As GUID) As Long
'------ クリップボード関係 -----
Public Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
'------ ワークシートに画像をD&Dする危ないトライアルで使用 -----
'指定されたウィンドウプロシージャに、メッセージ情報を渡します
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'指定されたウィンドウの属性を変更
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'ウィンドウがファイルのドラッグアンドドロップを受け入れるかどうかを設定
Public Declare Sub DragAcceptFiles Lib "Shell32.dll" (ByVal hWnd As Long, ByVal fAccept As Long)
'ドラッグアンドドロップ操作が成功した場合、ドロップされたファイルの名前を取得する
Public Declare Function DragQueryFile Lib "Shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
'アプリケーションへファイル名を転送するためにシステムが割り当てたメモリを解放
Public Declare Sub DragFinish Lib "Shell32.dll" (ByVal hDrop As Long)
'ウィンドウのハンドル取得
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'指定ウィンドウを前面に
Public Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Public Declare Function DragQueryPoint Lib "Shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long
'クライアント座標→スクリーン座標への変換
Public Declare Function ClientToScreen Lib "user32.dll" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
'追加
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'GdipCreateBitmapFromScan0の引数に使用
Dim PixelFormat32bppARGB As Long
Private Function ConvCLSID(ByVal sGuid As String) As GUID
CLSIDFromString StrPtr(sGuid), ConvCLSID
End Function
Sub test()
Const FileName As String = "C:\sample1.jpg"
Call LoadPictureScaledandRotated(FileName, 20, InterpolationModeHighQualityBicubic, 45)
ActiveSheet.Paste
End Sub
'画像をリサイズ、回転してクリップボードにコピー→別途ActiveCellに貼り付け
'設定がおかしいと、直前のデータが残ってしまうが、エラー処理できていない
Private Sub LoadPictureScaledandRotated( _
ByVal FileName As String, _
Optional ByVal scalerate As Long = 100, _
Optional ByVal InterpolationMode As InterpolationMode = InterpolationModeBilinear, _
Optional ByVal angle As Single = 0 _
)
Dim IID_IDispatch As GUID
Dim pd As PICTDESC
Dim udtInput As GdiplusStartupInput
Dim objPicture As Object
Dim hBmp As Long
Dim lngToken As Long
Dim pGraphics As Long
Dim pSrcBmp As Long
Dim pDstBmp As Long
Dim lngWidth As Long
Dim lngHeight As Long
Dim lngStatus As Long
Dim pImageTemp As Long
Dim hBrush As Long
Dim GdipBmpHdl As Long
Dim ret As Long
' 初期化
udtInput.GdiplusVersion = 1
If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
Debug.Print "GDI+ startup failed"
Exit Sub
End If
' 画像の読みこみ
If GdipCreateBitmapFromFile(ByVal StrPtr(FileName), pSrcBmp) <> 0 Then
GdiplusShutdown lngToken
Debug.Print "Read picture file failed"
Exit Sub
End If
'画像の回転
Call RotateImage(pSrcBmp, pImageTemp, angle, &HFFFFFFFF)
' 元画像サイズの取得
GdipGetImageWidth pImageTemp, lngWidth
GdipGetImageHeight pImageTemp, lngHeight
' サイズの変更
lngWidth = lngWidth * scalerate \ 100
lngHeight = lngHeight * scalerate \ 100
If GdipGetImageGraphicsContext(pImageTemp, pGraphics) = 0 Then
' コピー先Bitmap作成
lngStatus = GdipCreateBitmapFromGraphics(lngWidth, lngHeight, pGraphics, pDstBmp)
GdipDeleteGraphics pGraphics
If lngStatus = 0 Then
' コピー用Graphics作成
If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
' 補間方法の設定
GdipSetInterpolationMode pGraphics, InterpolationMode
'縁が出来てしまうので白で塗りつぶしておく
GdipCreateSolidFill &HFFFFFFFF, hBrush
GdipFillRectangle pGraphics, hBrush, 0, 0, lngWidth, lngHeight
GdipDeleteBrush hBrush
' イメージのコピー
GdipDrawImageRectI pGraphics, pImageTemp, 0, 0, lngWidth, lngHeight
GdipDeleteGraphics pGraphics
' GDIのビットマップ作成
GdipCreateHBITMAPFromBitmap pDstBmp, hBmp, 0
End If
GdipDisposeImage pDstBmp
End If
End If
GdipDisposeImage pImageTemp
GdiplusShutdown lngToken
If hBmp = 0 Then Exit Sub
' 以降はOLEのPictureオブジェクト作成処理
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With pd
.cbSizeofstruct = Len(pd)
.picType = PICTYPE_BITMAP
.hbitmap = hBmp
End With
If OleCreatePictureIndirect(pd, IID_IDispatch, _
1, objPicture) >= 0 Then
Else
' エラー時
DeleteObject hBmp
End If
'単純に、SetClipboardData(CF_BITMAP, hBmp)ではうまく行かない
'APIはhBmpを戻し良さそうだが、clipbrd.exeで確認しても取り込まれていない
'冗長だがPictureからクリップボードにコピーするコードを使用（出典見失った）
Call CopyBitmapPictureToCB(ByVal objPicture)
End Sub
Private Sub RotateImage(ByRef pSrcBmp As Long, ByRef pDestBmp As Long, ByVal angle As Single, Optional lBackColor As Long = -1)
' Dim retval As Long
Dim lHeight As Long, lWidth As Long
Dim newHeight As Long, newWidth As Long
Dim hBrush As Long
Dim imgGraphics As Long
Const pi As Single = 3.14159265
GdipGetImageHeight pSrcBmp, lHeight
GdipGetImageWidth pSrcBmp, lWidth
'新しい画像に最低限必要なサイズ算出
newWidth = lWidth * Abs(Cos(angle * pi / 180)) + lHeight * Abs(Sin(angle * pi / 180))
newHeight = lWidth * Abs(Sin(angle * pi / 180)) + lHeight * Abs(Cos(angle * pi / 180))
'; オフスクリーンバッファ Image、Graphics 作成
PixelFormat32bppARGB = 10 Or BitShift(32, 8) Or PixelFormatAlpha Or PixelFormatGDI Or PixelFormatCanonical
GdipCreateBitmapFromScan0 newWidth, newHeight, 0, PixelFormat32bppARGB, ByVal 0&, pDestBmp
GdipGetImageGraphicsContext pDestBmp, imgGraphics
GdipCreateSolidFill lBackColor, hBrush
GdipFillRectangle imgGraphics, hBrush, 0, 0, newWidth, newHeight
GdipDeleteBrush hBrush
'回転
GdipTranslateWorldTransform imgGraphics, -lWidth / 2, -lHeight / 2, MatrixOrderAppend
GdipRotateWorldTransform imgGraphics, angle, MatrixOrderAppend
GdipTranslateWorldTransform imgGraphics, newWidth / 2, newHeight / 2, MatrixOrderAppend
GdipDrawImageRectRectI imgGraphics, pSrcBmp, 0, 0, lWidth, lHeight, 0, 0, lWidth, lHeight, UnitPixel, 0, 0, 0
GdipDeleteGraphics imgGraphics
GdipDisposeImage pSrcBmp
End Sub
Private Function BitShift(Value As Long, Shift As Long) As Long
BitShift = Value * 2 ^ Shift
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