VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. Other
  3. controlToggleButton


ToggleButtonをなぞって一括設定

複数配置したToggleBoxをマウスの左ボタンを押した状態でなぞり、まとめてクリックしたいというお題。
最初コントロール配列化して、個々のToggleBoxのイベントを制御しようとトライしたが、どうもうまくいかないので、ToggleBoxをDisableにして、UserFormのイベントで取り扱う事を思いついた。

応用編でWorksheet上に透明UserFormを表示して、セルをなぞって着色もやってみました。（元の色と混ぜたいと思いましたが、「色」の世界は深く、ギブアップ状態です）
セルをなぞって着色（拙いお絵かきソフト？） 



UserForm_MouseDownなら、OnTimeのお世話にならなくてもいけるかもとトライしてみるとうまくいきました。
動作もストレスフリーになって、実用的になったようです。

☆標準モジュール
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetActiveWindow Lib "user32" () As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Public Type POINTAPI
X As Long
Y As Long
End Type

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

Public Const VK_LBUTTON = &H1 '[LeftClick]
Public Const VK_RBUTTON = &H2 '[RightClick]

Sub test()
  UserForm1.Show
End Sub

☆UserForm1モジュール
Dim hWnd As Long
Private myToggle() As MSForms.ToggleButton
Private myRect() As RECT
Private initialColor As Long
'UserFormのハンドル取得。 ScreenToClient APIで使用。
Private Sub UserForm_Activate()
  hWnd = GetActiveWindow()
End Sub

Private Sub UserForm_Initialize()
  Dim myControl As Control
  Dim scaleFactor As Single
  
  scaleFactor = 96 / 72
  '配列の添え字0の要素は使わない
  ReDim myToggle(0 To 0)
  ReDim myRect(0 To 0)
  For Each myControl In Me.Controls
    If TypeName(myControl) = "ToggleButton" Then
      myControl.Enabled = False
      myControl.Caption = ""
      ReDim Preserve myToggle(0 To UBound(myToggle) + 1)
      ReDim Preserve myRect(0 To UBound(myRect) + 1)
      Set myToggle(UBound(myToggle)) = myControl
      With myRect(UBound(myRect))
        .Left = CLng(myControl.Left * scaleFactor)
        .Top = CLng(myControl.Top * scaleFactor)
        .Right = CLng((myControl.Left + myControl.Width) * scaleFactor)
        .Bottom = CLng((myControl.Top + myControl.Height) * scaleFactor)
      End With
    End If
  Next
  initialColor = myToggle(1).BackColor
End Sub

'Private Sub UserForm_Click()だと、ボタンを離さないとEventが発生しないらしい
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim tempToggle As MSForms.ToggleButton
  Dim initialState As Boolean
  Dim toggleNo As Long, currentToggleNo As Long

  '最初のクリック箇所を保持
  If Button <> VK_LBUTTON Then Exit Sub
  currentToggleNo = getToggleNo()

  With myToggle(currentToggleNo)
    initialState = .Value
    .Value = Not (initialState)
    .BackColor = IIf(initialState, initialColor, vbBlue)
  End With
  '無限ループでマウスのモニタ
  Do
    DoEvents: DoEvents: DoEvents
    Sleep 10
    toggleNo = getToggleNo
    If toggleNo <> 0 Then
      Set tempToggle = myToggle(toggleNo)
      With tempToggle
        .Value = Not (initialState)
        .BackColor = IIf(initialState, initialColor, vbBlue)
      End With
      Set tempToggle = Nothing
    End If
  'マウスの左ボタンを離すまでループ
  Loop While GetAsyncKeyState(VK_LBUTTON)
End Sub

'マウスの存在する位置のトグルボックスのNoを取得。取得失敗は0を戻す。
Private Function getToggleNo() As Long
  Dim pos As POINTAPI
  Dim ret As Long
  Dim i As Long
  
  'Screen座標→Client座標に変換。RECT配列内の値はUserForm座標→Client座標に変換済み。
  GetCursorPos pos
  ret = ScreenToClient(hWnd, pos)
  For i = 1 To UBound(myRect)
    With myRect(i)
      If (pos.X >= .Left) And (pos.X <= .Right) And (pos.Y >= .Top) And (pos.Y <= .Bottom) Then
        getToggleNo = i
        Exit Function
      End If
    End With
  Next i
  getToggleNo = 0
End Function

======================================================
こちらは旧バージョンですが、UserFormからのOnTimeの使い方等の事例として残しておきます

