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

Your Favourite API or VBA Class Module Example

Participate now!

Share

Users Viewing This Thread