つらつら Excel VBA

私の備忘録です。

VBAでGetPixel

ディスプレイ上のどこでも色情報を取得できるAPIのGetPixel。100x100ピクセルくらいの範囲でも激重なので注意!
読み取り範囲と基準座標はポイントとピクセルとインチとdpiの計算が必要でハードルが高いと思います。
色情報を取得できたら、シートのセルの背景色に設定して遊んだりしましょう。

Option Base 0

'デバイスコンテキストのハンドルを取得、開放するAPIと指定座標の色を取得するAPI
'64ビット用
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As Long

'32ビット用
'Private Declare Function GetDC 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 Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long

Sub GetPictureColor()
    
    '配列領域確保
    ReDim 二次元配列(読み取りたい範囲縦 - 1, 読み取りたい範囲横 - 1)
    
'    Dim hDC As Long   'デバイスコンテキスト(32ビット用)
    Dim hDC As LongPtr 'デバイスコンテキスト(64ビット用)
    hDC = GetDC(0)     'デバイスコンテキスト取得
    
    '座標の色を取得する処理
    Dim iX      As Long
    Dim iY      As Long
    Dim iColor  As Long '色を格納
    
    For iX = LBound(二次元配列, 1) To UBound(二次元配列, 1)
        
        For iY = LBound(二次元配列, 2) To UBound(二次元配列, 2)
            
            iColor = GetPixel(hDC, 基準座標X + iX, 基準座標Y + iY)
            二次元配列(iX, iY) = iColor
            'Thisworkbook.Worksheet("書出").Cells(iY + 1, iX + 1).Interior.Color = iColor
            
        Next
        
        DoEvents 'ハングアップ対策
        
        '進行状況確認用
        If iX Mod 10 = 0 And iX > 0 Then Debug.Print iX & "..."
        
    Next
    
    Call ReleaseDC(0, hDC) 'デバイスコンテキストの解放
    
End Sub

以上。