Limit Cursor Movement inside a Userform

D

Dweeb458

Board Regular
Joined
Nov 15, 2005
Messages
52
Hello All,

I'm looking for code to limit the mouse cursor to only the boundries of a userform until the userform is closed. I have found some vb code for this as an API, but cannot seem to get the code to work.

I'm using Excel 2002, Windows XP, and the error I'm encountering is:
"Compile error, Method or Data member not found" on :GetClientRect Me.hWnd, client.

Here is the code I'm using:

Code: 
Option Explicit

Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
Private Type POINT
    x As Long
    y As Long
End Type

Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT)
Private Declare Sub ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINT)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long)

Private Sub CommandButton1_Click()
'Limits the Cursor movement to within the form.
    Dim client As RECT
    Dim upperleft As POINT
    
    'Get information about our window
    GetClientRect Me.hWnd, client
    upperleft.x = client.left
    upperleft.y = client.top
    
    'Make the bottom and right the same as the top/left
    client.bottom = client.top
    client.right = client.left
    
    'Convert window coordinates to screen coordinates
    ClientToScreen Me.hWnd, upperleft
    
    'offset our rectangle
    OffsetRect client, upperleft.x, upperleft.y
    
    'limit the cursor movement
    ClipCursor client
    
End Sub

Private Sub CommandButton2_Click()
 'Releases the cursor limits
    ClipCursor ByVal 0&
End Sub

Private Sub UserForm_Activate()
    CommandButton1.Caption = "Limit Cursor Movement"
    CommandButton2.Caption = "Release Limit"
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
 'Releases the cursor limits
    ClipCursor ByVal 0&
End Sub

Any help with this is much appreciated.

Thanks in advance. :-D
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
Hi,

the problem you are having is that userform window handles are not natively available in VBA. The userform handle is available in VB userforms though. We just need to add an API call to get the userform handle.

I modified your code in two ways:

1. I added the GetWindowA API function to your module and added code to get the userform handle

2. I commented out the following code because it was limiting mouse movement to a single point, not to the userform:

Code: 
    'Make the bottom and right the same as the top/left
'    client.bottom = client.top
'    client.right = client.left


There may still be a problem with the code in that you can't move the mouse to close the userform using the "x" button in the top right corner of the userform. I don't know if this is desirable or not for you.

Here is the modified code:

Code: 
Option Explicit

Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
Private Type POINT
    x As Long
    y As Long
End Type

Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT)
Private Declare Sub ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINT)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long)
'Added this declaration to get userform window handle
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long



Private Sub CommandButton1_Click()
'Limits the Cursor movement to within the form.
    Dim client As RECT
    Dim upperleft As POINT
    Dim hWnd As Long
    
    'Get Userform handle
    hWnd = FindWindow(vbNullString, Me.Caption)
    
    'Get information about our window
    GetClientRect hWnd, client
    upperleft.x = client.left
    upperleft.y = client.top
    
    'Make the bottom and right the same as the top/left
'    client.bottom = client.top
'    client.right = client.left
    
    'Convert window coordinates to screen coordinates
    ClientToScreen hWnd, upperleft
    
    'offset our rectangle
    OffsetRect client, upperleft.x, upperleft.y
    
    'limit the cursor movement
    ClipCursor client
    
End Sub

Private Sub CommandButton2_Click()
 'Releases the cursor limits
    ClipCursor ByVal 0&
End Sub

Private Sub UserForm_Activate()
    CommandButton1.Caption = "Limit Cursor Movement"
    CommandButton2.Caption = "Release Limit"
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
 'Releases the cursor limits
    ClipCursor ByVal 0&
End Sub
 
Upvote 0
Mark,

Thank you so much !!!

This is exactly what I was looking for. The close button is not a problem at all. I can't tell you how much time I've spent researching API's, and trying to understand why it was not working.

Your the best ! :-D
 
Upvote 0
You're welcome.

This is exactly what I was looking for. The close button is not a problem at all. I can't tell you how much time I've spent researching API's, and trying to understand why it was not working.
Click to expand...

Been there, done that, didn't like it, but I learned a lot.
 
Upvote 0
Hello I am new to the forum.

The code above work get for userform but can this be modified to work on msgbox pop up?

I have been doing Google search for days now and this is the only thing that is closest to what I need.

I am also very new to VBA.

Can someone let me know if this is even possible?

thank you.
 
Upvote 0
n07cn3 said:
Hello I am new to the forum.

The code above work get for userform but can this be modified to work on msgbox pop up?

I have been doing Google search for days now and this is the only thing that is closest to what I need.

I am also very new to VBA.

Can someone let me know if this is even possible?

thank you.
Click to expand...

Are you referring to a standard VB(A) MsgBox ? and if so, how many buttons will the MsgBox have on it ? ie : Just an OK button or a Yes/No buttons etc or what ?
And what is the reason you want to limit the cursor inside the Msgbox ? Maybe there is a less dramatic alternative solution to get you what you want.
 
Last edited:
Upvote 0
yes. it is the msgbox popup window in VBA. i need for it to work the same way on the userform.
the reason is, my work place use two monitors and everybody have a differnt set up. i need to msgbox to appear on the screen with the application that we are using (and at this point i have not figure out a way to set the msgbox to appear on the same screen as the application).
the reason i want this because i need the user to acknowlege the pop up message before clicking on the application that we are using. if users click on the application w/o clicking on the msgbox, then this could mess up the codes.
the msgbox just have yes and no buttons.

