Private Const IMAGE_BITMAP As Long = 0
Private Const LR_LOADFROMFILE As Long = &H10
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'ウィンドウハンドルを取得する関数
Declare Function GetDesktopWindow Lib "user32" () As Long
'ウィンドウのデバイスコンテキストのハンドルを取得する関数
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
'デバイスコンテキストの開放
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
'カーソル位置
Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
'マウスクリック検知
Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Long
Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Public Const VK_LBUTTON = &H1 '[LeftClick]
Private Const IDC_HAND = 32649&
' 画像ファイルの読み込み
Declare Function Api_LoadImage& Lib "user32" Alias "LoadImageA" (ByVal hInst&, ByVal lpszName$, ByVal uType&, ByVal cxDesired&, ByVal cyDesired&, ByVal fuLoad&)
' イメージを拡大縮小してコピーする
Declare Function Api_CopyImage& Lib "user32" Alias "CopyImage" (ByVal handle&, ByVal imageType&, ByVal newWidth&, ByVal newHeight&, ByVal lFlags&)
' クリップボードをオープン
Declare Function Api_OpenClipboard& Lib "user32" Alias "OpenClipboard" (ByVal hwnd&)
' クリップボードを空にする
Declare Function Api_EmptyClipboard& Lib "user32" Alias "EmptyClipboard" ()
' クリップボードにデータを設定
Declare Function Api_SetClipboardData& Lib "user32" Alias "SetClipboardData" (ByVal wFormat&, ByVal hMem&)
' クリップボードから指定フォーマットのデータを検索
Declare Function Api_GetClipboardData& Lib "user32" Alias "GetClipboardData" (ByVal wFormat&)
' クリップボードをクローズ
Declare Function Api_CloseClipboard& Lib "user32" Alias "CloseClipboard" ()
' 指定したフォーマットがクリップボードにあるかどうか判定
Declare Function Api_IsClipboardFormatAvailable& Lib "user32" Alias "IsClipboardFormatAvailable" (ByVal wFormat&)
' 指定されたデバイスコンテキストに関連するデバイスと互換性のあるメモリデバイスコンテキストを作成
Declare Function Api_CreateCompatibleDC& Lib "gdi32" Alias "CreateCompatibleDC" (ByVal hDC&)
' 指定されたデバイスコンテキストのオブジェクトを選択
Declare Function Api_SelectObject& Lib "gdi32" Alias "SelectObject" (ByVal hDC&, ByVal hObject&)
' オブジェクト取得
Declare Function Api_GetObject& Lib "gdi32" Alias "GetObjectA" (ByVal hObject&, ByVal nCount&, lpObject As Any)
' ビットブロック転送を行う。コピー元からコピー先のデバイスコンテキストへ、指定された長方形内の各ピクセルの色データをコピー
Declare Function Api_BitBlt& Lib "gdi32" Alias "BitBlt" (ByVal hDestDC&, ByVal x&, ByVal y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, ByVal dwRop&)
' 指定されたデバイスコンテキストを削除
Declare Function Api_DeleteDC& Lib "gdi32" Alias "DeleteDC" (ByVal hDC&)
' 指定されたウィンドウのクライアント領域または画面全体を表すディスプレイデバイスコンテキストのハンドルを取得
Declare Function Api_GetDC& Lib "user32" Alias "GetDC" (ByVal hwnd&)
' デバイスコンテキストを解放
Declare Function Api_ReleaseDC& Lib "user32" Alias "ReleaseDC" (ByVal hwnd&, ByVal hDC&)
'ウィンドウの位置と大きさ
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'ウィンドウの大きさ取得
Private Declare Function GetSystemMetrics Lib "user32 " (ByVal nIndex As Long) As Long 'APIの宣言
Private Const SM_CXSCREEN As Long = 0 '幅
Private Const SM_CYSCREEN As Long = 1 '高さ
'ウィンドウの大きさ
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Const HORZRES = 8 'ディスプレイの横幅(ピクセル単位)
Const VERTRES = 10 'ディスプレイの縦幅(ピクセル単位)
Const BITSPIXEL = 12 'ピクセル当たりのビット数
Const CF_BITMAP = 2
Const SRCCOPY = &HCC0020
'プリントスクリーンする
Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_SNAPSHOT = &H2C ''[PrintScrn]キー
Const KEYEVENTF_EXTENDEDKEY = &H1 ''キーを押す
Const KEYEVENTF_KEYUP = &H2 ''キーを放す
'クリップボードのクリア
Declare Function EmptyClipboard Lib "user32" () As Long
'マウス位置の指定
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
'マウスクリック
Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, Optional ByVal dx As Long = 0, Optional ByVal dy As Long = 0, Optional ByVal dwDate As Long = 0, Optional ByVal dwExtraInfo As Long = 0)
'順番にボタンを押す
Sub click_test()
ShowWindow Application.hwnd, SW_SHOWMINIMIZED
For Each Hogepic In ActiveSheet.DrawingObjects
Debug.Print Hogepic.Name
sttime = Timer
Api_OpenClipboard 0
Call EmptyClipboard
Api_CloseClipboard
Hogepic.Copy
'コピー待機
Do While Api_IsClipboardFormatAvailable(CF_BITMAP) = 0
Sleep 10
DoEvents
Loop
'コピーしたものを検索して位置特定
Call SearchBMPinDisplay
Debug.Print "完了:" & Timer - sttime
Next
ShowWindow Application.hwnd, SW_RESTORE
End Sub
'マウスクリック
Sub Click(x, y, clickflg)
SetCursorPos x, y
DoEvents
Sleep 100
If clickflg Then
mouse_event 2
mouse_event 4
End If
For i = 1 To 3
keybd_event VK_CONTROL, 0, KEYEVENTF_EXTENDEDKEY, 0
Sleep 10
DoEvents
keybd_event VK_CONTROL, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
Sleep 100
DoEvents
Next
End Sub
'プリントスクリーン
Sub PrincScreen()
''[PrintScrn]キーを押す
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0
''[PrintScrn]キーを放す
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
End Sub
'ディスプレイの中から、クリップボードに入っている画像の位置を特定する
Sub SearchBMPinDisplay()
Dim tBitmap As BITMAP
Application.EnableCancelKey = xlErrorHandler
On Error GoTo myend
DoEvents
'=======================================
'クリップボードの画像を取得
hBmp = getclipBMP
If hBmp = 0 Then
MsgBox "画像をコピーしてからやり直して下さい", vbInformation
GoTo myend
End If
'空っぽのデバイスコンテキストを作成する
hDC = CreateCompatibleDC(0)
hOrgBmp = SelectObject(hDC, hBmp)
'描画したBMPを取得して、tBitmapオブジェクトに格納する
Call GetObject(hBmp, Len(tBitmap), tBitmap)
Dim myWidth, myHeight
myWidth = tBitmap.bmWidth
myHeight = tBitmap.bmHeight
'=======================================
' スクリーンキャプチャを取る
Api_OpenClipboard 0
Call EmptyClipboard
Api_CloseClipboard
DoEvents
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
DoEvents
'クリップボードの画像を取得
Dim hBmp_dsk As Long
Dim hDC_dsk As Long
Dim tBitmap_dsk As BITMAP
hBmp_dsk = getclipBMP
If hBmp_dsk = 0 Then
MsgBox "スクリーンキャプチャ失敗", vbInformation
GoTo myend
End If
'空っぽのデバイスコンテキストを作成する
hDC_dsk = CreateCompatibleDC(0)
hOrgBmp_dsk = SelectObject(hDC_dsk, hBmp_dsk)
'描画したBMPを取得して、tBitmapオブジェクトに格納する
Call GetObject(hBmp_dsk, Len(tBitmap_dsk), tBitmap_dsk)
Api_OpenClipboard 0
Call EmptyClipboard
Api_CloseClipboard
'=======================================
'画像の四隅の色を取得
Dim testPx_array(1 To 5)
testPx_array(1) = GetPixel(hDC, 0, 0) '左上
testPx_array(2) = GetPixel(hDC, myWidth - 1, 0) '右上
testPx_array(3) = GetPixel(hDC, 0, myHeight - 1) '左下
testPx_array(4) = GetPixel(hDC, myWidth - 1, myHeight - 1) '右下
testPx_array(5) = GetPixel(hDC, Round((myWidth - 1) / 2), Round((myHeight - 1) / 2)) '中央
' Debug.Print testPx_array(1), testPx_array(2), testPx_array(3), testPx_array(4)
For i = 0 To tBitmap_dsk.bmWidth - 1
For j = 0 To tBitmap_dsk.bmHeight - 1
'四隅中央の色合致をチェックする
' DoEvents
If GetPixel(hDC_dsk, i, j) = testPx_array(1) Then
If GetPixel(hDC_dsk, i + myWidth - 1, j) = testPx_array(2) Then
If GetPixel(hDC_dsk, i, j + myHeight - 1) = testPx_array(3) Then
If GetPixel(hDC_dsk, i + myWidth - 1, j + myHeight - 1) = testPx_array(4) Then
If GetPixel(hDC_dsk, i + Round((myWidth - 1) / 2), j + Round((myHeight - 1) / 2)) = testPx_array(5) Then
'
' Stop
'四隅は合致
yosumiflg = True
Debug.Print "四隅合致!"
'四隅一致したので、画像の全ピクセルの一致確認
For i2 = 0 To myWidth - 1
For j2 = 0 To myHeight - 1
If GetPixel(hDC, i2, j2) <> GetPixel(hDC_dsk, i + i2, j + j2) Then
yosumiflg = False
Exit For
End If
Next
If yosumiflg = False Then Exit For
Next
'完全一致したので、中央をクリック処理する
If yosumiflg = True Then
Debug.Print "完全一致!"
click_x = i + Round(myWidth / 2)
click_y = j + Round(myHeight / 2)
Click click_x, click_y, False
GoTo myend
End If
End If
End If
End If
End If
End If
Next
Next
'=======================================
'後始末
'描画オブジェクト/デバイスコンテキストの後始末【必須】
myend:
SelectObject hDC, hOrgFont
SelectObject hDC, hOrgBmp
DeleteDC hDC
DeleteObject hBmp
SelectObject hDC_dsk, hOrgFont
SelectObject hDC_dsk, hOrgBmp_dsk
DeleteDC hDC_dsk
DeleteObject hBmp_dsk
End Sub
'クリップボードの画像を取得
Function getclipBMP()
If Api_IsClipboardFormatAvailable(CF_BITMAP) = 0 Then
getclipBMP = 0
Else
Api_OpenClipboard 0
getclipBMP = Api_GetClipboardData(CF_BITMAP)
Api_CloseClipboard
End If
End Function
More than 5 years have passed since last update.
EXCELVBAセルに貼った画像をデスクトップ上で検索してマウスでクリックするRPAの根幹部分
Last updated at Posted at 2018-06-25
Register as a new user and use Qiita more conveniently
- You get articles that match your needs
- You can efficiently read back useful information
- You can use dark theme
3