☆　標準モジュール　toggleControlModule

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetActiveWindow Lib "user32" () As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Public Type POINTAPI
X As Long
Y As Long
End Type
'追加
Public Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Public Const VK_LBUTTON = &H1 '[LeftClick]
Public Const VK_RBUTTON = &H2 '[RightClick]

Private nextTriggerTime As Date

Sub test()
  UserForm1.Show
End Sub

'UserForm側でApplication.Ontimeが実行出来ないので仲立ちをする
Public Sub setOnTime()
  ’Webで見つけたが本当に1秒以下の指定が出来ているか不明
  nextTriggerTime = [now()+"00:00:00.10"]
  Application.OnTime nextTriggerTime, "onTimer"
End Sub

Public Sub onTimer()
  UserForm1.ontimesub
End Sub

☆　UserForm1モジュール
'UserForm1には任意個数のToggleBoxが置いてあるものとする
Dim hWnd As Long
Private myToggle() As MSForms.ToggleButton
Private myRect() As RECT
Private initialColor As Long

Private xframe As Single, yframe As Single
Private myStartToggle As Long

'ToggleBox動的配置バージョン　UserForm全体にToggleButtonを敷き詰めて操作する検証用バージョン
'Const BUTTONCOUNT As Long = 15
'Const COLUMNCOUNT As Long = 5
'Const SIDELENGTH As Long = 40

'UserFormのハンドル取得。 ScreenToClient APIで使用。
Private Sub UserForm_Activate()
  hWnd = GetActiveWindow()
End Sub

Private Sub UserForm_Initialize()
  Dim myControl As Control
  Dim scaleFactor As Single
  
  scaleFactor = 96 / 72
  '配列の添え字0の要素は使わない
  ReDim myToggle(0 To 0)
  ReDim myRect(0 To 0)
  For Each myControl In Me.Controls
    If TypeName(myControl) = "ToggleButton" Then
      myControl.Enabled = False
      myControl.Caption = ""
      ReDim Preserve myToggle(0 To UBound(myToggle) + 1)
      ReDim Preserve myRect(0 To UBound(myRect) + 1)
      Set myToggle(UBound(myToggle)) = myControl
      With myRect(UBound(myRect))
        .Left = CLng(myControl.Left * scaleFactor)
        .Top = CLng(myControl.Top * scaleFactor)
        .Right = CLng((myControl.Left + myControl.Width) * scaleFactor)
        .Bottom = CLng((myControl.Top + myControl.Height) * scaleFactor)
      End With
    End If
  Next
  initialColor = myToggle(1).BackColor
End Sub

'ToggleBox動的配置バージョン
'Private Sub UserForm_Initialize()
'  Dim i As Long
'
'  With Me
'    xframe = .Width - .InsideWidth
'    yframe = .Height - .InsideHeight
'  End With
'
'  ReDim myToggle(1 To BUTTONCOUNT)
'  For i = 1 To BUTTONCOUNT
'    Set myToggle(i) = Controls.Add("Forms.ToggleButton.1")
'    With myToggle(i)
'      'UserFormのイベントを用いるためにtoggleButtonはDisableにする。値の変更は可能。
'      .Enabled = False
'      .Width = SIDELENGTH
'      .Height = SIDELENGTH
'      .Left = SIDELENGTH * ((i - 1) Mod COLUMNCOUNT)
'      .Top = SIDELENGTH * ((i - 1) \ COLUMNCOUNT)
'    End With
'  Next i
'  With Me
'    .Width = xframe + SIDELENGTH * COLUMNCOUNT
'    .Height = yframe + SIDELENGTH * (BUTTONCOUNT \ COLUMNCOUNT)
'  End With
'End Sub


'Private Sub UserForm_Click()だと、ボタンを離さないとEventが発生しないらしい
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  '最初のクリック箇所を保持
  If Button <> VK_LBUTTON Then Exit Sub
  Me.startToggle = getToggleNo()
  'イベントを直ぐに抜けるために、次の処理はApplication.OnTimeで起動する
  'UserFormからは直には使えないので、標準モジュールに仲立ちをしてもらう
  toggleControlModule.setOnTime
End Sub

