Function that executes one of four tasks depending on arguments passed 1

[patriciaxxx]

I have written the following cursor function, which works as commented.

I am only a vba beginner and did this by looking at other functions anfd tring to work out how to do it properly.

My question is can some one with experience who knows the correct way to write functions tell me if my code is how they would expect it to be, or post an example the way it should be written.

This will help me a great deal in learning the right way to code things.

Option Compare Database
Option Explicit
'Access allows us to display specific mouse pointers by controlling the MousePointer
'property of the Application object. However, it does not have the hand pointer (for
'example) pre-defined.
'Given a local ICO (icon) file, we can assign it to the Mouse pointer by using the
'LoadCursor and SetCursor API functions.

'Declare Windows API Constants for Windows System cursors.
Public Enum SystemCursorID
IDC_APPSTARTING = 32650& 'Standard arrow and small hourglass.
IDC_ARROW = 32512& 'Standard arrow.
IDC_CROSS = 32515 'Crosshair.
IDC_HAND = 32649 'Hand.
IDC_HELP = 32651 'Arrow and question mark.
IDC_IBEAM = 32513& 'Text I-beam.
IDC_ICON = 32641& 'Windows NT only: Empty icon.
IDC_NO = 32648& 'Slashed circle.
IDC_SIZE = 32640& 'Windows NT only: Four-pointed arrow.
IDC_SIZEALL = 32646& 'Four-pointed arrow pointing north, south, east, and west.
IDC_SIZENESW = 32643& 'Double-pointed arrow pointing northeast and southwest.
IDC_SIZENS = 32645& 'Double-pointed arrow pointing north and south.
IDC_SIZENWSE = 32642& 'Double-pointed arrow pointing northwest and southeast.
IDC_SIZEWE = 32644& 'Double-pointed arrow pointing west and east.
IDC_UPARROW = 32516& 'Vertical arrow.
IDC_WAIT = 32514& 'Hourglass.
End Enum

'Declarations for API Functions.
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'Declare handles for cursor.
Private Const GCL_HCURSOR = (-12)
Private hOldCursor As Long
Private hNewCursor As Long

'Change cursor to a hand.
'Browser default cursor.
Public Function UseHand()
modCursor.UseCursor IDC_HAND
End Function

'When you unload the cursor use hwnd
Public Function UnloadCursor(ByVal CurrentWindow As Long)
'Unload cursor.
hOldCursor = modCursor.SetClassLong(CurrentWindow, GCL_HCURSOR, hOldCursor)
End Function

'The UseCursor function will load and set a system cursor or a cursor from file to either a
'controls event property or to a forms event property.

'For controls set the argument Controls to True (default value).
'The argument CursorID is not optional.
'For system cursors select value from list.
'For cursors from file set the argument CursorPath to full path and enter 0 as the value for
'CursorID

'For forms set the argument Controls to False
'For correct use the forms Pop Up and Modal properties should be set to Yes
'Use's the hWnd property to determine the handle (a unique Long Integer value) assigned
'by Microsoft Windows to the current window.
'When you load the cursor use Me.hwnd
'When you unload the cursor use hwnd
Public Function UseCursor(CursorID As SystemCursorID, _
Optional CursorPath As String = "", _
Optional ByVal CurrentWindow As Long = 0, _
Optional Controls As Boolean = True)

'The arglist argument has too many values.
If CursorID > 0 And CursorPath <> "" Then
MsgBox "Can't assign both values." & vbCrLf & vbCrLf _
& "CursorID: " & CLng(CursorID) & vbCrLf _
& "CursorPath: " & CursorPath & vbCrLf, vbOKOnly, "UseCursor"
Exit Function
End If

'System cursor.
If Controls And CursorID > 0 Then
'Load new cursor and, if successful, set.
hNewCursor = LoadCursor(ByVal 0&, CLng(CursorID))
If (hNewCursor > 0) Then
hNewCursor = SetCursor(hNewCursor)
End If
End If

'Custom cursor from file.
'Custom animated cursor from file.
If Controls And CursorPath <> "" Then
'Load new cursor and, if successful, set.
hNewCursor = LoadCursorFromFile(CursorPath)
If (hNewCursor > 0) Then
hNewCursor = SetCursor(hNewCursor)
End If
End If

'System cursor.
If Controls = False And CursorID > 0 Then
'Load new cursor and, if successful, set.
hNewCursor = LoadCursor(ByVal 0&, CLng(CursorID))
If (hNewCursor > 0) Then
hOldCursor = SetClassLong(CurrentWindow, GCL_HCURSOR, hNewCursor)
End If
End If

