Help us understand the problem. What is going on with this article?

EXCELVBAセルに貼った画像をデスクトップ上で検索してマウスでクリックするRPAの根幹部分

More than 1 year has passed since last update.
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


Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
No comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
ユーザーは見つかりませんでした