HOME > エクセルVBA > サンプル > ClipCursor

ClipCursor


【ファイル名】ClipCursor.xlsm
【バージョン】Ver 1.0.0.1
【作成日】2021年05月18日
【更新日】2021年06月13日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】ClipCursor.zip
【説明】Windows APIのClipCursor関数で、マウスのカーソルの移動範囲を制限します。
メニュー

【外部リンク】Windows > Apps > Win32 > API > Display Devices Reference > Windef.h >  RECT structure
【外部リンク】Windows > Apps > Win32 > API > Menus and Other Resources> Winuser.h >  ClipCursorGetClipCursor
【外部リンク】Windows > Apps > Win32 > API > Windows GDI > Winuser.h >  GetDCReleaseDC
【外部リンク】Windows > Apps > Win32 > API > Windows GDI > Wingdi.h >  GetDeviceCaps
【外部リンク】Windows > Apps > Win32 > API > Windows Accessibility Features > Oleacc.h > WindowFromAccessibleObject

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="マウスのカーソルの移動範囲を">
          <button id="ShowFormButton" label="フォームを表示(&amp;S)" size="large" imageMso="HappyFace"
                  supertip="フォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

UserForm1
Option Explicit

' https://docs.microsoft.com/en-us/windows/win32/api/windef/ns-windef-rect
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

#If Win64 Then
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-clipcursor
  Private Declare PtrSafe Function ClipCursor Lib "user32" (lpRect As RECT) As Long
  Private Declare PtrSafe Function ResetClipCursor Lib "user32" Alias "ClipCursor" (ByVal lpRect As LongPtr) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-getclipcursor
  Private Declare PtrSafe Function GetClipCursor Lib "user32" (lprc As RECT) As Long

  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getdc
  Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
  
  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-releasedc
  Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long

  ' https://docs.microsoft.com/en-us/windows/win32/api/wingdi/nf-wingdi-getdevicecaps
  Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/desktop/api/oleacc/nf-oleacc-windowfromaccessibleobject
  Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As LongPtr) As Long

#Else
  Private Declare Function ClipCursor Lib "user32" (lpRect As RECT) As Long
  Private Declare Function ResetClipCursor Lib "user32" Alias "ClipCursor" (ByVal lpRect As Long) As Long
  Private Declare Function GetClipCursor Lib "user32" (lprc As RECT) As Long
  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 GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
  Private Declare Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As Long) As Long
#End If

#If Win64 Then
  Private myHwnd As LongPtr
#Else
  Private myHwnd As Long
#End If

Private Property Get hWnd()
  WindowFromAccessibleObject Me, myHwnd ' フォームのハンドルを取得する
  hWnd = myHwnd
End Property

' マウスの移動範囲をこのフォームに制限する
' フォームを移動すると、制限が解除される
Private Sub SetButton_Click()
  Const LOGPIXELSX = 88 ' Logical pixels/inch in X
  Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
  
  Dim XPixelsPerInch As Long
  Dim YPixelsPerInch As Long
  Dim lpRect As RECT
#If Win64 Then
  Dim hDC As LongPtr
#Else
  Dim hDC As Long
#End If

  hDC = GetDC(hWnd)
  XPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
  YPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
  ReleaseDC hWnd, hDC
  
  lpRect.Left = Me.Left * XPixelsPerInch / 72 ' Screenの座標(ピクセル)に変換する
  lpRect.Top = Me.Top * YPixelsPerInch / 72
  lpRect.Right = (Me.Left + Me.Width) * XPixelsPerInch / 72
  lpRect.Bottom = (Me.Top + Me.Height) * YPixelsPerInch / 72
  
  If ClipCursor(lpRect) = 0 Then
    MsgBox Prompt:="マウスの移動範囲を制限できません。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
  Else
    SetButton.Enabled = False
    ResetButton.Enabled = True
  End If
End Sub

' マウスの移動範囲の制限を解除する
Private Sub ResetButton_Click()
  
  If ResetClipCursor(0) = 0 Then
    MsgBox Prompt:="マウスの移動範囲の制限を解除できません。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
  Else
    SetButton.Enabled = True
    ResetButton.Enabled = False
  End If
End Sub

' マウスの移動範囲を取得する
Private Sub GetButton_Click()
  Dim lprc As RECT
  Dim Msg As String
  
  GetClipCursor lprc
  Msg = "マウスの移動範囲" & vbCrLf & vbCrLf
  Msg = Msg & "Left: " & lprc.Left & vbCrLf
  Msg = Msg & "Top: " & lprc.Top & vbCrLf
  Msg = Msg & "Right: " & lprc.Right & vbCrLf
  Msg = Msg & "Bottom: " & lprc.Bottom & vbCrLf
  MsgBox Prompt:=Msg, Buttons:=vbInformation, Title:="情報"
End Sub
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "ShowFormButton"
      UserForm1.Show vbModal
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub
このページの上