'☆ユーザーフォームモジュール
'貼り付け有効・無効のチェックボックス(CheckBox1)
'他に縮小倍率設定(TextBox1)、回転角度設定(TextBox2)のテキストボックスと、スピンボタンを設けている
'初期値設定
Private Sub UserForm_Initialize()
Me.TextBox1 = 20
Me.TextBox2 = 0
End Sub
Private Sub CheckBox1_Change()
If CheckBox1.Value = True Then
ghWnd = getExcelHWD
If ghWnd = 0 Then
MsgBox "Excelのハンドルが取得できません"
Exit Sub
End If
'サブクラス化開始
Call Hook
Else
'サブクラス化解除
Call Unhook
End If
End Sub
'スピンボタンで回転角度を変更
Private Sub SpinButton1_SpinDown()
TextBox2.Value = CStr(Val(TextBox2.Value) + 5)
End Sub
Private Sub SpinButton1_SpinUp()
TextBox2.Value = CStr(Val(TextBox2.Value) - 5)
End Sub
'☆標準モジュール
Public Enum InterpolationMode ' 補間方法
InterpolationModeInvalid = -1
InterpolationModeDefault = 0
InterpolationModeLowQuality = 1
InterpolationModeHighQuality = 2
InterpolationModeBilinear = 3
InterpolationModeBicubic = 4
InterpolationModeNearestNeighbor = 5
InterpolationModeHighQualityBilinear = 6
InterpolationModeHighQualityBicubic = 7
End Enum
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
cbSizeofStruct As Long
picType As Long
hbitmap As Long
hpal As Long
unused_wmf_yExt As Long
End Type
Enum MatrixOrder
MatrixOrderPrepend = 0
MatrixOrderAppend = 1
End Enum
'GDI+開始
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, pInput As GdiplusStartupInput, _
pOutput As Any) As Long
'GDI+終了
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
'デバイスコンテキストからGraphicsを生成
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, graphics As Long) As Long
'Graphics削除
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
'補間モード設定
Private Declare Function GdipSetInterpolationMode Lib "gdiplus" (ByVal graphics As Long, _
ByVal nInterpolationMode As InterpolationMode) As Long
'Image削除
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
'Imageの寸法取得
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
'Graphicsのサイズに合わせてImage描画
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
'ファイルからBitmap取得
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (FileName As Any, bitmap As Long) As Long
'GraphicsからBitmap取得
Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, _
ByVal Target As Long, bitmap As Long) As Long
'BitmapをHBITMAPに変換、クリップボードへの貼り付けに必要
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As Long, hbmReturn As Long, _
ByVal background As Long) As Long
'OleStdPictureの生成
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (lpPictDesc As PICTDESC, riid As GUID, _
ByVal fOwn As Long, lplpvObj As Any) As Long
'Objectの削除
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Const PICTYPE_BITMAP = 1
Const UnitWorld = 0 ' World coordinate (non-physical unit)
Const UnitDisplay = 1 ' Variable -- for PageTransform only
Const UnitPixel = 2 ' Each unit is one device pixel.
Const UnitPoint = 3 ' Each unit is a printer's point, or 1/72 inch.
Const UnitInch = 4 ' Each unit is 1 inch.
Const UnitDocument = 5 ' Each unit is 1/300 inch.
Const UnitMillimeter = 6 ' Each unit is 1 millimeter.
Const PixelFormatIndexed As Long = &H10000 ' Indexes into a palette
Const PixelFormatGDI As Long = &H20000 ' Is a GDI-supported format
Const PixelFormatAlpha As Long = &H40000 ' Has an alpha component
Const PixelFormatPAlpha As Long = &H80000 ' Pre-multiplied alpha
Const PixelFormatExtended As Long = &H100000 ' Extended color 16 bits/channel
Const PixelFormatCanonical As Long = &H200000
Const PixelFormatUndefined As Long = 0
Const PixelFormatDontCare As Long = 0
'追加分 クリップボード操作
Const CF_BITMAP As Long = 2
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () 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 Declare Function GdipRotateWorldTransform Lib "gdiplus" (ByVal graphics As Long, ByVal angle As Single, ByVal order As MatrixOrder) As Long
'Imageの複写
Private Declare Function GdipCloneImage Lib "gdiplus.dll" (ByVal pImage As Long, ByRef cloneImage As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus.dll" (ByVal pColor As Long, ByRef brush As Long) As Long
'塗りつぶし四角形を描画
Private 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
'GDI+のブラシ削除
Private Declare Function GdipDeleteBrush Lib "gdiplus.dll" (ByVal brush As Long) As Long
'座標変換
Private Declare Function GdipTranslateWorldTransform Lib "gdiplus.dll" (ByVal graphics As Long, ByVal dx As Single, ByVal dy As Single, ByVal order As Long) As Long
'メモリ上にBitmapを生成
Private 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
'原寸のままでGraphicsにImageを貼付
Private 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
'GdipCreateBitmapFromScan0の引数に使用
Dim PixelFormat32bppARGB As Long
Type POINTAPI
x As Long
y As Long
End Type
'指定されたウィンドウプロシージャに、メッセージ情報を渡します
Private 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
'指定されたウィンドウの属性を変更
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'ウィンドウがファイルのドラッグアンドドロップを受け入れるかどうかを設定
Private Declare Sub DragAcceptFiles Lib "Shell32.dll" (ByVal hWnd As Long, ByVal fAccept As Long)
'ドラッグアンドドロップ操作が成功した場合、ドロップされたファイルの名前を取得する
Private 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
'アプリケーションへファイル名を転送するためにシステムが割り当てたメモリを解放
Private Declare Sub DragFinish Lib "Shell32.dll" (ByVal hDrop As Long)
'ウィンドウのハンドル取得
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'指定ウィンドウを前面に
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function DragQueryPoint Lib "Shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long
'クライアント座標→スクリーン座標への変換
Private Declare Function ClientToScreen Lib "user32.dll" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public IsHooked As Boolean
Public lpPrevWndProc As Long
Public ghWnd As Long
Private Const WM_DROPFILES = &H233
Private Const GWL_WNDPROC = -4
Const DPI As Long = 96 'Pixel per inch
Const PPI As Long = 72 'Point per inch
'設定用フォームの表示
Sub loadSettingForm()
UserForm1.Show vbModeless
End Sub
Sub auto_open()
Call loadSettingForm
End Sub
'----------------------------------------------------------------
'サブクラス化開始
' ツール／マクロで表示されないように、ダミーの引数をもたせた
' Publicにしないと、UserFormから参照できない
'----------------------------------------------------------------
Public Sub Hook(Optional ByVal dummy As Long)
If IsHooked Then
MsgBox "Don't hook it twice without " & _
"unhooking, or you will be unable to unhook it."
Else
'受け入れの有
Call DragAcceptFiles(ghWnd, True)
'ウィンドウプロシージャの登録
lpPrevWndProc = SetWindowLong(ghWnd, GWL_WNDPROC, AddressOf WindowProc)
IsHooked = True
End If
End Sub
'----------------------------------------------------------------
'サブクラス化解除
'----------------------------------------------------------------
Public Sub Unhook(Optional ByVal dummy As Long)
Dim temp As Long
'元のウィンドウプロシージャに戻す
temp = SetWindowLong(ghWnd, GWL_WNDPROC, lpPrevWndProc)
'受け入れの無
Call DragAcceptFiles(ghWnd, True)
IsHooked = False
End Sub
'----------------------------------------------------------------
'ウィンドウプロシージャ
'----------------------------------------------------------------
Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim hDrop As Long
Dim filecnt As Long 'ファイルの総数
Dim files() As String 'ファイル名
Dim i As Long
Dim leng As Long
Dim buf As String * 256
Dim pDrop As POINTAPI
Dim pScrn As POINTAPI
Dim dummy As StdPicture
On Error Resume Next '追加
Select Case uMsg
Case WM_DROPFILES 'ドロップされた
'---------------------------------------
'ドラッグされたファイルの格納
'---------------------------------------
hDrop = wParam
'ドラッグされたファイル数の取得
filecnt = DragQueryFile(hDrop, -1&, vbNullString, 0)
'ドロップされた位置の取得
Call DragQueryPoint(hDrop, pDrop)
pScrn = pDrop
Call ClientToScreen(ghWnd, pScrn)
'配列初期化
ReDim files(filecnt - 1)
'ファイル名の取得
For i = 0 To filecnt - 1
'変数初期化
buf = String(256, Chr(0)) 'nullで埋める
'ファイルの取得
leng = DragQueryFile(hDrop, i, buf, 256)
'取得結果を配列に格納
files(i) = Left$(buf, InStr(1, buf, Chr(0)) - 1)
Next
'エクセルを前面に
SetForegroundWindow ghWnd
'ドロップされた位置に該当するセルをActivate
Range(screenToCellAddress(pScrn)).Activate
Set dummy = LoadPictureScaledandRotated(files(0), UserForm1.TextBox1.Value, InterpolationModeHighQualityBicubic, UserForm1.TextBox2.Value)
ActiveSheet.Paste
SendKeys "{ESC}" 'ちらつき防止
'メモリの開放
Call DragFinish(hDrop)
'連続実行すると暴走(UserFormが制御不能化）する事が多いのでシングル動作に変更。都度チェックしなおす必要あり。
Unhook
UserForm1.CheckBox1 = False
Case Else
'WindowProc = CallWindowProc(lpPrevWndProc, hWnd, uMsg, wParam, lParam)
End Select
'他の処理はデフォルトのウィンドウプロシージャに委ねる - 場所移動
WindowProc = CallWindowProc(lpPrevWndProc, hWnd, uMsg, wParam, lParam)
End Function
'エクセルのハンドル取得
Public Function getExcelHWD() As Long
getExcelHWD = FindWindow("XLMAIN", vbNullString)
End Function
'ワークシート上のクリックより得られたスクリーン座標をセル座標に変換する
Private Function screenToCellAddress(scrnPOINT As POINTAPI) As String
Dim pointDifX As Single, pointDifY As Single
Dim startX As Single, startY As Single
Dim targetRange As Range
Dim pointX As Single, pointY As Single
Dim zoomX As Single, zoomY As Single
Dim i As Long
'左上隅セルの左上角との距離をポイントに変換
Call realZoomRate(zoomX, zoomY)
pointDifX = (scrnPOINT.x - ActiveWindow.PointsToScreenPixelsX(0)) * PPI / DPI / zoomX
pointDifY = (scrnPOINT.y - ActiveWindow.PointsToScreenPixelsY(0)) * PPI / DPI / zoomY
startX = ActiveWindow.VisibleRange(1).Left
startY = ActiveWindow.VisibleRange(1).Top
Set targetRange = ActiveWindow.VisibleRange(1)
For i = 1 To ActiveWindow.VisibleRange(1).Column
pointX = pointX + targetRange.Width
Next i
For i = 1 To ActiveWindow.VisibleRange(1).Row
pointY = pointY + targetRange.Height
Next i
Do Until pointX > pointDifX
Set targetRange = targetRange.Offset(0, 1)
pointX = pointX + targetRange.Width
Loop
Do Until pointY > pointDifY
Set targetRange = targetRange.Offset(1, 0)
pointY = pointY + targetRange.Height
Loop
screenToCellAddress = targetRange.Address
End Function
'真のズーム倍率を求める 'by kanabun
Private Sub realZoomRate(ByRef zoomX As Single, ByRef zoomY As Single)
Dim c As Range
Dim dotX As Long
Dim dotY As Long
Dim dotX1 As Long
Dim dotY1 As Long
Set c = Range("a1")
With ActiveWindow
' ---------- 実際のZoom比の計算 ---------------
dotY = c.Height * DPI / PPI
dotY1 = dotY * .Zoom / 100
zoomY = dotY1 / dotY '実際に適用されているZoom率
dotX = c.Width * DPI / PPI
dotX1 = dotX * .Zoom / 100
zoomX = dotX1 / dotX
End With
End Sub
'shira氏のコードに若干追加
Private Function LoadPictureScaledandRotated( _
ByVal FileName As String, _
Optional ByVal scalerate As Long = 100, _
Optional ByVal InterpolationMode As InterpolationMode = InterpolationModeBilinear, _
Optional ByVal angle As Single = 0 _
) As stdole.IPictureDisp
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, lngWidthd
Dim lngHeight As Long, lngHeightd
Dim lngStatus As Long
Dim pImageTemp As Long
Dim hBrush As Long '追加
' 初期化
udtInput.GdiplusVersion = 1
If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
Exit Function
End If
' 画像の読みこみ
If GdipCreateBitmapFromFile(ByVal StrPtr(FileName), pSrcBmp) <> 0 Then
GdiplusShutdown lngToken
Exit Function
End If
'画像の回転
Call RotateImage(pSrcBmp, pImageTemp, angle, &HFFFFFFFF)
' pImageTemp = pSrcBmp 'for debug
' 元画像サイズの取得
GdipGetImageWidth pImageTemp, lngWidth
GdipGetImageHeight pImageTemp, lngHeight
' サイズの変更
lngWidthd = lngWidth * scalerate \ 100
lngHeightd = lngHeight * scalerate \ 100
Debug.Print lngWidthd, lngHeightd
If GdipGetImageGraphicsContext(pImageTemp, pGraphics) = 0 Then
' コピー先Bitmap作成
lngStatus = GdipCreateBitmapFromGraphics(lngWidthd, lngHeightd, 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, lngWidthd, lngHeightd
' GdipDrawImageRectRectI pGraphics, pImageTemp, 0, 0, lngWidthd, lngHeightd, 0, 0, lngWidth, lngHeight, UnitPixel, 0, 0, 0
GdipDeleteGraphics pGraphics
' GDIのビットマップ作成
GdipCreateHBITMAPFromBitmap pDstBmp, hBmp, 0
End If
GdipDisposeImage pDstBmp
End If
End If
GdipDisposeImage pImageTemp
GdiplusShutdown lngToken
If hBmp = 0 Then Exit Function
'画像をクリップボードにコピー
If OpenClipboard(0) <> 0 Then
EmptyClipboard
SetClipboardData CF_BITMAP, hBmp
CloseClipboard
End If
' 以降は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
Set LoadPictureScaledandRotated = objPicture
Else
' エラー時
DeleteObject hBmp
End If
End Function
Private Sub RotateImage(ByRef hImage As Long, ByRef imgImage As Long, ByVal angle As Single, Optional lBackColour 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 hImage, lHeight
GdipGetImageWidth hImage, 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&, imgImage
GdipGetImageGraphicsContext imgImage, imgGraphics
GdipCreateSolidFill lBackColour, 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, hImage, 0, 0, lWidth, lHeight, 0, 0, lWidth, lHeight, UnitPixel, 0, 0, 0
GdipDeleteGraphics imgGraphics
GdipDisposeImage hImage
End Sub
Private Function BitShift(Value As Long, Shift As Long) As Long
BitShift = Value * 2 ^ Shift
End Function