ダウンロード (10KB)

マウスカーソル下にある色を取得しましょう。同機能を提供するフリーソフトにPixieがある。見た目が簡素で可愛らしく時々お世話になっているのであるが、ただ１点ソースが有料であることが気になっていた。「何で有料？そんなに高度なことやってるの？」と。

見た感じ、

(1)マウスポインタの位置を取得
(2)デスクトップを丸ごとデバイスコンテキストにコピー
(3)GetPixel で色を取得

としているだけっぽいんだけど…。後は補助機能としてホットキーでRGB文字列をコピー可能にしているだけだよねぇ。
ということで、それを検証すべく自ら実装してみた。結論としては「超余裕」であった。

留意すべきことは「マウスがフォームの外に移動してもその位置を把握し続けること」である。フォームの MouseMove イベントは、フォーム内のマウス移動をハンドリングするものなので今回は使用できず。となったら API の登場である。SetWindowsHookEx でマウスの挙動をフックして、移動イベントをハンドリングすればよい。

主たるロジックは以下の通りで、非常に簡単である。
なお GetColors関数にてマウスカーソル位置がマイナス値だったりすると -1 が返る。この点は注意である。

'メモリコピー
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDest As Any, ByRef pSource As Any, ByVal ByteLen As Long)

Private Type POINTAPI
    x As Long
    y As Long
End Type

'フックプロシージャをインストールする

'フックプロシージャをアンインストールする
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

'次のフックプロシージャをコールする
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

'マウスフック用構造体
Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type

Private Const HCBT_ACTION = 0
Private Const WH_MOUSE = 7
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEMOVE = &H200

'指定位置の色を取得する
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

'デスクトップのウインドウハンドルを取得する
Private Declare Function GetDesktopWindow Lib "user32" () As Long

'デバイスコンテキストを取得する
'Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

'デバイスコンテキストを開放する
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

'フック関数のハンドル
Private hMouseHook As Long

'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
' 機  能：フック関数のハンドルを取得する
' 引  数：なし
' 返り値：フック関数のハンドル
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Public Property Get GetHookHandle() As Long
   GetHookHandle = hMouseHook
End Property

'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
' 機  能：マウスフックを開始する
' 引  数：なし
' 返り値：なし
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Public Sub StartMouseMoveHook()
   'WH_MOUSE を指定して第４引数に自分のスレッドIDを指定するとフォーム内のマウス位置を取得できる
   'hMouseHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseHookProc, App.hInstance, App.ThreadID)

   'WH_MOUSE_LL を指定して第４引数を 0 にするとフォーム外のマウス位置を取得できる
   hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseHookProc, App.hInstance, 0&)
End Sub

'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
' 機  能：マウスフックを終了する
' 引  数：なし
' 返り値：なし
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Public Sub HenMouseMoveHook()
    Call UnhookWindowsHookEx(hMouseHook)
End Sub

'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
' 機  能：マウスをフックする
' 引  数：なし
' 返り値：なし
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Function MouseHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim udtMhs As MOUSEHOOKSTRUCT
    If (nCode = HCBT_ACTION And wParam = WM_MOUSEMOVE) Then
        'アドレスより構造体取得
        Call CopyMemory(udtMhs, ByVal lParam, Len(udtMhs))

        'デバッグ - マウスカーソルの位置を表示
        'Debug.Print udtMhs.pt.x & " x " & udtMhs.pt.y
        Dim RGBValue As Long

        '色を取得
        RGBValue = GetColors(udtMhs.pt.x, udtMhs.pt.y)

        '描画(フォームのPublicメソッドを呼ぶ)
        Call frmMain.DrawMouseInfo(udtMhs.pt.x, udtMhs.pt.y, RGBValue)
    End If

    'フックを続ける
    MouseHookProc = CallNextHookEx(hMouseHook, nCode, wParam, lParam)
End Function

'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
' 機  能：指定位置の色を取得する
' 引  数：(i)xPos … Ｘ座標
'         (i)yPos … Ｙ座標
' 返り値：指定位置の色
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Function GetColors(ByVal xPos As Long, ByVal yPos As Long) As Long
    Dim hWndDesktop As Long 'デスクトップのウィンドウハンドル
    Dim hDCdesktop As Long  'デスクトップのデバイスコンテキストのハンドル

    'デスクトップのウインドウハンドルを取得する
    hWndDesktop = GetDesktopWindow()

    'デスクトップのデバイスコンテキストを取得する
    'hDCdesktop = GetDC(hWndDesktop)      '←何故か動作せず(XPだから？)
    hDCdesktop = GetWindowDC(hWndDesktop) '←こっちで動いたよっと

    '色を取得
    GetColors = GetPixel(hDCdesktop, xPos, yPos)

    'デスクトップのデバイスコンテキストを開放する
    Call ReleaseDC(0, hDCdesktop)
End Function