'Custom cursor from file.
'Custom animated cursor from file.
If Controls = False And CursorPath <> "" Then
'Load new cursor and, if successful, set.
hNewCursor = LoadCursorFromFile(CursorPath)
If (hNewCursor > 0) Then
hOldCursor = SetClassLong(CurrentWindow, GCL_HCURSOR, hNewCursor)
End If
End If

End Function

 

[strongm]

Given I can't foresee a situation where you'd regularly be needing to mess about with the cursor associated with a window's class, I suspect I'd be tempted to reduce the cursor setting function to:

[blue]Public Function UseCursor(ByVal NewCursor As Variant)

    Select Case TypeName(CursorID)
        Case "String"
            hNewCursor = LoadCursorFromFile(NewCursor)
        Case "Long", "Integer"
            hNewCursor = LoadCursor(ByVal 0&, NewCursor)
    End Select
    If (hNewCursor > 0) Then
        hOldCursor = SetCursor(hNewCursor)
    End If

End Function[/blue]

 

[patriciaxxx]

Hello strongm

I like very much your example, it seems much more professional and user friendly.

My aim was to write a kind of all inclusive cursor function but I think that’s what yours is only streamlined.

1. When you say “mess about with the cursor associated with a window's class” do you mean the hwnd for the form. If so I guess you’re right it really isn’t that useful and the function as you’ve written it seems much better.

2. Can you give me examples of how I would call this function.

3. Why Case "Long", "Integer" what are the values I assign here?

4. Can you be so kind as to clean up what declares etc I don’t need using your example. Kind of give me the whole picture as you would write it, including comments.

 

[strongm]

>Why Case "Long", "Integer" what are the values I assign here?


You don't assign anything. The functuion can now take any sort of variable, so we need to determine what type was passed and make the appropriate API call. The Case statement you question simply checks whetehr we have passed a long or an integer. Both can be used by LoadCursor.

 

[patriciaxxx]

Hello strongm

Below is the full code, I have taken out what I think is not needed using your new function, but can you please check it to make sure its correct for me.

There are two problems which I hope you will be able to solve for me. The code now fails to compile on the following line

