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")
This code goes ontop of the UF code (for every UF)
This goes somewhere else in the UF code (For every UF)
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
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
Code:
' 'Scrollwheel
Dim LH As Long
Private blnHooked As Boolean 'flag to determine if the control is currently hooked
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 SubIn 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:
