Your Favourite API or VBA Class Module Example

**pike** · Jun 11th 2017

Hook Mouse wheel to scroll Userform Frame

Found this to be a handy addition to allow scrolling in userform frames or other controls

module code

Code

Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private 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
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const cSCROLLCHANGE As Long = 10
Private mLngMouseHook As Long
Private mFormHwnd As Long
Private mbHook As Boolean
Dim mForm As Object
Sub HookFormScroll(oForm As Object)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Set mForm = oForm
hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
If mFormHwnd <> hwndUnderCursor Then
UnhookFormScroll
mFormHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookFormScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mFormHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long
On Error GoTo errH
If (nCode = HC_ACTION) Then
If GetActiveWindow = mFormHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If lParam.hwnd > 0 Then
mForm.ScrollBar1.Value = Application.Min(0, mForm.ScrollBar1.Value + cSCROLLCHANGE)
Else
mForm.ScrollBar1.Value = Application.Max(-250, mForm.ScrollBar1.Value - cSCROLLCHANGE)
End If
Exit Function
End If
End If
End If
MouseProc = CallNextHookEx(mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookFormScroll
End Function

Display More

Userform code

Code

Private Sub CommandButton1_Click()
If Me.OptionButton2.Value = True Then
ActiveWorkbook.Close
ActiveWorkbook.Saved = True
ElseIf Me.OptionButton1.Value = True Then
UnhookFormScroll
Unload Me
Else
MsgBox " you must read the agreement prior to commencing something"
End If
End Sub
Private Sub ScrollBar1_Change()
ProNotes.Frame1.Top = ProNotes.ScrollBar1.Value
End Sub
Private Sub UserForm_Activate()
HookFormScroll Me
End Sub
Private Sub UserForm_Deactivate()
UnhookFormScroll
End Sub
Private Sub UserForm_Initialize()
HookFormScroll Me
End Sub
Private Sub UserForm_QueryClose(Cancel%, CloseMode%)
Dim uname$
If CloseMode = vbFormControlMenu Then
MsgBox " click the OK button to close the UserForm.", , "Dude"
Cancel = True
End If
End Sub

Display More

**pike** · Oct 30th 2017

auto alpha numeration of a userform checkbox list

Code

Dim mcolEvents As Collection
Public Sub SelectedChange(objCtr)
Dim intChr As Long, objColl As Object
intChr = 97
For Each objColl In mcolEvents
If objColl.mCheckBox Then
Me.Controls(objColl.mName).Caption = " (" & Chr(intChr) & ")" & Right(Me.Controls(objColl.mName).Caption, Len(Me.Controls(objColl.mName).Caption) - 4)
intChr = intChr + 1
Else
Me.Controls(objColl.mName).Caption = " (-)" & Right(Me.Controls(objColl.mName).Caption, Len(Me.Controls(objColl.mName).Caption) - 4)
End If
Next
End Sub

Display More

clsFrmCtls class

Code

Option Explicit
Public mName
Public mFrm As Object
Public Event SelectedChange(objCtr)
Public WithEvents mCheckBox As MSForms.CheckBox
Private Sub mCheckBox_Click()
RaiseEvent mFrm.SelectedChange(mName)
End Sub

**pike** · Aug 30th 2018

RadioButton Grades

Class module called RadioCount

Code

Option Explicit
Public Frm As Object
Event RadioButtonCount(mGrade As String)
Public WithEvents RadioButton As MSForms.OptionButton
Sub RadioButton_Click()
Dim lngIndex As Long
Dim lngAlpha As Long
Dim lngLetter As Long
Dim strAlpha As String
Dim ctl As MSForms.Control
Dim AlphaList As Object
Set AlphaList = CreateObject("System.Collections.ArrayList")
lngIndex = 0
lngAlpha = 0
For Each ctl In Frm.Controls
If TypeOf ctl Is MSForms.OptionButton Then
If ctl.Caption = "Yes" Then
lngAlpha = lngAlpha + 1
AlphaList.Add Chr(lngAlpha + 64)
End If
If ctl.Caption = "Yes" And ctl.Value Then lngIndex = lngIndex + 1
End If
Next
AlphaList.Reverse
If lngIndex > 0 Then
strAlpha = AlphaList.Item(lngIndex - 1)
Else
strAlpha = ""
End If
RaiseEvent Frm.RadioButtonCount(strAlpha)
End Sub

Display More

userform module code

Code

Option Explicit
Dim RadioButton As New Collection
Sub UserForm_Initialize()
Dim dbEvents As RadioCount
Dim ctl As MSForms.Control
For Each ctl In Me.Controls
If TypeOf ctl Is MSForms.OptionButton Then
Set dbEvents = New RadioCount
Set dbEvents.Frm = Me
Set dbEvents.RadioButton = Me.Controls(ctl.Name)
RadioButton.Add dbEvents
End If
Next
End Sub
Sub RadioButtonCount(strAlpha)
Me.TextBox1.Value = strAlpha
End Sub

Display More

Just add more OptionButtons with yes or no Captions to the userform and the code will adjust the grade accordingly

**pike** · Aug 31st 2018

Class for Textbox entry limited to Numeric or Alphanumeric entry

Userform Code

Code

Option Explicit
Dim myCollection As Collection
Dim TboxAtoZ(1) As New clsFrmTboxText
Dim Tbox1to9(1) As New clsFrmTboxNumber
Private Sub UserForm_Initialize()
Dim xCell, objControl As Control
Set myCollection = New Collection
For Each objControl In Me.Controls
If TypeOf objControl Is MSForms.TextBox Then
Debug.Print objControl.Name
If objControl.Name = "TextBox1" Then
Set TboxAtoZ(1).TextBoxEvents = objControl
ElseIf objControl.Name = "TextBox2" Then
Set Tbox1to9(1).TextBoxEvents = objControl
End If
End If
Next objControl
Set objControl = Nothing
With Sheet1
For Each xCell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
On Error Resume Next
myCollection.Add CStr(xCell & "~" & xCell.Offset(0, 1).Value), CStr(xCell & "~" & xCell.Offset(0, 1).Value)
Err.Clear
Next
End With
End Sub
Private Sub CommandButton1_Click()
With Sheet1
On Error Resume Next
myCollection.Add CStr(Me.TextBox1.Value & "~" & Me.TextBox2.Value), CStr(Me.TextBox1.Value & "~" & Me.TextBox2.Value)
If Err = 457 Then
Err.Clear
MsgBox "Items exist"
Else
.Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, 2) = VBA.Array(Me.TextBox1.Value, Me.TextBox2.Value)
Unload Me
End If
End With
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub

Display More

Class module clsFrmTboxText

Code

Option Explicit
Public WithEvents TextBoxEvents As MSForms.TextBox
Dim LastPosition As Long
Private Sub TextBoxEvents_Change()
Static LastText As String
Static SecondTime As Boolean
If Not SecondTime Then
With TextBoxEvents
If .text Like "*[!A-Za-z ']*" Then
Beep
SecondTime = True
.text = LastText
.SelStart = LastPosition
Else
LastText = .text
End If
End With
End If
SecondTime = False
End Sub
Private Sub TextBoxEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
With TextBoxEvents
LastPosition = .SelStart
End With
End Sub
Private Sub TextBoxEvents_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
With TextBoxEvents
LastPosition = .SelStart
End With
End Sub

Display More

Class module clsFrmTboxNumber

Code

Option Explicit
Public WithEvents TextBoxEvents As MSForms.TextBox
Dim LastPosition As Long
Private Sub TextBoxEvents_Change()
Static LastText As String
Static SecondTime As Boolean
If Not SecondTime Then
With TextBoxEvents
If .text Like "*[!0-9.]*" Or .text Like "*.*.*" Then
Beep
SecondTime = True
.text = LastText
.SelStart = LastPosition
Else
LastText = .text
End If
End With
End If
SecondTime = False
End Sub
Private Sub TextBoxEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
With TextBoxEvents
LastPosition = .SelStart
End With
End Sub
Private Sub TextBoxEvents_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
With TextBoxEvents
LastPosition = .SelStart
End With
End Sub

Display More

**Carim** · Sep 1st 2018

Hello Pike ...:wink:

As usual .. extremely handy codes ...!!! :smile:

You are building a Generic Library which is becoming THE Reference ....:congrats:

Cheers

**pike** · Sep 3rd 2018

Enhanced "Popup menu at mouse position" is one I have been using a lot.
Instead of returning the additem id number it returns the popup text associated wit the id number.
It uses a event with in the clsPopup class to populate a external collection to return the text.

In the clsPopup class add dimensions

Code

Public Event AddCollection(objStr, objInd) ' add this line
Public Frm As Object ' add this line

and in the additem function

Code

RaiseEvent Frm.AddCollection(varItem, CStr(nID))

In the userform add dimension

Code

Dim mylist As Collection

and event to populate the collection

Code

Public Sub AddCollection(varItem, nID)
mylist.Add varItem, nID
End Sub

Then the result is retrieved like

Code

lngResult = mnu.PopUpMnu
If Not lngResult = 9 And Not lngResult = 0 Then
MsgBox "You picked " & mylist(CStr(lngResult))
End If

Its easier to follow in the complete syntax in the attached workbook

**pike** · Sep 8th 2018

Very handy
Calendar Control Class by Jonathon English

basicvba01 · Dec 29th 2019

64-bit 2010 mouse scroll does not work, compilation error. Couple you please provide 64-bit compatible working code.

**Carim** · Dec 29th 2019

Hello,

For all 64 bit platforms, you can use following link by Jan Karel Pieterse

https://jkp-ads.com/Articles/apideclarations.asp

Hope this will help

basicvba01 · Dec 29th 2019

'''''' normal module code I tried changing the calls as suggested in the link for 64-bit (compilation error,, automation error, excel crash , but with less expertise i am not able to get it work ....

Anyone in thyis forum is having migrated calls for 64-bit office working, please share

Code

Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private 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
Private Declare Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
'Private Declare Function PostMessage Lib "user32.dll" _
' Alias "PostMessageA" ( _
' ByVal hwnd As Long, _
' ByVal wMsg As Long, _
' ByVal wParam As Long, _
' ByVal lParam As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
'Private Const WM_KEYDOWN As Long = &H100
'Private Const WM_KEYUP As Long = &H101
'Private Const VK_UP As Long = &H26
'Private Const VK_DOWN As Long = &H28
'Private Const WM_LBUTTONDOWN As Long = &H201
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
Private mCtl As MSForms.Control
Dim n As Long
Sub HookListBoxScroll(frm As Object, ctl As MSForms.Control)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
If Not frm.ActiveControl Is ctl Then
ctl.SetFocus
End If
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
Set mCtl = ctl
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
' PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
Set mCtl = Nothing
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc( _
ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MOUSEHOOKSTRUCT) As Long
Dim idx As Long
On Error GoTo errH
If (nCode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
' If lParam.hwnd > 0 Then
' PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
' Else
' PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
' End If
' PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
If lParam.hwnd > 0 Then idx = -1 Else idx = 1
' idx = idx + mCtl.ListIndex
' If idx >= 0 Then mCtl.ListIndex = idx
idx = idx + mCtl.TopIndex
If idx >= 0 Then mCtl.TopIndex = idx
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function

Display More

'''''''' end normal module code

**pike** · Jan 1st 2020

Hi ,

The link below has the supporting changes

https://docs.microsoft.com/en-…rsafe-with-64-bit-support

**Carim** · Jan 1st 2020

Quote from pike

Hi ,
The link below has the supporting changes

https://docs.microsoft.com/en-…rsafe-with-64-bit-support

Thanks for the link

Cristian Buse · Feb 4th 2021

Alternative solution that works on both x32 and x64: VBA UserForm MouseScroll

**Carim** · Feb 4th 2021

Quote from Cristian Buse

Alternative solution that works on both x32 and x64: VBA UserForm MouseScroll

Thanks for sharing your work on github

Share