[COLOR=#204A87]Select Case TypeName(CursorID)
[/color]

and I have lost the Intellisense which gave me the drop down list of cursur names from the following line

[COLOR=#204A87]CursorID As SystemCursorID
[/color]

If you could modify the code so it compiles and has that Intellisense list back I would be very grateful.

[COLOR=#204A87]Option Compare Database
Option Explicit

'Declare Windows API Constants for Windows System cursors.
Public Enum SystemCursorID
    IDC_APPSTARTING = 32650&    'Standard arrow and small hourglass.
    IDC_ARROW = 32512&          'Standard arrow.
    IDC_CROSS = 32515           'Crosshair.
    IDC_HAND = 32649            'Hand.
    IDC_HELP = 32651            'Arrow and question mark.
    IDC_IBEAM = 32513&          'Text I-beam.
    IDC_ICON = 32641&           'Windows NT only: Empty icon.
    IDC_NO = 32648&             'Slashed circle.
    IDC_SIZE = 32640&           'Windows NT only: Four-pointed arrow.
    IDC_SIZEALL = 32646&        'Four-pointed arrow pointing north, south, east, and west.
    IDC_SIZENESW = 32643&       'Double-pointed arrow pointing northeast and southwest.
    IDC_SIZENS = 32645&         'Double-pointed arrow pointing north and south.
    IDC_SIZENWSE = 32642&       'Double-pointed arrow pointing northwest and southeast.
    IDC_SIZEWE = 32644&         'Double-pointed arrow pointing west and east.
    IDC_UPARROW = 32516&        'Vertical arrow.
    IDC_WAIT = 32514&           'Hourglass.
End Enum

'Declarations for API Functions.
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long

'Declare handles for cursor.
Private hNewCursor As Long

Public Function UseCursor(ByVal NewCursor As Variant)

    Select Case TypeName(CursorID)
        Case "String"
            hNewCursor = LoadCursorFromFile(NewCursor)
        Case "Long", "Integer"
            hNewCursor = LoadCursor(ByVal 0&, NewCursor)
    End Select
    If (hNewCursor > 0) Then
        hOldCursor = SetCursor(hNewCursor)
    End If

End Function
[/color]

 

[PHV]

Replace this:
Select Case TypeName(CursorID)
with this:
Select Case TypeName(NewCursor)

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[patriciaxxx]

Hello PHV

Tried your suggestion it solved the compile problem.

Can you or anyone help me with the following.

Can you modify the function so I can get back the ‘Intellisense’ that this line ‘CursorID As SystemCursorID’ gave me.

Important. Can you solve a bug which I discovered, it produces the following behavior: when you load ‘cursor from file’ and assign to the mouse move event of a control on a form, if you move back and forth over that control and / or a second similar control the cursor you set disappears and the standard pointer appears and the whole thing grinds to a halt, you have to close the database for everything to return to normal again.

I need a function that works well and is robust in all situations.

 

[strongm]

S'my fault, I didn't replace all the variable names correctly when I transposed this the function should have been:

[blue]Public Function UseCursor(ByVal NewCursor As Variant)

    Select Case TypeName([b]NewCursor[/b])
        Case "String"
            hNewCursor = LoadCursorFromFile(NewCursor)
        Case "Long", "Integer"
            hNewCursor = LoadCursor(ByVal 0&, NewCursor)
    End Select
    If (hNewCursor > 0) Then
        hOldCursor = SetCursor(hNewCursor)
    End If

End Function[/blue]

And since we have now declared the parameter as a variant instead of a SystemCursorID you won't get the automatic intellisense. However, if you type the first few letter of the variable name followed by <CTL>+<SPACE> you'll get a list: eg

Call USeCursor(IDC<CTL>+<SPACE>

should give you an appropriate intellisense dropdown.

 

[patriciaxxx]

Hello strongm

Can you solve a bug which I discovered, it produces the following behavior: when you load ‘cursor from file’ and assign to the mouse move event of a control on a form, if you move back and forth over that control and / or a second similar control the cursor you set disappears and the standard pointer appears and the whole thing grinds to a halt, you have to close the database for everything to return to normal again.

It only seems to be with the ‘LoadCursorFromFile’

The ‘LoadCursor’ seems to be ok.

 

[strongm]

We probably need to be smarter about how often we load the cursor from file . We only really want to do it once, not everytime we move the mouse a pixel ...

 

[patriciaxxx]

Hello strongm

Would you be kind enough to modify your function and post an example of the code that will achieve this.

 

[patriciaxxx]

Hello strongm or someone please

We probably need to be smarter about how often we load the cursor from file . We only really want to do it once, not everytime we move the mouse a pixel ...

Can you modify the code according to the quote which should sort out the bug.

[COLOR=#204A87]Option Compare Database
Option Explicit

'Declare Windows API Constants for Windows System cursors.
Public Const IDC_APPSTARTING = 32650&    'Standard arrow and small hourglass.
Public Const IDC_ARROW = 32512&          'Standard arrow.
Public Const IDC_CROSS = 32515           'Crosshair.
Public Const IDC_HAND = 32649            'Hand.
Public Const IDC_HELP = 32651            'Arrow and question mark.
Public Const IDC_IBEAM = 32513&          'Text I-beam.
Public Const IDC_ICON = 32641&           'Windows NT only: Empty icon.
Public Const IDC_NO = 32648&             'Slashed circle.
Public Const IDC_SIZE = 32640&           'Windows NT only: Four-pointed arrow.
Public Const IDC_SIZEALL = 32646&        'Four-pointed arrow pointing north, south, east, and west.
Public Const IDC_SIZENESW = 32643&       'Double-pointed arrow pointing northeast and southwest.
Public Const IDC_SIZENS = 32645&         'Double-pointed arrow pointing north and south.
Public Const IDC_SIZENWSE = 32642&       'Double-pointed arrow pointing northwest and southeast.
Public Const IDC_SIZEWE = 32644&         'Double-pointed arrow pointing west and east.
Public Const IDC_UPARROW = 32516&        'Vertical arrow.
Public Const IDC_WAIT = 32514&           'Hourglass.

'Declarations for API Functions.
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long

'Declare handles for cursor.
Private hOldCursor As Long
Private hNewCursor As Long

Public Function UseCursor(ByVal NewCursor As Variant)

    'Load new cursor.
    Select Case TypeName(NewCursor)
        Case "String" 'Custom cursor from file.
            hNewCursor = LoadCursorFromFile(NewCursor)
        Case "Long", "Integer" 'System cursor.
            hNewCursor = LoadCursor(ByVal 0&, NewCursor)
    End Select
    'If successful set new cursor.
    If (hNewCursor > 0) Then
        hOldCursor = SetCursor(hNewCursor)
    End If

End Function[/color]

 

[strongm]

Patricia,

You've got to start thinking for yourself. I am sure it is not the case, but is beginning to look like you simply want people to write code for you. Here's a final example. Note that LoadNewCursor is actually just the original UseCursor renamed. You'd call this once to get a handle to the relevant new cursur. You then call the new (parameterless) UseCursor during MouseMove, as you did the original. This is just one approach. Note that this is example code, not necessarily production code (for example, we don't clear up our new cursors when we no longer need them, nor do we really bother checking whether the cursor alocation succeeds or not)

[blue]Option Compare Database
Option Explicit

'Declare Windows API Constants for Windows System cursors.
Public Const IDC_APPSTARTING = 32650&    'Standard arrow and small hourglass.
Public Const IDC_ARROW = 32512&          'Standard arrow.
Public Const IDC_CROSS = 32515           'Crosshair.
Public Const IDC_HAND = 32649            'Hand.
Public Const IDC_HELP = 32651            'Arrow and question mark.
Public Const IDC_IBEAM = 32513&          'Text I-beam.
Public Const IDC_ICON = 32641&           'Windows NT only: Empty icon.
Public Const IDC_NO = 32648&             'Slashed circle.
Public Const IDC_SIZE = 32640&           'Windows NT only: Four-pointed arrow.
Public Const IDC_SIZEALL = 32646&        'Four-pointed arrow pointing north, south, east, and west.
Public Const IDC_SIZENESW = 32643&       'Double-pointed arrow pointing northeast and southwest.
Public Const IDC_SIZENS = 32645&         'Double-pointed arrow pointing north and south.
Public Const IDC_SIZENWSE = 32642&       'Double-pointed arrow pointing northwest and southeast.
Public Const IDC_SIZEWE = 32644&         'Double-pointed arrow pointing west and east.
Public Const IDC_UPARROW = 32516&        'Vertical arrow.
Public Const IDC_WAIT = 32514&           'Hourglass.

'Declarations for API Functions.
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long

'Declare handles for cursor.
Private hOldCursor As Long
Private hNewCursor As Long


Public Function LoadNewCursor(ByVal NewCursor As Variant)

    'Load new cursor.
    Select Case TypeName(NewCursor)
        Case "String" 'Custom cursor from file.
            hNewCursor = LoadCursorFromFile(NewCursor)
        Case "Long", "Integer" 'System cursor.
            hNewCursor = LoadCursor(ByVal 0&, NewCursor)
    End Select
    'If successful set new cursor.
    If (hNewCursor > 0) Then
        hOldCursor = SetCursor(hNewCursor)
    End If

End Function


Public Sub UseCursor()

    If (hNewCursor > 0) Then
        hOldCursor = SetCursor(hNewCursor)
    End If

End Function[/blue]

 

[patriciaxxx]

strongm

Well your unfriendly comments have almost got me afraid to ask questions anymore, however I will still ask away because that's how I learn best, and I guess you and your friends will simply no longer reply, which, of course, is your right, as is mine to ask the questions.

I find your suggestion offensive as I am only trying to learn how to correctly code and sort bugs, which for me is quite complicated and I learn from experienced people demonstrating the correct way things should be done through examples.

I am sure that for you and those who are experienced this must seem unbelievably simple and perhaps to some even a try on but maybe those who feel like this shouldn’t answer on these forums and just leave it to those who enter into the spirit of the thing.

In your reply to me you say to call UseCursor during MouseMove which I understand, but where do I call LoadNewCursor once from.

As for clearing up the cursors would setting them to nothing as I have done below be the correct approach.

Public Sub UseCursor()

If (hNewCursor > 0) Then
hOldCursor = SetCursor(hNewCursor)
End If

Set hOldCursor = Nothing
Set hNewCursor = Nothing

End Function

Unfortunately I have no idea how to check whether the cursor alocation succeeds or not, and although I would appreciate you help in knowing how to do this I guess that won’t be forthcoming.

 

[strongm]

>unfriendly comments

How, precisely, are you counting a fairly neutral

"You've got to start thinking for yourself. I am sure it is not the case, but is beginning to look like you simply want people to write code for you"

as unfriendly? It is simply an observation, and a mild one at that - particularly given the amount of time I have spent trying to help you, and continued to try and help you since at least 3 monthsr.

In fact, since you have decided to bring it up, you have been asking for code solutions to your problems, and suggesting that a) you are a beginner and b) a programmer since January 2012. There is only so much hand-holding we can do in a professional forum (which is what tek-tips is). To have a self-proclaimed programmer turn around and say, for example, that they have no idea how to call something just once ... and to then impute that it is those people that have been helping them for months are somehow in the wrong is ... well, frankly I'm (almost) speechless.

No one here is paid for providing assistance. We all do it on our own time. For example for this particular issue I've actually been trying to help whilst on vacation.

I'm not even going to get into your suggestion that the experienced people here don't know how difficult some of this stuff can be for beginners - mainly because a) for most of the regulars that help out in here that's clearly rubbish and b) after a year of you asking for help here I find it difficult to accept that you can legitimately remain a complete beginner.

>would setting them to nothing as I have done below be the correct approach

No. The cursor handles we are dealing with are API handles, not class references. So setting them to nothing will do ... nothing. Apart from causing an error. The reality is that since we are using what is called a shared cursor we don't actaually need to destroy it as it is cleaned up when our module (VB6 program) exits. But my point is this - having been given info about LoadCursor etc. I'd have expected you to do a little research of your own about related issues, rather than expecting tek-tips to do all the hard work for you. If you then came back and said something like "I don't understand what a module is and therefore whether I need to destroy the cursor I loaded" then THAT would be an understandable question ... (How do you destroy a cursor? DestroyCursor API call. Do you need to? In this case, no)

 

[patriciaxxx]

For anyone who is looking for similar code here is my revised and working code which overcomes the previous bug.

The module:

[COLOR=#204A87]Option Compare Database
Option Explicit

'Declare Windows API Constants for Windows System cursors.
Public Const IDC_APPSTARTING = 32650&    'Standard arrow and small hourglass.
Public Const IDC_ARROW = 32512&          'Standard arrow.
Public Const IDC_CROSS = 32515           'Crosshair.
Public Const IDC_HAND = 32649            'Hand.
Public Const IDC_HELP = 32651            'Arrow and question mark.
Public Const IDC_IBEAM = 32513&          'Text I-beam.
Public Const IDC_ICON = 32641&           'Windows NT only: Empty icon.
Public Const IDC_NO = 32648&             'Slashed circle.
Public Const IDC_SIZE = 32640&           'Windows NT only: Four-pointed arrow.
Public Const IDC_SIZEALL = 32646&        'Four-pointed arrow pointing north, south, east, and west.
Public Const IDC_SIZENESW = 32643&       'Double-pointed arrow pointing northeast and southwest.
Public Const IDC_SIZENS = 32645&         'Double-pointed arrow pointing north and south.
Public Const IDC_SIZENWSE = 32642&       'Double-pointed arrow pointing northwest and southeast.
Public Const IDC_SIZEWE = 32644&         'Double-pointed arrow pointing west and east.
Public Const IDC_UPARROW = 32516&        'Vertical arrow.
Public Const IDC_WAIT = 32514&           'Hourglass.

'Declarations for API Functions.
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long

'Declare handles for cursor.
Private hOldCursor As Long
Private hNewCursor As Long

'The UseCursor function will load and set a system cursor or a cursor from file to a
'controls event property.
Public Function UseCursor(ByVal NewCursor As Variant)
    
    'Load new cursor.
    Select Case TypeName(NewCursor)
        Case "String" 'Custom cursor from file.
            hNewCursor = LoadCursorFromFile(NewCursor)
        Case "Long", "Integer" 'System cursor.
            hNewCursor = LoadCursor(ByVal 0&, NewCursor)
        Case Else 'Display the default cursor.
            Screen.MousePointer = 0
    End Select
    'If successful set new cursor.
    If (hNewCursor > 0) Then
        hOldCursor = SetCursor(hNewCursor)
    End If
    'Clean up.
    hOldCursor = DestroyCursor(hNewCursor)
    hNewCursor = DestroyCursor(hOldCursor)
    
End Function
[/color]

It can be called in a forms control event like so, it can be any controls event, in this example I’ve used MouseMove because that's where I previously found the bug (you can hover over any of the 3 cursors any number of times and it all seems to work ok, no dropping the cursor or freezing as before):

[COLOR=#204A87]Option Compare Database
Option Explicit

Private Sub lblAniCursorFromFile_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
UseCursor CurrentProject.Path & "\APPSTART.ani"
End Sub

Private Sub lblStdCursorFromFile_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
UseCursor CurrentProject.Path & "\cool.cur"
End Sub

Private Sub lblSystemCursor_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
UseCursor IDC_HELP
End Sub
[/color]