Excel/ vba scrollwheel code failure

Unleash

New Member
Joined
Apr 15, 2011
Messages
13
Since this is my first post about my current project, ill introduce it a bit. You can skip it as its only relevant to the project and not to the problem.

The context:

There is a certain calculation that needs to be run over and over again during a design step. This calculation is an ASME calculation for piping and flanges. (ASME VIII Div.1 App.2).

Because this calculation needs extensive user input, there are a lot of userforms, containing some listboxes. There need to be made choices in material, size, type of bolting etc... so therefor the listbox.

The data for the listboxes is in the innitial excel workbook and is loaded into the listboxes through vba code.

All this functions as it should. The Userforms (UF) are opening and closing in order, the calculation is run and the output is exported to and new excel workbook.

But, yes there it finally is, there is one small thing that really irritates me. The listbox control doesnt support the scrollwheel of a mouse. So scrolling through the lists is done only with the scrollbar and accompanying arrow buttons.

Here starts the trouble. After some research I found and snippet of unfinished code that I used for the scrolwheel, that combined with the msdn knowledge base made me write the following code.

The Problem:

The following code functions as it should. The original code was intented for a single UF and a single combobox. I rewrote that part to support multiple UFs and multiple listboxes.

The thing is that the first UF where the code is applied everything works as it should and the listboxes include the scrolwheel functionality. Then when UF1 unloads and opens UF2, UF2 will appear in the middle of the screen (still good so far), but when I move the cursor over the UF excel will crash and terminate.

The code:
This code goes into a module (currently named "v_scrollwheel")
Code:
Option Explicit
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
    ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MouseWheel = &H20A
Private hWnd_UserForm As Long
Private lngWndProc As Long
'this traps the mousewheel scroll message as it's sent to your form by Wiindows,
'then it calls the procedure in the form's code module in order to scroll the list
Private Function WindowProc(ByVal lWnd As Long, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim MouseKeys As Long
Dim Rotation As Long
    If lMsg = WM_MouseWheel Then
        MouseKeys = wParam And 65535
        Rotation = wParam / 65536
        Select Case True
            Case FlensDefinitie.Visible
                FlensDefinitie.List_MouseWheel Rotation
            Case BandP.Visible
                BandP.BandP_MouseWheel Rotation
         End Select
    End If
    WindowProc = CallWindowProc(lngWndProc, lWnd, lMsg, wParam, lParam)
 
End Function
Public Sub WheelHook(ClientForm As UserForm)
    hWnd_UserForm = FindWindow("ThunderDFrame", ClientForm.Caption)
    lngWndProc = SetWindowLong(hWnd_UserForm, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook()
Dim lRet As Long
    lRet = SetWindowLong(hWnd_UserForm, GWL_WNDPROC, lngWndProc)
End Sub
This code goes ontop of the UF code (for every UF)
Code:
' 'Scrollwheel
Dim LH As Long
Private blnHooked As Boolean 'flag to determine if the control is currently hooked
This goes somewhere else in the UF code (For every UF)
Code:
''==================================================================================================
''==================================================================================================
' Scrollwheel... test
''==================================================================================================
''==================================================================================================
Private Sub List_Pakking_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    LH = 1
    'Maak de hook als muis op control komt.
    List_Hook
End Sub
Private Sub List_Bout_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    LH = 2
    'Maak de hook als muis op control komt.
    List_Hook
End Sub
Private Sub List_MatB_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    LH = 3
    'Maak de hook als muis op control komt.
    List_Hook
End Sub
 
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    LH = 0
    'Vernietigd de hook als muis niet op de control is.
    List_UnHook
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    LH = 0
    'Verzekerd hook vernietiging voordat het scherm wordt gesloten
    List_UnHook
End Sub
Private Sub UserForm_Deactivate()
    LH = 0
    'Vernietigt de hook als een ander scherm wordt geactiveerd
    List_UnHook
End Sub
Private Sub List_Hook()
    'Maakt de Hook alleen als deze nog niet bestaat
    If Not blnHooked Then
        WheelHook Me
        blnHooked = True
    End If
End Sub
Private Sub List_UnHook()
    'Vernietigd de hook alleen als deze al bestaat
    If blnHooked Then
        WheelUnHook
        blnHooked = False
    End If
End Sub
' '============================================================
' ' Function:         BandP_MouseWheel
' ' Part of:            ASME stress calc tool
' ' Desc:              Zorgt ervoor dat de scrollknop werkt op ListBoxen
' ' Called by:       WindowProc
' ' Comments:    v1;
' ' Based on a version by:              Timbo @ xtremevbtalk.com
' ' Rewrite:                                        --, --
' '----------------------------------------------------------------------------------------------------------
' ' All rights reserved
' ' ===========================================================
Public Sub BandP_MouseWheel(ByVal Rotation As Long)
Dim lngNewIndex As Long
Static intCounter As Integer
    'Dit zorgt ervoor dat de code maar één maal wordt uitgevoerd per drie maal "langskomen"
    intCounter = intCounter + 1
    If Not intCounter = 3 Then Exit Sub
    intCounter = 0
    Select Case LH
        Case 1
        With Me.List_Pakking
            If Rotation < 0 Then
                lngNewIndex = .ListIndex + 1
                If .ListCount > lngNewIndex Then .ListIndex = lngNewIndex
            Else
            If Not .ListIndex <= -1 Then .ListIndex = .ListIndex - 1
            End If
        End With
        Case 2
        With Me.List_Bout
            If Rotation < 0 Then
                lngNewIndex = .ListIndex + 1
                If .ListCount > lngNewIndex Then .ListIndex = lngNewIndex
            Else
            If Not .ListIndex <= -1 Then .ListIndex = .ListIndex - 1
            End If
        End With
        Case 3
        With Me.List_MatB
            If Rotation < 0 Then
                lngNewIndex = .ListIndex + 1
                If .ListCount > lngNewIndex Then .ListIndex = lngNewIndex
            Else
            If Not .ListIndex <= -1 Then .ListIndex = .ListIndex - 1
            End If
        End With
    End Select
End Sub

In total ther are 6 modules and 8 Userforms, of which 2 UFs contain the above code.

So I hope you can see what I am missing, but I cant see why this will terminate excel.

Any help will be greatly appreciated!
(since I already started smashing my head onto the desk.)

~U
 
Last edited:

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Nothing??

Nothing? So this is an unsolvable problem?

Ah... thats reall crappy. Sorry for the language.

Maybe you can tell me the main reasons for excel to terminate in this way?
This way: When scrolling over something its like excel deletes its own proces in windows task manager. It just vanishes without a trace...
 
Upvote 0

Forum statistics

Threads
1,224,587
Messages
6,179,738
Members
452,940
Latest member
Lawrenceiow

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