GDIplusCODE


'エクセル自身を含む、表示されているアプリケーション画面等のマウス指定画素の色情報を取得
'別アプリケーションの画面をExcel上で模擬しようと思い、得意の目的と手段の逆転で作成してみた。

'標準モジュール

'☆ Module1
'カーソルを変更しようとトライしたが、エクセル上のカーソルしか変更出来ず断念。

Type POINTAPI
    x As Long
    y As Long
End Type

Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long) As Long
Public Declare Sub DragAcceptFiles Lib "Shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
Public 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
Public Declare Sub DragFinish Lib "Shell32.dll" (ByVal hDrop As Long)
Public Declare Function DragQueryPoint Lib "Shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long
Public Declare Function ClientToScreen Lib "user32.dll" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
'Windowを半透明化する
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd&, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Public Declare Function GetPixel Lib "gdi32.dll" _
        (ByVal hdc As Long, ByVal nXPos As Long, ByVal nYPos As Long) As Long

Public Const LWA_COLORKEY = 1
Public Const LWA_ALPHA = 2              
Public Const SM_CXSCREEN As Long = 0
Public Const SM_CYSCREEN As Long = 1
Public Const GWL_STYLE = -16
Public Const GWL_EXSTYLE = -20
Public Const WS_CAPTION = &HC00000 'タイトルバーを持つウィンドウ
Public Const WS_SYSMENU = &H80000  'タイトルバー上にウィンドウメニューボックスを持つウィンドウ
Public Const WS_MINIMIZEBOX = &H20000 '最小化ボタンを持つウィンドウ
Public Const WS_MAXIMIZEBOX = &H10000  '最大化ボタンを持つウィンドウ
Public Const WS_EX_DLGMODALFRAME = &H1&    '二重の境界線を持つウィンドウ
Public Const HWND_TOPMOST = -1&   '常に手前に表示
Public Const HWND_TOP = 0         '手前に表示
Public Const SWP_FRAMECHANGED = &H20
Public Const WM_DROPFILES = &H233
Public Const GWL_WNDPROC = -4
Public Const WS_EX_TOOLWINDOW = &H80
Public Const WS_EX_LAYERED = &H80000
Public Const WM_KEYDOWN = &H100

'スクリーン座標とエクセルワークシート座標の変換
'出典：http://home.att.ne.jp/zeta/gen/excel/c04p06.htm
Public Const DPI As Long = 96
Public Const PPI As Long = 72

Public IsHooked      As Boolean
Public lpPrevWndProc As Long
Public m_hwnd         As Long

'******** 視認不能なUserformを表示し、ディスプレイ全体を覆い、クリックしたピクセルの色を取得 *******
Sub Main()
  Application.StatusBar = "カーソル位置の色を取得します。任意のキー押下で復帰します。"
  UserForm1.Show
  Application.StatusBar = False
End Sub


'☆ dualMonitorModule
'海外のサイトを参考にしましたが、既にリンク切れなので、出典は明示いたしません。
'In a module
Public Const MONITORINFOF_PRIMARY = &H1
Public Const MONITOR_DEFAULTTONEAREST = &H2
Public Const MONITOR_DEFAULTTONULL = &H0
Public Const MONITOR_DEFAULTTOPRIMARY = &H1

Public Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Public Type monitorInfo
  cbSize As Long
  rcMonitor As RECT
  rcWork As RECT
  dwFlags As Long
End Type

'Module1で宣言
'Public Type POINT
'  x As Long
'  y As Long
'End Type

Public Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, _
  ByRef lpmi As monitorInfo) As Long
Public Declare Function MonitorFromPoint Lib "user32.dll" (ByVal x As Long, ByVal y As Long, ByVal dwFlags _
  As Long) As Long
