Announcement

Collapse
No announcement yet.

Your Favourite API or VBA Class Module Example

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • #16
    Update ~ Class Userform Controls Raise Events

    Programmatically enhanced to handle the errors in previous example ..

    Userform1 is now showModal=False and additional MousedownOnForm code added

    Userform1 Code

    Code:
    Option Explicit
    Public Event OnEnter(ctrl As msforms.Control)
    Public Event OnExit(ctrl As msforms.Control)
    Private oXitClass As CtlExitCls
    Private bFormUnloaded As Boolean
    Private oPrevActiveCtl As msforms.Control
    Private oCol As New Collection
    Dim MousedownOnForm As Boolean
    Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        MousedownOnForm = True
    End Sub
    Private Sub UserForm_Click()
        If Not MousedownOnForm Then Exit Sub
        MousedownOnForm = False
    End Sub
    Sub Combobox_List(myCtrl As Control)
        Dim myRng As Range, objCtrl As Control
        With CreateObject("scripting.dictionary")
            .comparemode = 1
            For Each myRng In Range("A2", Cells(Rows.Count, 1).End(xlUp))
                If Not .exists(myRng.Value) Then .Add myRng.Value, Nothing
            Next myRng
            For Each objCtrl In Me.Controls
                If TypeName(objCtrl) Like "ComboBox" And Not objCtrl.Name Like myCtrl.Name Then
                    If .exists(objCtrl.Value) Then
                        .Remove (objCtrl.Value)
                    End If
                End If
            Next
            If .Count Then
                myCtrl.List = Application.Transpose(.keys)
            End If
        End With
    End Sub
    Private Sub CommandButton1_Click()
        Unload Me
    End Sub
    Private Sub UserForm_Layout()
        Call WatchEvents
    End Sub
    Private Sub UserForm_Terminate()
        Call CleanUp
    End Sub
    Private Sub WatchEvents()
        If Not oXitClass Is Nothing Then Exit Sub
        Set oXitClass = New CtlExitCls
        Set oXitClass.FormCtrl = Me
        bFormUnloaded = False
        Set oPrevActiveCtl = Me.ActiveControl
        RaiseEvent OnEnter(Me.ActiveControl)
        Do While bFormUnloaded = False
            If Not oPrevActiveCtl Is Nothing Then
                If Not oPrevActiveCtl Is Me.ActiveControl Then
                    RaiseEvent OnExit(oPrevActiveCtl)
                    RaiseEvent OnEnter(Me.ActiveControl)
                    Me.ActiveControl.SetFocus
                End If
            End If
            Set oPrevActiveCtl = Me.ActiveControl
            DoEvents
        Loop
    End Sub
    Private Sub CleanUp()
        bFormUnloaded = True
        RaiseEvent OnExit(oPrevActiveCtl)
        Set oXitClass = Nothing
        Set oCol = Nothing
        Set oPrevActiveCtl = Nothing
    End Sub
    Class Module named CtlExitCls

    Code:
    Option Explicit
    Public WithEvents FormCtrl As UserForm1
    Private Sub FormCtrl_OnEnter(ctrl As msforms.Control)
    ' MsgBox "You Exited the Control :  " & "(" & Ctrl.Name & ")"
        Select Case True
        Case TypeName(ctrl) Like "ComboBox"
            Call FormCtrl.Combobox_List(ctrl)
        Case TypeName(ctrl) Like "TextBox"
            '   MsgBox "You Entered the Control :  " & "(" & Ctrl.Name & ")"
        Case TypeName(ctrl) Like "CommandButton"
            '  MsgBox "You Entered the Control :  " & "(" & Ctrl.Name & ")"
        Case Else
        End Select
    End Sub
    Private Sub FormCtrl_OnExit(ctrl As msforms.Control)
    ' MsgBox "You Exited the Control :  " & "(" & Ctrl.Name & ")"
        Select Case True
        Case TypeName(ctrl) Like "ComboBox"
            '   MsgBox "You Exited the ComboBox Control :  " & "(" & Ctrl.Name & ")"
        Case TypeName(ctrl) Like "TextBox"
            '   MsgBox "You Exited the TextBox Control :  " & "(" & Ctrl.Name & ")"
        Case TypeName(ctrl) Like "CommandButton"
            '  MsgBox "You Exited the CommandButton Control :  " & "(" & Ctrl.Name & ")"
        End Select
    End Sub
    Attached Files
    If the solution helped please donate to RSPCA

    Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

    Comment


    • #17
      Re: Your Favourite VBA Class Module Example

      Thanks Pike... I needed this about 12 months ago good to know (now) how it can be done
      Check out our new reputation system. Click on the Like button under the post!
      _______________________________________________

      There are 10 types of people in the world. Those that understand Binary and those that dont.

      Why are Halloween and Christmas the same? Because Oct 31 = Dec 25...

      The BEST Lookup function of all time

      Dynamic Named Ranges are your bestest friend

      _______________________________________________

      Comment


      • #18
        Re: Your Favourite VBA Class Module Example

        Just stumbled across it here.
        If the solution helped please donate to RSPCA

        Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

        Comment


        • #19
          VBA event Class for worksheet Activex or Form Controls

          in the example workbook click any ActiveX textbox to transfer its value to range A1

          module code
          Code:
          Option Explicit
          Dim ListTextBoxes() As New clsTextBox
          Sub Hook_TextBoxes()
              Dim objShape As Shape
              Dim intCount As Long
          
              ReDim ListTextBoxes(1 To 1)
              For Each objShape In ActiveSheet.Shapes
              ' Debug.Print "A~ " & TypeName(objShape.OLEFormat.Object)
                  If TypeName(objShape.OLEFormat.Object) Like "OLEObject" Then
                    ' Debug.Print "B~ " & TypeName(objShape.OLEFormat.Object.Object)
                      If TypeName(objShape.OLEFormat.Object.Object) Like "TextBox" Then
                          intCount = intCount + 1
                          ReDim Preserve ListTextBoxes(1 To intCount)
                          Set ListTextBoxes(intCount).objTextBox = objShape.OLEFormat.Object.Object
                      End If
                  End If
              Next
          End Sub
          Sub UnHook_TextBoxes()
              Dim intCount As Long
          
              If IsArray(ListTextBoxes) Then
                  For intCount = LBound(ListTextBoxes) To UBound(ListTextBoxes)
                      Set ListTextBoxes(intCount).objTextBox = Nothing
                  Next
              End If
          End Sub
          worksheet module

          Code:
          Option Explicit
          Private Sub Worksheet_Activate()
              Call Hook_TextBoxes
          End Sub
          Sub Worksheet_Deactivate()
              Call UnHook_TextBoxes
          End Sub
          class module named clsTexBox
          Code:
          Option Explicit
          Public WithEvents objTextBox As msforms.TextBox
          Private Sub objTextBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
              Range("A1").Value = objTextBox.Value
          End Sub
          Attached Files
          If the solution helped please donate to RSPCA

          Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

          Comment


          • #20
            Re: Your Favourite VBA Class Module Example

            another gem from Jaafar
            Class for Trapping Mouse Clicks on Cells
            Attached Files
            If the solution helped please donate to RSPCA

            Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

            Comment


            • #21
              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



              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
              Attached Files
              If the solution helped please donate to RSPCA

              Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

              Comment


              • #22
                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
                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
                Attached Files
                If the solution helped please donate to RSPCA

                Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

                Comment


                • #23
                  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
                  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
                  Just add more OptionButtons with yes or no Captions to the userform and the code will adjust the grade accordingly
                  Attached Files
                  Last edited by pike; 3 weeks ago.
                  If the solution helped please donate to RSPCA

                  Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

                  Comment


                  • #24
                    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



                    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

                    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
                    Attached Files
                    If the solution helped please donate to RSPCA

                    Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

                    Comment


                    • #25
                      Hello Pike ...

                      As usual .. extremely handy codes ...!!!

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

                      Cheers
                      If you feel like saying "Thank You" for the help received ...You can click on the "Like" icon ...just underneath ... ... in the bottom right corner ...

                      Comment


                      • #26
                        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
                        Attached Files
                        Last edited by pike; 2 weeks ago.
                        If the solution helped please donate to RSPCA

                        Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

                        Comment


                        • #27


                          Very handy
                          Calendar Control Class by Jonathon English
                          Attached Files
                          If the solution helped please donate to RSPCA

                          Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | SO The Macro Man | The Smallman

                          Comment

                          Working...
                          X