Public Sub ontimesub()
  Dim tempToggle As MSForms.ToggleButton
  Dim initialState As Boolean
  Dim toggleNo As Long
  
  With myToggle(Me.startToggle)
    initialState = .Value
    '状態変更の前にEnabled=True,変更後にEnabled=Falseにする必要があると考えたが無くてもOKだった
    .Value = Not (initialState)
    .BackColor = IIf(initialState, initialColor, vbBlue)
  End With
  '無限ループでマウスのモニタ
  Do
    DoEvents: DoEvents: DoEvents
    Sleep 10
    toggleNo = getToggleNo
    If toggleNo <> 0 Then
      Set tempToggle = myToggle(toggleNo)
      With tempToggle
        .Value = Not (initialState)
        .BackColor = IIf(initialState, initialColor, vbBlue)
      End With
      Set tempToggle = Nothing
    End If
  'マウスの左ボタンを離すまでループ
  Loop While GetAsyncKeyState(VK_LBUTTON)
End Sub

'マウスの存在する位置のトグルボックスのNoを取得。取得失敗は0を戻す。
Private Function getToggleNo() As Long
  Dim pos As POINTAPI
  Dim ret As Long
  Dim i As Long
  
  GetCursorPos pos
  ret = ScreenToClient(hWnd, pos)
  For i = 1 To UBound(myRect)
    With myRect(i)
      If (pos.X >= .Left) And (pos.X <= .Right) And (pos.Y >= .Top) And (pos.Y <= .Bottom) Then
        getToggleNo = i
        Exit Function
      End If
    End With
  Next i
  getToggleNo = 0
End Function

'ToggleBox動的配置バージョン
'Private Function getToggleNo() As Long
'  Dim pos As POINTAPI
'  Dim ret As Long
'  Dim toggleId As Long
'
'  GetCursorPos pos
'  ret = ScreenToClient(hWnd, pos)
'  With pos
'    'UserForm座標系の値に戻す
'    .X = .X * 72 / 96
'    .Y = .Y * 72 / 96
'    getToggleNo = (.X \ SIDELENGTH) + (.Y \ SIDELENGTH) * COLUMNCOUNT + 1
'  End With
'End Function

Public Property Let startToggle(toggleNo As Long)
  myStartToggle = toggleNo
End Property

Public Property Get startToggle() As Long
  startToggle = myStartToggle
End Property
ページのトップに戻る 

======================================================================================
'セルをなぞって色を着けます。別ページの色指定ダイアログで色を選択するのも組み込んでみました。

'標準モジュール
Public Type POINTAPI
X As Long
Y As Long
End Type

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

Declare Function FindWindow Lib "User32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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
'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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetActiveWindow Lib "user32" () As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Public Const VK_LBUTTON = &H1 '[LeftClick]
Public Const VK_RBUTTON = &H2 '[RightClick]

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

Public buttonName As String

'ワークシート上に置いた図形から起動。選択した色を図形に表示。
Sub showForm()
  buttonName = Application.Caller
  '非表示のUserForm2から色指定のクラスを呼んでダイアログを閉じる時にエラーが出るため安易にパス
  On Error Resume Next
  Load UserForm2
  UserForm1.Show
End Sub

'ワークシート上のクリックより得られたスクリーン座標をセル座標に変換する
Public Function screenToCellAddress(scrnPOINT As POINTAPI) As String
    Dim pointDifX As Single, pointDifY As Single
    Dim startX As Single, startY As Single
    Dim targetRange As Range
    Dim pointX As Single, pointY As Single
    Dim zoomX As Single, zoomY As Single
    Dim i As Long
  
    '左上隅セルの左上角との距離をポイントに変換
    Call realZoomRate(zoomX, zoomY)
    pointDifX = (scrnPOINT.X - ActiveWindow.PointsToScreenPixelsX(0)) * PPI / DPI / zoomX
    pointDifY = (scrnPOINT.Y - ActiveWindow.PointsToScreenPixelsY(0)) * PPI / DPI / zoomY
    startX = ActiveWindow.VisibleRange(1).Left
    startY = ActiveWindow.VisibleRange(1).Top
    Set targetRange = ActiveWindow.VisibleRange(1)
    For i = 1 To ActiveWindow.VisibleRange(1).Column
        pointX = pointX + targetRange.Width
    Next i
    For i = 1 To ActiveWindow.VisibleRange(1).Row
        pointY = pointY + targetRange.Height
    Next i
    Do Until pointX > pointDifX
        Set targetRange = targetRange.Offset(0, 1)
        pointX = pointX + targetRange.Width
    Loop
    Do Until pointY > pointDifY
        Set targetRange = targetRange.Offset(1, 0)
        pointY = pointY + targetRange.Height
    Loop
    screenToCellAddress = targetRange.Address