thanks in advance for your help.
 
Upvote 0
n07cn3 said:
the reason is, my work place use two monitors and everybody have a differnt set up. i need to msgbox to appear on the screen with the application that we are using (and at this point i have not figure out a way to set the msgbox to appear on the same screen as the application).
Click to expand...

I don't have experience working with multiple monitors but if the application you are using is EXCEL then the following code should force the MsgBox to be displayed on the monitor/screen where the excel application is displayed.

Place this code in a Standard Module :

Code: 
Option Explicit

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

Private Type MONITORINFOEX
    cbSize As Long
    rcMonitor As RECT
    rcWork As RECT
    dwFlags As Long
    szDevice As String * 32
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
Dim lHook As LongPtr

    Declare PtrSafe Function MonitorFromWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Declare PtrSafe Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoA" (ByVal hMonitor As LongPtr, lpmi As MONITORINFOEX) As Long
    Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Dim lHook As Long
    
    Declare Function MonitorFromWindow Lib "user32" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Declare Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, lpmi As MONITORINFOEX) As Long
    Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount 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 wFlags As Long) As Long
    Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Const MONITOR_DEFAULTTOPRIMARY = 1
Const MONITOR_DEFAULTTONEAREST = 2
Const WH_CBT = 5
Const HCBT_ACTIVATE = 5
Const SWP_NOSIZE = &H1
Const SWP_SHOWWINDOW = &H40


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Sub KeepWindowWithinApplicationMonitor(ByVal hwnd As LongPtr)
        Dim hMonitor As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Sub KeepWindowWithinApplicationMonitor(ByVal hwnd As Long)
        Dim hMonitor As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim tMi As MONITORINFOEX
    Dim tRect As RECT
    
    Call GetWindowRect(hwnd, tRect)
    tMi.cbSize = Len(tMi)
    hMonitor = MonitorFromWindow(Application.hwnd, MONITOR_DEFAULTTONEAREST)
    If hMonitor Then
        Call GetMonitorInfo(hMonitor, tMi)
        With tMi.rcWork
            Call SetWindowPos(hwnd, 0, (.Right - .Left) / 2 - (tRect.Right - tRect.Left) / 2, _
            (.Bottom - .Top) / 2 - (tRect.Bottom - tRect.Top) / 2, 0, 0, SWP_NOSIZE + SWP_SHOWWINDOW)
        End With
    End If
End Sub

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Function HookProc(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Function HookProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim ret As Long, sClassName As String
    If idHook Then
        Select Case idHook
            Case HCBT_ACTIVATE
                sClassName = Space$(256)
                ret = GetClassName(wParam, ByVal sClassName, 256)
                sClassName = Left$(sClassName, ret)
                If sClassName = "#32770" Then
                    UnhookWindowsHookEx lHook
                    Call KeepWindowWithinApplicationMonitor(wParam)
                End If
        End Select
    End If
    HookProc = CallNextHookEx(lHook, idHook, wParam, ByVal lParam)
End Function

Code test:
Code: 
Sub Test()
    lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
    MsgBox "This MsgBox is displayed in the excel application monitor"
    UnhookWindowsHookEx lHook
End Sub
 
Last edited:
Upvote 0
If you just want to limit the mouse cursor to only the boundries of the MsgBox then you could use this code :

Place the following in a Standard Module :
Code: 
Option Explicit

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

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Dim lHook As LongPtr

    Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function ClipCursor Lib "user32" (lpRect As Any) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Dim lHook As Long
    
    Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Const WH_CBT = 5
Const HCBT_ACTIVATE = 5

Property Let ClipCursorToMsgBox (ByVal vNewValue As Boolean)
    If vNewValue Then
        lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
    Else
        ClipCursor ByVal 0
        UnhookWindowsHookEx lHook
    End If
End Property

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Function HookProc(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Function HookProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim ret As Long, sClassName As String, tRect As RECT
    If idHook Then
        Select Case idHook
            Case HCBT_ACTIVATE
                sClassName = Space$(256)
                ret = GetClassName(wParam, ByVal sClassName, 256)
                sClassName = Left$(sClassName, ret)
                If sClassName = "#32770" Then
                    UnhookWindowsHookEx lHook
                    GetWindowRect wParam, tRect
                    ClipCursor tRect
                End If
        End Select
    End If
    HookProc = CallNextHookEx(lHook, idHook, wParam, ByVal lParam)
End Function


Test:
Code: 
Sub Test()
    ClipCursorToMsgBox = True
    MsgBox "The mouse cursor is restricted to this MsgBox."
    ClipCursorToMsgBox = False
End Sub
 
Upvote 0
Jaafar: Your code in post#9 works well until the title bar of the msgbox is clicked and the msgbox relocated.

Regards,

CJ
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
229
Jaafar Tribak
Jaafar Tribak
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
315
Minh Tuan VN
M
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
439
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
771
Jaafar Tribak
Jaafar Tribak
T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
617
tigger_na
T

Forum statistics

Threads
1,223,712
Messages
6,174,033
Members
452,542
Latest member
Bricklin

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top