I was thinking about implementing a “What’s This?” type help system on an Excel userform. The first task, it seems, is changing the cursor. In Changing the Cursor in VBA, I discussed the built-in way to modify the cursor. The options there are pretty limited and they particularly don’t include a question mark that I might like to use for this application.
AllAPI.net had an example from Jerry Grant that seemed to fill the bill. It uses several API’s of which I understand most. I modified the example a little to suit the situation. Here is the declaration section of a standard module:
Public Declare Function CopyIcon Lib “user32” _
(ByVal hIcon As Long) As Long
Public Declare Function LoadCursorFromFile Lib “user32” Alias “LoadCursorFromFileA” _
(ByVal lpFileName As String) As Long
Public Declare Function SetCursor Lib “user32” _
(ByVal hCursor As Long) As Long
Public Declare Function SetSystemCursor Lib “user32” _
(ByVal hcur As Long, ByVal id As Long) As Long
Public Declare Function GetCursor Lib “user32” () As Long
Public Const lOCR_NORMAL As Long = 32512
And here is the code behind the userform that changes the cursor.
Private mlCurrCursor As Long
Private mlDefCursor As Long
Private Sub cmdWhat_Click()
If mbWhatActive Then
ChangeCursor
mbWhatActive = False
Else
ChangeCursor “C:Windowscursorshelp_r.cur”
mbWhatActive = True
End If
End Sub
Private Sub ChangeCursor(Optional sCursPath As String)
Dim lCursor As Long
If Len(sCursPath) = 0 Then
lCursor = mlDefCursor
Else
mlCurrCursor = GetCursor()
mlDefCursor = CopyIcon(mlCurrCursor)
lCursor = LoadCursorFromFile(sCursPath)
End If
SetSystemCursor lCursor, lOCR_NORMAL
End Sub
I was messing around with cursors, and I think I like this one the best:
Hi Dick,
No need to resort to the API for the arrow+question mark cursor.
Try the following code in a userform with a button.
Private Sub CommandButton1_Click()
‘ arrow + questionmark
Me.MousePointer = fmMousePointerHelp
End Sub
Private Sub UserForm_Click()
Me.MousePointer = fmMousePointerDefault
End Sub
Also this may help.
http://www.andypope.info/vba/whatsthishelp.htm
Dick,
its very useful to change the m-icon. However when I close the UserForm when the hlp icon is active and restart restart the form the hlp icon won’t change back to default.
The solution was a little script addition:
Private Sub cmdWhat_Click()
If mbWhatActive Then
ChangeCursor “C:WINNTcursorsarrow_m.cur”
mbWhatActive = False
Else
ChangeCursor “C:WINNTcursorshelp_r.cur”
mbWhatActive = True
End If
End Sub
Private Sub ChangeCursor(Optional sCursPath As String)
Dim lCursor As Long
If sCursPath “C:WINNTcursorshelp_r.cur” Then
mlCurrCursor = GetCursor()
mlDefCursor = CopyIcon(mlCurrCursor)
lCursor = LoadCursorFromFile(sCursPath)
Else
mlCurrCursor = GetCursor()
mlDefCursor = CopyIcon(mlCurrCursor)
lCursor = LoadCursorFromFile(sCursPath)
End If
SetSystemCursor lCursor, lOCR_NORMAL
End Sub
Cheers
Lars
Also this may help.
http://www.andypope.info/vba/whatsthishelp.htm
That look like just what I wanted to do. Thanks, Andy.
Lars: The problem with that is if the user has changed their default cursor, then you’d be changing it back to your default cursor. Once fully developed, the user wouldn’t be able to close the userform because all the close mechanism would have help associated with them. However, a call to ChangeCursor (with no arguments) from the QueryClose event does the trick too.
True if fully developed. Thanks anyway
Lars
Apologies if I am incorrect to post here.
I am seeking to replace the ‘busy’ hourglass icon on the worksheet and thought by modifying the suggestions above it might do the trick. Not. In DeployCursor there are 2 options for testing. One, a msgbox, meant to represent some work. This shows the icon correctly until the msgbox is acknowledged and the cursor reverts. The other is real work but then the icon replace does NOT work. Clearly there is some other stuff going on here – but what?
All code goes into a standard module:
Public Declare Function CopyIcon Lib “user32” _
(ByVal hIcon As Long) As Long
Public Declare Function LoadCursorFromFile Lib “user32” Alias “LoadCursorFromFileA” _
(ByVal lpFileName As String) As Long
Public Declare Function SetCursor Lib “user32” _
(ByVal hCursor As Long) As Long
Public Declare Function SetSystemCursor Lib “user32” _
(ByVal hcur As Long, ByVal id As Long) As Long
Public Declare Function GetCursor Lib “user32” () As Long
Public Const lOCR_NORMAL As Long = 32512
Private mbWhatActive As Boolean
Private mlCurrCursor As Long
Private mlDefCursor As Long
Dim sCursPath As String
Private Sub ToggleCursor()
If mbWhatActive Then
ChangeCursor “C:Windowscursorsarrow_m.cur”
mbWhatActive = False
Else
ChangeCursor Application.Path & “MSN.ico”
mbWhatActive = True
End If
End Sub
Private Sub ChangeCursor(Optional sCursPath As String)
Dim lCursor As Long
If sCursPath = Application.Path & “MSN.ico” Then
mlCurrCursor = GetCursor()
mlDefCursor = CopyIcon(mlCurrCursor)
lCursor = LoadCursorFromFile(sCursPath)
Else
mlCurrCursor = GetCursor()
mlDefCursor = CopyIcon(mlCurrCursor)
lCursor = LoadCursorFromFile(sCursPath)
End If
SetSystemCursor lCursor, lOCR_NORMAL
End Sub
Sub DeployCursor()
Dim x As Long, y As Long
ToggleCursor
MsgBox “”
” For x = 1 To 1000
” For y = 1 To 10000
” Next y
” Next x
ToggleCursor
End Sub
Example for a Textbox in a Userform
This example vill force the cursor to be a hand when you rihgtclick on the Textbox. The cursor vill not change even if any other code will run while rightclick witch normay would set the cursor to a houerglass.
****************************************
Private Declare Function LoadCursorFromFile Lib “user32? Alias “LoadCursorFromFileA” (ByVal lpFileName As String) As Long
Private Declare Function CopyIcon Lib “user32? (ByVal hIcon As Long) As Long
Private Declare Function SetSystemCursor Lib “user32? (ByVal hcur As Long, ByVal id As Long) As Long
Private Declare Function GetCursor Lib “user32? () As Long
Private mbWhatActive As Boolean
Private mlCurrCursor As Long
Private mlDefCursor As Long
Private Const lOCR_NORMAL As Long = 32512
Private Sub TextBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
Custor_locked True
‘Any code
End If
End Sub
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
Custor_locked False
End If
End Sub
Private Sub Custor_locked(Locked As Boolean)
Dim lCursor As Long
If Locked And mlDefCursor = 0 Then
Application.Cursor = xlNorthwestArrow
mlCurrCursor = GetCursor()
mlDefCursor = CopyIcon(mlCurrCursor)
lCursor = LoadCursorFromFile(“C:Windowscursorshns.cur”)
SetSystemCursor lCursor, lOCR_NORMAL
ElseIf Not Locked And Not mlDefCursor = 0 Then
Application.Cursor = xlDefault
lCursor = mlDefCursor
mlDefCursor = 0
SetSystemCursor lCursor, lOCR_NORMAL
End If
End Sub