End Function

'真のズーム倍率を求める 'by kanabunさん
Public Sub realZoomRate(ByRef zoomX As Single, ByRef zoomY As Single)
  Dim c As Range
  Dim dotX As Long
  Dim dotY As Long
  Dim dotX1 As Long
  Dim dotY1 As Long
  
  Set c = Range("a1")
  With ActiveWindow
    ' ---------- 実際のZoom比の計算 ---------------
    dotY = c.Height * DPI / PPI
    dotY1 = dotY * .Zoom / 100
    zoomY = dotY1 / dotY '実際に適用されているZoom率
    dotX = c.Width * DPI / PPI
    dotX1 = dotX * .Zoom / 100
    zoomX = dotX1 / dotX
  End With
End Sub

'ユーザーフォームを二個使っているのですが、どちらも「見えない・表示されない」のです。
'☆UserForm1モジュール　不透明度1の見えないフォーム
Dim R1C1Left As Long
Dim R1C1Top As Long

Private Sub UserForm_Initialize()
  'フォームの不透明度 0にすると機能しなくなる。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

  R1C1Left = ActiveWindow.PointsToScreenPixelsX(0)
  R1C1Top = ActiveWindow.PointsToScreenPixelsY(0)
End Sub

Private Sub UserForm_Activate()
  Dim myLeft As Long, myTop As Long, myWidth As Long, myHeight As Long
  Dim zoomX As Single, zoomY As Single
  Dim rightBottomCell As Range
  Const myFontSize = 11
   
  'エクセルのActiveWindowのセルが表示されている範囲を覆うUserFormを表示
  'ほとんど透明なので視認できない
  realZoomRate zoomX, zoomY
  With Application.ActiveWindow.VisibleRange
    Set rightBottomCell = .Cells(.Rows.Count, .Columns.Count)
  End With
  myLeft = R1C1Left
  myTop = R1C1Top
  myWidth = zoomX * (rightBottomCell.Left + rightBottomCell.Width) * DPI / PPI
  myHeight = zoomY * (rightBottomCell.Top + rightBottomCell.Height) * DPI / PPI
  
  'フォームの表示順（Zオーダー）、サイズ指定
  SetWindowPos m_hwnd, HWND_TOP, myLeft, myTop, myWidth, myHeight, SWP_FRAMECHANGED

errHandle:
End Sub
 
 Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim pos As POINTAPI
  Dim currentCell As Range

  '左ボタンのみ対象
  If Button <> VK_LBUTTON Then Exit Sub
  '無限ループでマウスのモニタ
  Do
    DoEvents: DoEvents: DoEvents
    Sleep 10
    GetCursorPos pos
    'ドロップされた位置に該当するセルをActivate
    Set currentCell = ActiveSheet.Range(screenToCellAddress(pos))
    '元の色と混ぜたいなと思ってRGB、CMYK、加色混合、減色混合、補色等色々調べて試行錯誤しましたがちっともうまくいきません
    currentCell.Interior.color = Sheets(1).Shapes(buttonName).Fill.ForeColor.RGB
  'マウスの左ボタンを離すまでループ
  Loop While GetAsyncKeyState(VK_LBUTTON)
End Sub

'やめたくなったときは何かキーを押すと停止
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  Unload Me
End Sub

'☆UserForm2モジュール
'色設定ダイアログを呼ぶためだけの、表示しないフォーム（はっきり言って手抜き）
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hndw As Long) As Boolean

Dim myPalette As Class1
Dim ccHwnd As Long

Private Sub UserForm_Initialize()
  'Class1は別のページに載せてあるダイアログからの色選択クラス
    4-34 色指定のダイアログを表示して色を取得、カスタムカラー保存機能つき

  Set myPalette = New Class1
  Set myPalette.parent = Me
  Set myPalette.dataSheet = ThisWorkbook.Sheets(2)
  Sheets(1).Shapes(buttonName).Fill.ForeColor.RGB = myPalette.colorCode
  Unload Me
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Dim lngRet As Long
  
  'Dialogが消えないままUserFormを消した時の対策
  'Dialogが消える時まで,Class1のterminateが実行されない様である
  ccHwnd = FindWindow(vbNullString, "色の設定")
  If ccHwnd Then DestroyWindow (ccHwnd)
  Set myPalette = Nothing
End Sub