Public Declare Function MonitorFromRect Lib "user32.dll" (ByRef lprc As RECT, ByVal dwFlags As Long) As Long
Public Declare Function MonitorFromWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal dwFlags As Long) As Long
Public Declare Function EnumDisplayMonitors Lib "user32.dll" (ByVal hdc As Long, ByRef lprcClip As Any, _
  ByVal lpfnEnum As Long, ByVal dwData As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Dim MIs() As monitorInfo
Dim i As Long
 
'Dual Monitorの幅合計と、大きい方の高さを求める
Public Function getMaximumSize() As RECT
  Dim i As Long
  Dim firstMonitor As monitorInfo, secondMonitor As monitorInfo
  Dim flag1 As Boolean, flag2 As Boolean
  Dim totalWidth As Long, commonHeight As Long
  
  i = 0
  ReDim MIs(1 To 1)
    
  'Monitorを列挙するコールバック関数を呼ぶ、結果は配列MIsに戻る
  EnumDisplayMonitors ByVal 0&, ByVal 0&, AddressOf MonitorEnumProc2, ByVal 0&
  
  '配列に取得した列挙結果に対して処理
  For i = LBound(MIs) To UBound(MIs)
    With MIs(i).rcMonitor
      If MIs(i).cbSize > 0 Then

        If CBool(MIs(i).dwFlags) Then
          firstMonitor = MIs(i)
          flag1 = True
        Else
          secondMonitor = MIs(i)
          flag2 = True
        End If
      End If
    End With
    If flag1 And flag2 Then Exit For
  Next i
  
  With getMaximumSize
    .Left = 0
    .Top = 0
    .Right = firstMonitor.rcMonitor.Right - firstMonitor.rcMonitor.Left + secondMonitor.rcMonitor.Right - secondMonitor.rcMonitor.Left
    If firstMonitor.rcMonitor.Bottom - firstMonitor.rcMonitor.Top >= secondMonitor.rcMonitor.Bottom - secondMonitor.rcMonitor.Top Then
      .Bottom = firstMonitor.rcMonitor.Bottom - firstMonitor.rcMonitor.Top
    Else
      .Bottom = secondMonitor.rcMonitor.Bottom - secondMonitor.rcMonitor.Top
    End If
  End With

End Function

'CallBack関数なのでディスプレイの数だけ実行される
Private Function MonitorEnumProc2(ByVal hMonitor As Long, ByVal hdcMonitor As Long, lprcMonitor As RECT, _
  ByVal dwData As Long) As Long
  
  Dim MI As monitorInfo, R As RECT

  'initialize the MONITORINFO structure
  MI.cbSize = Len(MI)
  'Get the monitor information of the specified monitor
  GetMonitorInfo hMonitor, MI
  '実行されるのは2回だけなのに、iが40迄とか加算される？
  'このプロシージャ内で.cbSizeで分岐してもうまく行かない（OKの時もあり）
    i = i + 1
    ReDim Preserve MIs(1 To i)
  'Continue enumeration,Put the result to Array
  MIs(i) = MI
  
  MonitorEnumProc2 = 1
End Function

'☆ UserForm1 Module、コントロールは何も置かない
'Thisworkbook
Dim wbk As Workbook

Private Sub UserForm_Initialize()
  'フォームの不透明度1ならほとんど判別できないが機能する。
  Const opacityRatio As Long = 1

  With Me
    .StartUpPosition = 0
    .BorderStyle = fmBorderStyleNone
    .SpecialEffect = fmSpecialEffectFlat
    'フォームに時刻を名前としてつける
    .Caption = .Caption & Timer()
  End With
  '名前を手がかりとして、ユーザーフォームのハンドルを取得
  m_hwnd = FindWindow("ThunderDFrame", Me.Caption)
  ' フォームのメニュー、最大最小化ボタン等は一切表示しない設定とする
  SetWindowLong m_hwnd, GWL_STYLE, _
              GetWindowLong(m_hwnd, GWL_STYLE) And _
                       Not (WS_SYSMENU Or WS_CAPTION Or _
                            WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
  SetWindowLong m_hwnd, GWL_EXSTYLE, _
              GetWindowLong(m_hwnd, GWL_EXSTYLE) And _
              Not WS_EX_DLGMODALFRAME
  SetWindowLong m_hwnd&, GWL_EXSTYLE, _
            GetWindowLong(m_hwnd&, GWL_EXSTYLE) Or WS_EX_LAYERED
  SetLayeredWindowAttributes m_hwnd&, 0, opacityRatio, LWA_ALPHA
  
  Set wbk = ThisWorkbook
              
End Sub

Private Sub UserForm_Activate()
  Dim myLeft As Long, myTop As Long, myWidth As Long, myHeight As Long
  Dim rightBottomCell As Range
  Dim retRECT As RECT
  
  Const myFontSize = 11
   
  '指定範囲を覆うUserFormを表示
  'ほとんど透明なので視認できない
  With Application.ActiveWindow.VisibleRange
    Set rightBottomCell = .Cells(.Rows.Count, .Columns.Count)
  End With

  'Dual Monitorも全体を覆う
  retRECT = getMaximumSize
 
  With retRECT
    myLeft = 0
    myTop = 0
    myWidth = .Right
    myHeight = .Bottom
  End With
  'フォームの表示順（Zオーダー）、サイズ指定
  SetWindowPos m_hwnd, HWND_TOP, myLeft, myTop, myWidth, myHeight, SWP_FRAMECHANGED
'  Hook
errHandle:
End Sub
 
'やめたくなったときは何かキーを押すと停止
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  Unload Me
End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
  Dim hdc As Long, Color As Long
  Dim pt As POINTAPI
  Dim R As Byte, G As Byte, B As Byte
  
  Dim myCell As Range
  
  Call GetCursorPos(pt)
  hdc = GetDC(0)
  Color = GetPixel(hdc, pt.x, pt.y)
  Call ReleaseDC(0, hdc)

  R = Color And &HFF
  G = Color \ &H100 And &HFF
  B = Color \ &H10000 And &HFF
 
  'シートに着色文字と塗りつぶしセルを作成、RGBをセルに書き出す
  With wbk.Worksheets(1)
    Set myCell = .Range("A" & .Rows.Count).End(xlUp)
    If myCell.Value <> "" Then Set myCell = myCell.Offset(1, 0)
    myCell.Value = "色"
    myCell.Font.Color = Color
    myCell.Offset(0, 1).Interior.Color = Color
    myCell.Offset(0, 2).Value = R & ", " & G & ", " & B
  End With
  
End Sub
画面の指定画素の色取得
