Your Favourite API or VBA Class Module Example

**pike** · Jul 30th 2015

What is your Favourite Excel VBA Class that you frequently use
CTextbox class is used to only allow input of numbers in userform text boxes.. Very useful

Class Module name CTextbox

Code

Option Explicit Public WithEvents TBox As MSForms.TextBox


Private Sub Tbox_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = CheckInput(KeyAscii)
End Sub
Public Function CheckInput(ByVal KeyAscii As MSForms.ReturnInteger)
    CheckInput = IIf((KeyAscii >= 48) And (KeyAscii <= 57), KeyAscii, vbKeyClear)
End Function

Userform code

Code

Option Explicit
Dim TextBoxes() As New CTextbox


Private Sub UserForm_Initialize()
Dim ctl As MSForms.Control
Dim idx As Long


    For Each ctl In Me.Controls
        If TypeOf ctl Is MSForms.TextBox Then
            ReDim Preserve TextBoxes(idx)
            Set TextBoxes(idx).TBox = ctl
            idx = idx + 1
        End If
    Next ctl


End Sub

Display More

Please add your favourite and most frequently use class

**pike** · Jul 30th 2015

Trigger a control change event in Userform

another Class written by jindon to trigger a control change event for comboboxes in a userform and linking a result to a textbox

Class module name Class1

Code

Option Explicit


Private WithEvents myCB As MSForms.ComboBox
Private myIndex As Long
 
Public Sub New_CB(CB As MSForms.ComboBox, CBIndex As Long)
    Set myCB = CB
    myIndex = CBIndex
End Sub
 
Private Sub myCB_Change()
    UserForm1.Controls("textbox" & myIndex).Value = ""
End Sub


Private Sub myCB_Click()
    UserForm1.Controls("textbox" & myIndex).Value = ""
    With UserForm1.Controls("combobox" & myIndex)
        If .ListIndex > -1 Then
            UserForm1.Controls("textbox" & myIndex).Value = _
            Sheets("feuil1").Cells(.ListIndex + 6, "e").Text
        End If
    End With
End Sub

Display More

userform code

Code

Option Explicit
Private CB(1 To 10) As New Class1


Private Sub UserForm_Initialize()
    Dim i As Long, f As Worksheet
    Set f = Sheets("Feuil1")
    For i = 1 To 10
        CB(i).New_CB Me.Controls("combobox" & i), i
        Me.Controls("ComboBox" & i).List = f.Range("D6", f.[D65000].End(xlUp)).Value
        Me.Controls("ComboBox" & i).ListIndex = -1
        Me.Controls("textbox" & i).Text = ""
    Next
End Sub

Display More

Im sure everyone has a usefully object they have created or use that can be added

cytop · Jul 30th 2015

Popup menu at mouse position

Generates a Popup menu at the mouse position - or any position you like. I've used this to build a menu 'bar' on a userform...

[Blocked Image: http://www.ozgrid.com/forum/attachment.php?attachmentid=66409&d=1438265863]

If I could credit any original authors, I would, but SourceSafe (Yeah, I still use that!) shows the first version labelled as 'Visual Basic 4 (16 Bit)'! - that dates it a little and it has been extended/modified since - upgraded to 32 bit, then 64 bit. Wondering if I'll even care about upgrading it to 128 bit

Test procedure:

Code

Option Explicit
Option Compare Text


Public Sub PopUp()


   Dim mnu              As clsPopup
   Dim mnuSub           As clsPopup


   On Error GoTo Catch


   Set mnu = New clsPopup
   Set mnuSub = New clsPopup


   mnuSub.Caption = "Test 4 (Sub menu)"


   With mnu


      .AddItem 0, "Test 1 (Disabled)", , , True
      .AddItem 1, "Test 2 (Default)", True
      .AddItem 2, "Test 3 (Checked)", , True
      .AddItem 3, mnuSub                              '// Can also have other settings like 'Default, Checked' etc
      .AddItem 5, "-"
      .AddItem 6, "Close Menu"
   End With


   With mnuSub
      .AddItem 10, "Submenu 1"
      .AddItem 11, "Submenu 2"
      .AddItem 12, "Submenu 3"
      .AddItem 13, "Submenu 4"
      .AddItem 14, "Submenu 5 (New Column)", , , , , True
      .AddItem 15, "Submenu 6"
      .AddItem 16, "Submenu 7"


   End With
   
   '// the return value will be the value defined after the .ADDITEM
   Debug.Print mnu.PopUpMnu()


   Set mnu = Nothing
   Set mnuSub = Nothing


Catch:


End Sub

Display More

Class Module code (clsPopup)

Code

Option Explicit
Option Compare Text


Private m_hMenu         As Long


'//* The Caption proporty of a Sub-menu is the option displayed on the parent menu
Public Caption          As String


Private Declare Function SetMenuDefaultItem Lib "User32" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPos As Long) As Long
Private Declare Function CreatePopupMenu Lib "User32" () As Long
Private Declare Function DestroyMenu Lib "User32" (ByVal hMenu As Long) As Long
Private Declare Function AppendMenu Lib "User32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, lpNewItem As String) As Long
Private Declare Function EnableMenuItem Lib "User32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
Private Declare Function RemoveMenu Lib "User32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long




Private ItemCount       As Long


Private Const MF_STRING = &H0&
Private Const MF_SEPARATOR = &H800&
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_POPUP = &H10&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H2&
Private Const MF_ENABLED As Long = &H0&
Private Const MF_CHECKED = &H8&


Private Const MF_BYPOSITION = &H400&
Private Const MF_REMOVE = &H1000&


Private Const APIFALSE  As Long = 0


Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTL) As Long
Private Declare Function GetDesktopWindow Lib "User32" () As Long
Private Declare Function TrackPopupMenu Lib "User32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, ByVal lprc As Long) As Long
Private Declare Function GetWindow Lib "User32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "User32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long


Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2


Private Type POINTL
   X                    As Long
   Y                    As Long
End Type
Private Const TPM_RETURNCMD = &H100&
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_LEFTBUTTON = &H0&


Private Declare Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long


Private Type RECT
   Left                 As Long
   Top                  As Long
   Right                As Long
   Bottom               As Long
End Type


Private Sub Class_Initialize()
   m_hMenu = CreatePopupMenu()
End Sub


Private Sub Class_Terminate()
   DestroyMenu m_hMenu
End Sub


'//* Returns a reference to the menu


Friend Property Get hMenu() As Long
   hMenu = m_hMenu
End Property


'//* Removes a single item


Public Sub RemoveItem(ByVal nID As Long)


   RemoveMenu m_hMenu, 0, MF_REMOVE Or MF_BYPOSITION


End Sub


'//* Adds an item to the menu


Public Sub AddItem(ByVal nID As Long, _
                   varItem As Variant, _
                   Optional bDefault As Boolean = False, _
                   Optional bChecked As Boolean = False, _
                   Optional bDisabled As Boolean = False, _
                   Optional bGrayed As Boolean = False, _
                   Optional bNewColumn As Boolean = False)


   If TypeName(varItem) = "String" Then
      If varItem = "-" Then
         AppendMenu m_hMenu, MF_STRING Or MF_SEPARATOR, nID, ByVal vbNullString
      Else
         AppendMenu m_hMenu, MF_STRING Or IIf(bNewColumn, MF_MENUBARBREAK, 0) Or IIf(bChecked, MF_CHECKED, 0), nID, ByVal varItem
      End If
   ElseIf TypeName(varItem) = "clsPopup" Then


      Dim cSubMenu      As clsPopup
      Set cSubMenu = varItem
      
      AppendMenu m_hMenu, MF_STRING Or MF_POPUP Or IIf(bNewColumn, MF_MENUBARBREAK, 0), cSubMenu.hMenu, ByVal cSubMenu.Caption
      
   End If


   If bDefault Then SetMenuDefaultItem m_hMenu, nID, APIFALSE
   If bGrayed Then EnableMenuItem m_hMenu, nID, MF_BYCOMMAND Or MF_GRAYED
   If bDisabled Then EnableMenuItem m_hMenu, nID, MF_BYCOMMAND Or MF_DISABLED


   ItemCount = ItemCount + 1


End Sub


'//* Returns the count of items


Public Property Get Items() As Long


   Items = ItemCount


End Property


'//* Enables/Disables a single item


Public Sub GreyItem(nID, Disabled As Boolean)


   On Error Resume Next
   EnableMenuItem m_hMenu, nID, MF_BYCOMMAND Or IIf(Disabled, MF_DISABLED, MF_ENABLED)


End Sub


'//* The main procedure to display the menu and return the selection


Public Function PopUpMnu(Optional ByVal hwnd As Long = -1, _
                           Optional ByVal PopX As Long = -1, _
                           Optional ByVal PopY As Long = -1, _
                           Optional ByVal hWndOfBeneathControl As Long = -1) As Long


   Dim h                As Long
   Dim X                As Long
   Dim Y                As Long


   If hwnd = -1 Or hwnd = 0 Then
      ' Find the top window of current process
      Dim hDesktop      As Long
      hDesktop = GetDesktopWindow()


      '//* Find the Active Child Window
      Dim hChild        As Long
      hChild = GetWindow(hDesktop, GW_CHILD)


      '//* Get the ProcessID
      Dim idCurrent     As Long
      idCurrent = GetCurrentProcessId()
      
      Do While hChild
         Dim idChild    As Long
         GetWindowThreadProcessId hChild, idChild
         If idChild = idCurrent Then Exit Do
         hChild = GetWindow(hChild, GW_HWNDNEXT)
      Loop


      If hChild = 0 Then Err.Raise -1, "cMenu.TrackPopup", "Cannot find top window of current process!"
      h = hChild
   Else
      h = hwnd
   End If


   '//* Passed a default control to use as a reference point?
   If hWndOfBeneathControl <> -1 Then
      Dim rt            As RECT
      GetWindowRect hWndOfBeneathControl, rt
      X = rt.Left
      Y = rt.Bottom
   Else
      '//* else get the current Mouse position
      Dim pt            As POINTL
      GetCursorPos pt
      If PopX = -1 Then X = pt.X Else: X = PopX
      If PopY = -1 Then Y = pt.Y Else: Y = PopY
   End If


   '//* Show the menu.
   PopUpMnu = TrackPopupMenu(m_hMenu, TPM_RETURNCMD + TPM_LEFTALIGN + TPM_LEFTBUTTON, X, Y, 0, h, 0)


End Function

Display More

**Carim** · Jul 30th 2015

Class for Linked lists

Hi,

Excellent idea to recap favourite Classes ...:smile:

Chip Pearson has created a long time ago ...a very handy class for Linked lists ...

Code

Option Explicit
Option Compare Text
Option Base 1
'==============================================================================
'==============================================================================
' CLinkedListBox
' By Chip Pearson, [email protected] www.cpearson.com
'                  www.cpearson.com/Excel/LinkedListBoxes.aspx
' 18-June-2010
'
' This provides the logic for linking multiple list boxes to
' one another based on the selected item in a list box. That is to
' say, changing the selected item in ListBox1 can cause its "child"
' or "downstream" listboxes to update their list values.
' Each listbox in the chain of linked listboxes (with the exception
' of the final listbox) contains a reference to the next or "downstream"
' list box. When a listbox's value is changed, the LoadListBox member
' of the listbox's downstream list box is called, causing it to update
' its list and the lists of all the downstream listboxes.
'==============================================================================
'==============================================================================




'=============================================
' PRIVATE VARIABLES
'=============================================
' pLBX is the ListBox control that is
' managed by this instance of the class.
Private WithEvents pLBX As MSForms.ListBox
' pNextListBox in the next listbox in the
' natural order of the data hierarchy.
Private pNextListBox As CLinkedListBox
' pInitialIndex sets the listbox's
' ListIndex to any valid value.
Private pInitialIndex As Long


'=============================================
' PROPERTY PROCEDURES
'=============================================
Public Property Get LBX() As MSForms.ListBox
''''''''''''''''''''''''''''''''''''''''''''''
' Get LBX
' Returns the ListBox control managed by
' this instance of the class.
''''''''''''''''''''''''''''''''''''''''''''''
    Set LBX = pLBX
End Property


Public Property Set LBX(C As MSForms.ListBox)
''''''''''''''''''''''''''''''''''''''''''''''
' Set LBX
' This sets the ListBox control to be managed
' by this instance of the class.
'''''''''''''''''''''''''''''''''''''''''''''
    Set pLBX = C
End Property


Public Property Get NextListBox() As CLinkedListBox
''''''''''''''''''''''''''''''''''''''''''''''
' Get NextListBox
' This returns the next listbox in the chain
' of linked listboxes.
''''''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    Set NextListBox = pNextListBox
End Property


Public Property Set NextListBox(CLbx As CLinkedListBox)
''''''''''''''''''''''''''''''''''''''''''''''
' Set NextListBox
' This sets the NextListBox to the class that
' controls the next downstream listbox.
''''''''''''''''''''''''''''''''''''''''''''''
    Set pNextListBox = CLbx
End Property
    
Public Property Get InitialIndex() As Long
''''''''''''''''''''''''''''''''''''''''''''''
' Get InitialIndex
' This returns the InitialIndex value. This
' is the value to which the listbox's
' ListIndex is to be set.
''''''''''''''''''''''''''''''''''''''''''''''
    InitialIndex = pInitialIndex
End Property


Public Property Let InitialIndex(Value As Long)
''''''''''''''''''''''''''''''''''''''''''''''
' Let InitialIndex
' Sets the value of this class's InitialIndex
' property.
''''''''''''''''''''''''''''''''''''''''''''''
    If Value < 0 Then
        Err.Raise 5, , "InitialIndex must be greater than or equal to 0."
        Exit Property
    End If
    pInitialIndex = Value
End Property


'=============================================
' METHODS
'=============================================


Public Sub LoadListBox(DataRange As Range)
''''''''''''''''''''''''''''''''''''''''''''''
' LoadListBox
' This loads the listbox. It takes its
' values from the first column of DataRange
' and the ranges linked to each of those
' from the second item in the row.
''''''''''''''''''''''''''''''''''''''''''''''
    Dim R As Range
    Dim Arr() As String
    Dim N As Long
    N = DataRange.Rows.Count
    ReDim Arr(1 To N, 1 To 2)
    ClearList
    With Me.LBX
        N = 0
        For Each R In DataRange.Columns(1).Cells
            ' skip empty elements
            If (Len(Trim(R(1, 1).Text)) > 0) Then
                If R(1, 3).Value <> False Then
                    N = N + 1
                    Arr(N, 1) = R.Text
                    Arr(N, 2) = R(1, 2).Text
                End If
            End If
        Next R
        .List = Arr
        If .ListCount > 0 Then
            If (pInitialIndex <= .ListCount - 1) And _
                (pInitialIndex >= 0) Then
                .ListIndex = pInitialIndex
            Else
                .ListIndex = 0
            End If
            If Not pNextListBox Is Nothing Then
                ' call the next listbox's LoadListBox. This
                ' will cause a cascade down the listbox change.
                pNextListBox.LoadListBox Range(.List(.ListIndex, 1))
            End If
        End If
    End With
End Sub


Public Sub ClearList()
''''''''''''''''''''''''''''''''''''''''''''''
' ClearList
' Clear the list box and send a message down stream
' to clear all subordinate list boxes. Upstream
' listboxes are not cleared.
''''''''''''''''''''''''''''''''''''''''''''''
    Me.LBX.Clear
    
    If Not pNextListBox Is Nothing Then
        pNextListBox.ClearList
    End If
End Sub


Public Sub SetIndex(Value As Long)
''''''''''''''''''''''''''''''''''''''''''''''
' SetIndex
' This sets the current ListIndex for the
' LBX listbox controlled by this instance
' of the class. It calls the LoadListBox
' of the downstream listbox so all downstream
' listboxes will be properly updated. However,
' upstream listboxes are not updated, so it
' is possible that the (upstream) listboxes
' will be out of sync. Use this method with
' caution.
''''''''''''''''''''''''''''''''''''''''''''''
Dim S As String
If (Value < 0) Or (Value > Me.LBX.ListCount - 1) Then
    Err.Raise 5, , "Invalid Value for ListIndex"
    Exit Sub
End If
With Me.LBX
    .ListIndex = Value
    S = .List(.ListIndex, 1)
    pNextListBox.LoadListBox Range(S)
End With
End Sub


Private Sub pLBX_Click()
''''''''''''''''''''''''''''''''''''''''''''''
' pLBX_Click
' When the user clicks on a list box item,
' the range name from the hidden second column
' of the list box is passed to pNextListBox
' so that it (and other downstream listboxes
' can load with the right data.
'''''''''''''''''''''''''''''''''''''''''''
    Dim S As String
    With Me.LBX
        If .ListIndex < 0 Then
            Exit Sub
        End If
        S = .List(.ListIndex, 1)
        If Not pNextListBox Is Nothing Then
            pNextListBox.LoadListBox Range(S)
        End If
    End With
End Sub

Display More

**Krishnakumar** · Jul 31st 2015

Class Module for Database Connection

Database connection

Class module

Code

'//Original link from where I got this wonderful code snippet
'http://markdagosta.com/tag/reusable-class-module/


Option Explicit
Private mobjConn As Object 'ADODB.Connection


'Module-level variables
Private mblnIntegratedSecurity As Boolean
Private mstrModuleName As String
Private mstrConnectionString As String
Private mstrCurrentServer As String
Private mstrCurrentDatabase As String
Private mstrDatabaseType As String


Private mlngRecordCount As Long


Private Const adUseClient As Long = 3
Private Const adLockReadOnly As Long = 1
Private Const adStateOpen As Long = 1
Private Const adCmdStoredProc As Long = 4
Private Const adParamOutput As Long = 2
Private Const adOpenDynamic As Long = 2
Private Const adOpenstatic As Long = 3


Private Sub Class_Initialize()


mstrModuleName = "clsDBConnection_LBinding"
'Set mobjConn = New ADODB.Connection
Set mobjConn = CreateObject("ADODB.Connection")


End Sub


Private Sub Class_Terminate()


On Error Resume Next
mobjConn.Close
Set mobjConn = Nothing
On Error GoTo 0


End Sub


'//added by Kris
Public Property Get RecordCount() As Long


RecordCount = mlngRecordCount


End Property


Public Property Let RecordCount(ByVal NewValue As Long)


mlngRecordCount = NewValue


End Property
'//end


Public Property Get ConnectionString() As String


ConnectionString = mstrConnectionString


End Property


Public Property Let ConnectionString(ByVal NewValue As String)


mstrConnectionString = NewValue


End Property


Public Property Get CommandTimeOut() As Integer


CommandTimeOut = mobjConn.CommandTimeOut


End Property


Public Property Let CommandTimeOut(ByVal NewTimeOut As Integer)


mobjConn.CommandTimeOut = NewTimeOut


End Property


Public Property Get CurrentDatabase() As Integer


'Read-only property
CurrentDatabase = mstrCurrentDatabase


End Property


Public Property Get CurrentServer() As String


'Read-only property
CurrentServer = mstrCurrentServer


End Property


Public Property Get DatabaseType() As String


DatabaseType = mstrDatabaseType


End Property


Public Property Let DatabaseType(ByVal NewValue As String)


mstrDatabaseType = NewValue


End Property


Public Property Get IntegratedSecurity() As Boolean


IntegratedSecurity = mblnIntegratedSecurity


End Property


Public Property Let IntegratedSecurity(ByVal NewValue As Boolean)


mblnIntegratedSecurity = NewValue


End Property


Public Sub CloseDB()


'Close connection to database.
On Error Resume Next
If Not mobjConn Is Nothing Then
If mobjConn.State And adStateOpen Then
'Connection is defined and still open; close it.
mobjConn.Close
End If
End If
On Error GoTo 0


End Sub


Public Sub ShowErrorMessages(ByVal StandardErrorObject As VBA.ErrObject, _
ByVal SourceModule As String, ByVal SourceMethod As String)


'Construct a comprehensive error message based on the passed objects.
Dim strMsg As String


'Handle the standard error, if any.
If StandardErrorObject.Number <> 0 Then
strMsg = "Error: " & CStr(Err.Number) & vbCrLf & vbCrLf & "Description: " & _
Err.Description & vbCrLf & vbCrLf
End If


'Include the database-related errors, if any.
If Not (gobjDB Is Nothing) Then
strMsg = strMsg & gobjDB.ADOErrors()
End If


'Finally, tack on the module/method names.
strMsg = strMsg & SourceModule & "::" & SourceMethod & vbCrLf


Err.Clear


MsgBox strMsg, vbCritical, "Contact Technical Support For Assistance"


End Sub


Public Function ADOErrors() As String


'Return a fully formatted string containing any current ADO errors in the collection.
Dim lngCount As Long
Dim objErr As Object 'ADODB.Error
Dim strReturn As String


strReturn = vbNullString


For Each objErr In mobjConn.Errors
strReturn = strReturn & CStr(objErr.Number) _
& vbCrLf & objErr.Description & vbCrLf & vbCrLf
Next objErr
mobjConn.Errors.Clear


ADOErrors = strReturn


End Function


Public Function OpenDB(Optional ByVal DatabaseType As String, _
Optional ByVal TargetServer As String = "", _
Optional ByVal TargetDatabase As String = "", _
Optional ByVal IntegratedSecurity As Boolean = False) As Boolean


'Open a connection to the specified server and database, if not already open.
'If the parameters are not specified, then just re-use the last connection
'string that was created.
Dim blnNewConnect As Boolean
Dim blnReturn As Boolean
Dim strDataSource As String
Dim strDB As String
Dim strConn As String


blnReturn = True
blnNewConnect = True


On Error GoTo ODError


If Not mobjConn Is Nothing Then
If mobjConn.State And adStateOpen Then
'Connection is alread defined and opened.
blnNewConnect = False
End If
End If


If blnNewConnect Then
'Must create a new connection
If TargetServer = "" Or TargetDatabase = "" Then
'Calling routine has not specified Server or Database values;
' default to last used.
If Len(mstrConnectionString) > 0 Then
strConn = mstrConnectionString
Else
'If full connection string is blank, use the individual Server/Environment and
' Database variables to determine connection.
strConn = BuildConnectionString(mstrDatabaseType, mstrCurrentServer, _
mstrCurrentDatabase, mblnIntegratedSecurity)
End If
Else
'Build connection string, based on passed arguments
strConn = BuildConnectionString(DatabaseType, TargetServer, TargetDatabase, _
mblnIntegratedSecurity)
End If
mobjConn.ConnectionString = strConn
mobjConn.Open
End If


ODResume:
OpenDB = blnReturn
Exit Function


ODError:
blnReturn = False
ShowErrorMessages Err, mstrModuleName, "OpenDB"
Resume ODResume


End Function


Public Function BuildConnectionString(ByVal DatabaseType As DBaseType, _
ByVal TargetServer As String, _
ByVal TargetDatabase As String, _
ByVal IntegratedSecurity As Boolean, _
Optional ByVal UserID As String, _
Optional ByVal Password As String) As String


Dim strExtn As String


'Construct a full connection string, set local properties, and
'return string to calling routine.




'Build connection string
Select Case DatabaseType
Case 2 '"SQLServer"
'Microsoft SQL Server; use proper network library.
If Len(UserID) Then
mstrConnectionString = "Network Library=DBMSSOCN;" & _
"PROVIDER=SQLOLEDB;DATA SOURCE=" & TargetServer & _
";INITIAL CATALOG=" & TargetDatabase & _
";User Id=" & UserID & ";Password=" & Password & ";"
Else
'"Provider=SQLNCLI10;"
mstrConnectionString = "Network Library=DBMSSOCN;Provider=SQLOLEDB;" & _
"Server=" & TargetServer & ";" & _
"Database=" & TargetDatabase & ";" & _
"Trusted_Connection=yes;"
End If
Case 1 '"Access"
strExtn = UCase(Mid(TargetDatabase, InStrRev(TargetDatabase, ".") + 1))


Select Case glngAppVersion
Case 10
If Len(Password) Then
mstrConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & TargetServer & TargetDatabase & ";" & _
"Jet OLEDB:Database Password=" & Password & ";"
Else
mstrConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & TargetServer & TargetDatabase & ";"
End If
Case Is > 10
If Len(Password) Then
mstrConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & TargetServer & TargetDatabase & ";" & _
"Jet OLEDB:Database Password=" & Password & ";"
Else
mstrConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & TargetServer & TargetDatabase & _
";Persist Security Info=False;"
End If
End Select
Case "Excel"
strExtn = UCase(Mid(TargetDatabase, InStrRev(TargetDatabase, ".") + 1))
Select Case strExtn
Case "XLSX"
mstrConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & TargetDatabase & ";" & _
"Extended Properties = 'Excel 12.0 Xml;HDR=YES'"
Case "XLSB"
mstrConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & TargetDatabase & ";" & _
"Extended Properties = 'Excel 12.0;HDR=YES'"


Case "XLSM"
mstrConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & TargetDatabase & ";" & _
"Extended Properties = 'Excel 12.0 Macro;HDR=YES'"


Case "XLS"
'to connect Excel 97-2003 from Excel 2007+
mstrConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & TargetDatabase & ";" & _
"Extended Properties = 'Excel 8.0;HDR=YES'"
End Select
Case Else
'Some other server; modify to accommodate.
mstrConnectionString = "Provider=SQLOLEDB;Server=" & TargetServer & _
";Database=" & TargetDatabase & ";Trusted_Connection=yes;"
End Select


'Update the module variables
mstrCurrentServer = TargetServer
mstrCurrentDatabase = TargetDatabase
mstrDatabaseType = DatabaseType
mblnIntegratedSecurity = IntegratedSecurity
BuildConnectionString = mstrConnectionString


End Function


Public Function ExecuteSPWithADOCommand(StoredProcName As String, _
OutputParameter As String, OutputValue As Variant, _
ParamArray InputParameters() As Variant) As Boolean


' Execute a stored procedure, using an ADO command object. The InputParameters
' paramarray must contain pairs of data (i.e. element 0 should be Parameter name,
' with leading '@', and element 1 should be the associated parameter value; then
' element 2 is the next parameter name, element 3 is the next parameter value, etc.).
' Also allows for a single Output parameter and associated return value
' (OutputParmeter and OutputValue ByRef parameters). Remember
' to prefix the OutputParmeter name with '@', same as the input parameters.


Dim objCmd As Object 'ADODB.Command
Dim blnReturn As Boolean
Dim lngParam As Long
Dim strParamName As String
Dim varParamValue As Variant


blnReturn = True


On Error GoTo ESPError


If OpenDB() Then
'Set objCmd = New ADODB.Command
Set objCmd = CreateObject("ADODB.Command")
With objCmd
.ActiveConnection = mobjConn
.CommandText = StoredProcName
.CommandType = adCmdStoredProc
.Parameters.Refresh
'Define the Input Parameters
For lngParam = 0 To UBound(InputParameters) Step 2
.Parameters(InputParameters(lngParam)).Value = _
InputParameters(lngParam + 1)
Next lngParam
'Define the single allowed output parameter, if any
If Len(Trim(OutputParameter)) > 0 Then
.Parameters(OutputParameter).Direction = adParamOutput
End If
'Execute the stored procedure
.Execute
End With


'Retrieve the value of the output parameter (if any)
If Len(Trim(OutputParameter)) > 0 Then
OutputValue = objCmd.Parameters(OutputParameter).Value
Else
OutputValue = vbNullString
End If
Else
'No database connection could be established, but no error
' was raised (should never happen).
OutputValue = vbNullString
blnReturn = False
End If


ESPResume:
ExecuteSPWithADOCommand = blnReturn
Set objCmd = Nothing
CloseDB
Exit Function


ESPError:
blnReturn = False
ShowErrorMessages Err, mstrModuleName, "ExecuteSPWithADOCommand"
Resume ESPResume


End Function


Function GetRecordset(strSQL As String) As Object 'ADODB.Recordset
'Return a disconnected recordset from the database.
Dim objRSet As Object 'ADODB.Recordset


On Error GoTo GRError
mlngRecordCount = 0


If OpenDB() Then
'Set objRSet = New ADODB.Recordset
Set objRSet = CreateObject("ADODB.Recordset")
objRSet.CursorLocation = adUseClient
objRSet.Open strSQL, mobjConn, adOpenDynamic
mlngRecordCount = objRSet.RecordCount
Set GetRecordset = objRSet
objRSet.ActiveConnection = Nothing
End If


GRResume:
CloseDB
Exit Function


GRError:
ShowErrorMessages Err, mstrModuleName, "GetRecordset"
Resume GRResume


End Function


Public Function GetRecordsetToArray(strSQL As String) As Variant
' Return recordset data into an array. If, for any reason, the recordset
' does not return any data, this function simply creates a single element
' array and populates it with "No matching records...".


Dim objRSet As Object 'ADODB.Recordset
Dim varArrData As Variant
Dim lngX As Long


On Error GoTo GRAError


If OpenDB() Then
'Set objRSet = New ADODB.Recordset
Set objRSet = CreateObject("ADODB.Recordset")
With objRSet
.CursorLocation = adUseClient
.LockType = adLockReadOnly
.Open strSQL, mobjConn, adOpenstatic


If Not (objRSet.EOF) Then
'Disconnect the recordset
.ActiveConnection = Nothing
'Get the field count
lngX = .fields.Count
varArrData = .getrows()
Else
'Recordset is empty; create dummy array record
ReDim varArrData(0, 0)
varArrData(0, 0) = "No matching records found in the database"
End If
End With
Else
'Connection failed for some reason; in order not to crash the
' calling routine, create dummy array record.
ReDim varArrData(0, 0)
varArrData(0, 0) = "Could not open database connection"
End If


GRAResume:
GetRecordsetToArray = varArrData
CloseDB
Exit Function


GRAError:
ShowErrorMessages Err, mstrModuleName, "GetRecordsetToArray"
Resume GRAResume


End Function


Public Function GetMultipleRecordsets(strSQL As String, Optional ByVal GetRecordCount As Boolean = False) As Object 'ADODB.Recordset


'Allows for multiple recordsets to be returned to the calling routine.
'IMPORTANT - Although this method is similar to the GetRecordSet function,
' there are significant differences.
' 1. Do not disconnect the Recordset (i.e. don't set ActiveConnection to Nothing).
' 2. You must not close the database connection! It must remain open so that
' the calling routine can retrieve all of the resultsets in the returned Recordset.
' IT IS UP TO THE CALLING ROUTINE TO CLOSE THE CONNECTION WHEN DONE.


Dim objRSet As Object 'ADODB.Recordset


On Error GoTo GMRError
mlngRecordCount = 0
If OpenDB() Then
'Set objRSet = New ADODB.Recordset
Set objRSet = CreateObject("ADODB.Recordset")
If GetRecordCount Then
objRSet.CursorLocation = adUseClient
objRSet.Open strSQL, mobjConn
mlngRecordCount = objRSet.RecordCount
Else
objRSet.Open strSQL, mobjConn
End If
Set GetMultipleRecordsets = objRSet
End If


GMRResume:
'REMEMBER! Do NOT close the connection here. Calling routine must close it.
Exit Function


GMRError:
ShowErrorMessages Err, mstrModuleName, "GetMultipleRecordsets"
Resume GMRResume


End Function


Public Function ExecuteActionQuery(SQLToExecute As String, Optional CloseDatabase As Boolean = True) As Boolean


'Execute an action query, or stored procedure, which is not expected
'to return a resultset.
Dim blnReturn As Boolean


blnReturn = True


On Error GoTo EAQError


If OpenDB() Then
mobjConn.Execute SQLToExecute
End If


EAQResume:
If CloseDatabase Or Not blnReturn Then CloseDB
ExecuteActionQuery = blnReturn
Exit Function


EAQError:
blnReturn = False
ShowErrorMessages Err, mstrModuleName, "ExecuteActionQuery"
Resume EAQResume


End Function


Public Property Get SQLConnection() As Object 'ADODB.Connection


'Return the actual connection object, if requested by
' calling routine.
If Not mobjConn Is Nothing Then
On Error Resume Next
Set SQLConnection = mobjConn
On Error GoTo 0
End If


End Property[/vb]


and in Standard module


[vb]Option Explicit
'Global data access class object
Public gobjDB As clsDBConnection_LBinding
Public glngAppVersion As Long


Public Enum DBaseType
Access = 1
SQLServer = 2
Excel = 3
End Enum


Public Sub InitializeDatabase(ByVal DBType As DBaseType)


Dim strDatabaseType As DBaseType
Dim strServerName As String
Dim strDatabaseName As String
Dim blnIntegratedSecurity As Boolean


' Access = 1:SQLServer = 2:Excel = 3


If Not gobjDB Is Nothing Then
If gobjDB.DatabaseType = CStr(DBType) Then
GoTo Xit
End If
End If


strDatabaseType = DBType
strDatabaseName = "MyDB"
blnIntegratedSecurity = False
strServerName = "100.100.10.10"


If strDatabaseType = Access Or strDatabaseType = Excel Then
If Not CBool(Len(Dir(strServerName & strDatabaseName, 0))) Then
MsgBox "Database" & vbLf & strDatabaseName & vbLf & "does not exist.", vbInformation, "Database Connect"
GoTo Xit
End If
End If


glngAppVersion = Val(Application.Version)


Set gobjDB = New clsDBConnection_LBinding
gobjDB.BuildConnectionString strDatabaseType, strServerName, _
strDatabaseName, blnIntegratedSecurity, gstrUID, gstrDBPwd
Xit:


End Sub


Public Sub DestroyDatabase()
'//do not forget to call this procedure in the workbook close event just to ensure that the db has been closed.
If Not (gobjDB Is Nothing) Then
On Error Resume Next
gobjDB.CloseDB
Set gobjDB = Nothing
End If


End Sub

Display More

**pike** · Aug 22nd 2015

Re: Your Favourite VBA Class Module Example

Old example I saved from mikerickerson

clsCustomtextbox class module

Code

Public WithEvents myBox As MSForms.TextBox
Event DEntered()
Property Get HasD()
      HasD = myBox.Text Like "*D"
End Property
Private Sub myBox_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
      If Not (Me.HasD) And Chr(KeyAscii) = "D" Then RaiseEvent DEntered
End Sub

in userform

Code

Public WithEvents CustomTextBox As clsCustomtextbox
Private Sub CustomTextBox_DEntered()
     MsgBox "D was pressed"
End Sub

and has to have textbox1

Code

Private Sub UserForm_Initialize()
      Set CustomTextBox = New clsCustomtextbox
      Set CustomTextBox.myBox = textbox1
end sub

**pike** · Aug 28th 2015

Userforms Selected Commandbutton Object

Class clsFrmCtls

Code

Option Explicit
Public mName
Public mFrm As Object
Public WithEvents mCommandbutton As MSForms.CommandButton


Private Sub mCommandButton_Click()
     Call mFrm.SelectedChange(mName)
End Sub

or

Code

Option Explicit
Public mName
Public mFrm As Object
Public Event SelectedChange(objCtr)
Public WithEvents mCommandbutton As MSForms.CommandButton


Private Sub mCommandButton_Click()
    RaiseEvent mFrm.SelectedChange(mName)
End Sub

userform

Code

Option Explicit
Dim mcolEvents As Collection
Public Sub SelectedChange(objCtr)
    MsgBox objCtr
    MsgBox Me(objCtr).Caption


End Sub


Private Sub UserForm_Initialize()
    Dim cCBEvents As clsFrmCtls
    Dim intCon


    Set mcolEvents = New Collection
    For Each intCon In Array(1, 2, 3, 4, 5, 8, 9, 10, 11, 12, 14, 15, 16, 17, 18, 20, 21, 22, 23, 24)
        Set cCBEvents = New clsFrmCtls
        Set cCBEvents.mFrm = Me
        cCBEvents.mName = Me.Controls("CommandButton" & intCon).Name
        Set cCBEvents.mCommandbutton = Me.Controls("CommandButton" & intCon)
        mcolEvents.Add cCBEvents
    Next intCon


End Sub

Display More

**pike** · Aug 29th 2015

Class Module E_Num and impliments

clear intent for using Impliments and E_Num in class moduleshttp://stackoverflow.com/quest…e-implements-in-excel-vba

which is very handy

**pike** · Sep 11th 2015

Resizable userform VBA Class Module Example

This example is just brilliant ,,, a resizable userform in real time .its now my numero uno fav

workbook at http://www.ozgrid.com/forum/sh…96725&p=756114#post756114

Code

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'//*******************************************************************************************************************
'//* This code is Windows API - not VBA
'//* Detailed comments are not included. Recommended that the code is not used rather than trying to adapt
'//* due to the complexity. Get a call to an API function wrong and you WILL crash Excel, and possibly
'//* Windows as well!
'//-------------------------------------------------------------------------------------------------------------------
Option Explicit


'//* Retrieves a handle to the top-level window whose class name and window name match the specified strings.
'//* This function does not search child windows. This function does not perform a case-sensitive search.
'//* http://msdn.microsoft.com/en-us/library/windows/desktop/ms633499(v=vs.85).aspx
Private Declare Function FindWindow Lib _
                                    "User32" Alias "FindWindowA" ( _
                                    ByVal lpClassName As String, _
                                    ByVal lpWindowName As String) As Long


'//* Retrieves a handle to the top-level window whose class name and window name match the specified strings.
'//* This function does not search child windows. This function does not perform a case-sensitive search.
'//* http://msdn.microsoft.com/en-us/library/windows/desktop/ms633584(v=vs.85).aspx
Private Declare Function GetWindowLong Lib _
                                       "User32" Alias "GetWindowLongA" ( _
                                       ByVal hwnd As Long, _
                                       ByVal nIndex As Long) As Long


'//* Changes an attribute of the specified window. The function also sets the 32-bit (long) value at the
'//* specified offset into the extra window memory
'//* http://msdn.microsoft.com/en-us/library/windows/desktop/ms633584(v=vs.85).aspx
Private Declare Function SetWindowLong Lib _
                                       "User32" Alias "SetWindowLongA" ( _
                                       ByVal hwnd As Long, _
                                       ByVal nIndex As Long, _
                                       ByVal dwNewLong As Long) As Long


'//* The GetSystemMenu function allows the application to access the window menu (also known as the
'//* System menu or the Control menu) for copying and modifying.
Private Declare Function GetSystemMenu Lib _
                                       "User32" ( _
                                       ByVal hwnd As Long, _
                                       ByVal bRevert As Long) As Long


'//* Deletes an item from the specified menu. If the menu item opens a menu or submenu, this
'//* function destroys the handle to the menu or submenu and frees the memory used by the menu
'//* or submenu
Private Declare Function DeleteMenu Lib _
                                    "User32" ( _
                                    ByVal hMenu As Long, _
                                    ByVal nPosition As Long, _
                                    ByVal wFlags As Long) As Long


Private Declare Function DrawMenuBar Lib _
                                     "User32" ( _
                                     ByVal hwnd As Long) As Long


Private Declare Function SetFocus Lib _
                                  "User32" ( _
                                  ByVal hwnd As Long) As Long


Private Declare Function SendMessage Lib _
                                     "User32" Alias "SendMessageA" ( _
                                     ByVal hwnd As Long, _
                                     ByVal wMsg As Long, _
                                     ByVal wParam As Integer, _
                                     ByVal lParam As Long) As Long


Private Declare Function ReleaseCapture Lib _
                                        "User32" () As Long




'// Window styles
Private Const GWL_STYLE As Long = (-16)
Private Const WS_CAPTION As Long = &HC00000
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000


'// Close menu constant
Private Const SC_CLOSE  As Long = &HF060


'//Variables to store the various selections/options
Dim mbSizeable          As Boolean
Dim mbCaption           As Boolean
Dim mbMaximize          As Boolean
Dim mbMinimize          As Boolean
Dim mbCloseBtn          As Boolean
Dim moForm              As Object
Dim mhWndForm           As Long


Private Const SWP_NOMOVE As Long = 2
Private Const SWP_NOSIZE As Long = 1


'// Constants to support captionless drag
Private Const WM_NCLBUTTONDOWN As Long = &HA1         '//*left button down
Private Const HTCAPTION As Long = 2


'// A couple of True defaults
Private Sub Class_Initialize()
   mbCaption = True
   mbCloseBtn = True
End Sub


Public Property Get Handle() As Long


   Handle = mhWndForm


End Property


'// Set reference to form
Public Property Set Form(oForm As Object)


   '// Get the userform's window handle
   '// Class name is optional - it is just used to limit the possible
   '// matches. Consdier than the default userform Caption is 'UserForm1'
   '// there can be plenty of opportunies to find the wrong userform
   If Val(Application.Version) < 9 Then
      mhWndForm = FindWindow("ThunderXFrame", oForm.Caption)   'XL97
   Else
      '//   mhWndForm = FindWindow("ThunderDFrame", oForm.Caption)   'XL2000+
      mhWndForm = FindWindow(vbNullString, oForm.Caption)   'XL2000+
   End If


   'Remember the form for later
   Set moForm = oForm


   'Set the form's style
   SetFormStyle


End Property


Public Property Let Sizeable(bSizeAble As Boolean)
   mbSizeable = bSizeAble
   SetFormStyle
End Property


Public Property Get Sizeable() As Boolean
   Sizeable = mbSizeable
End Property


Public Property Let ShowCaption(bCaption As Boolean)
   mbCaption = bCaption
   SetFormStyle
End Property




Public Property Get ShowCaption() As Boolean
   ShowCaption = mbCaption
End Property


Public Property Let ShowMaximizeBtn(bMaximize As Boolean)
   mbMaximize = bMaximize
End Property


Public Property Get ShowMaximizeBtn() As Boolean
   ShowMaximizeBtn = mbMaximize
End Property


Public Property Let ShowMinimizeBtn(bMinimize As Boolean)
   mbMinimize = bMinimize
End Property


Public Property Get ShowMinimizeBtn() As Boolean
   ShowMinimizeBtn = mbMinimize
End Property


Public Property Let ShowCloseBtn(bCloseBtn As Boolean)
   mbCloseBtn = bCloseBtn
End Property


Public Property Get ShowCloseBtn() As Boolean
   ShowCloseBtn = mbCloseBtn
End Property


'// Set the forms window style
Public Sub SetFormStyle()


   Dim lStyle           As Long
   Dim hMenu            As Long


   '// Have we got a form defined?
   If mhWndForm = 0 Then Exit Sub


   '// Get the basic window style
   lStyle = GetWindowLong(mhWndForm, GWL_STYLE)


   '// Build up the basic window style flags for the form
   SetBit lStyle, WS_CAPTION, mbCaption
   SetBit lStyle, WS_THICKFRAME, mbSizeable
   SetBit lStyle, WS_MINIMIZEBOX, mbMinimize
   SetBit lStyle, WS_MAXIMIZEBOX, mbMaximize


   '// Set the basic window styles
   SetWindowLong mhWndForm, GWL_STYLE, lStyle


   '// Close button handled differently
   If mbCloseBtn Then
      '// Want it, so reset the control menu
      hMenu = GetSystemMenu(mhWndForm, 1)
   Else
      '// Don't want it, so delete it from the control menu
      hMenu = GetSystemMenu(mhWndForm, 0)
      DeleteMenu hMenu, SC_CLOSE, 0&
   End If


   '// Forc the Window to redraw
   DrawMenuBar mhWndForm


   '// Make sure it has focus
   SetFocus mhWndForm


End Sub


'// Set or clear a bit from a style flag
Private Sub SetBit(ByRef lStyle As Long, ByVal lBit As Long, _
                   ByVal bOn As Boolean)
   If bOn Then
      lStyle = lStyle Or lBit
   Else
      lStyle = lStyle And Not lBit
   End If


End Sub


Public Sub SetDraggable()


   '//* based on www.allapi.net
   Dim lRetVal          As Long
   Call ReleaseCapture
   'send a '//*left mouse button down on caption'//*-message to the form
   lRetVal = SendMessage(mhWndForm, WM_NCLBUTTONDOWN, HTCAPTION, 0)


End Sub

Display More

___________________________________________________________________

Original idea by Stephen Bullen years ago - it's just something I've chopped/changed and generally mutilated over the years.

A fuller version also includes Transparency, Max/Min form sizes (without the flashing borders when resized in the Resize event (but may flicker in the client area), lock the userform in position - I'll tidy up a sample workbook and upload a little later.

cytop · Sep 11th 2015

Re: Your Favourite VBA Class Module Example

That sample...

There is code to limit the Max/Min size of the userform. This uses the Windows API - read the various comments marked as 'ESSENTIAL' otherwise say goodbye to your workbook... or at least that version in memory.

2nd attachment for Pike - resize a fixed border userform when the zoom factor is changed.

**pike** · Nov 5th 2015

Chart Hooks Mouse Pointer to scroll

This is very cool
In the example workbook attached just click in the chart to enable the chart manipulation
Class module below for the hook and there are two auxiliary modules in the workbook

Code

'
' Description:  Class to demonstrate converting between the various
'               chart coordinate systems
'
' Authors:      Rob Bovey, www.appspro.com
'               Stephen Bullen, www.oaltd.co.uk
'
Option Explicit


''''''''''''''''''''''''''''''''''''''''''''''''''
' Module-level Declarations Follow
''''''''''''''''''''''''''''''''''''''''''''''''''


'Module variable to hook a chart's events
Public WithEvents mchtChart As Chart




''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: As the user moves the mouse around the chart, convert
'           the mouse coordinates to data and drawing object
'           coordinates, updating the status bar and moving a circle.
'
' Date          Developer       Action
' --------------------------------------------------------------
' 05 Jun 08     Stephen Bullen  Created
'
Private Sub mchtChart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)


    Dim dZoom As Double
    Dim dXVal As Double
    Dim dYVal As Double
    Dim dPixelSize As Double


    On Error Resume Next


    'The active window zoom factor
    dZoom = ActiveWindow.Zoom / 100


    'The pixel size, in points
    dPixelSize = PointsPerPixel


    'Mouse coordinates to Data coordinates
    With mchtChart
        dXVal = .Axes(xlCategory).MinimumScale + (.Axes(xlCategory).MaximumScale - .Axes(xlCategory).MinimumScale) * (X * dPixelSize / dZoom - (.PlotArea.InsideLeft + .ChartArea.Left)) / .PlotArea.InsideWidth
        dYVal = .Axes(xlValue).MinimumScale + (.Axes(xlValue).MaximumScale - .Axes(xlValue).MinimumScale) * (1 - (Y * dPixelSize / dZoom - (.PlotArea.InsideTop + .ChartArea.Top)) / .PlotArea.InsideHeight)
    End With


    Application.StatusBar = "(" & Application.Round(dXVal, 2) & ", " & Application.Round(dYVal, 2) & ")"
    Sheets("3D Rotation").Range("K26").Value = Application.Round(dXVal, 2)
    Sheets("3D Rotation").Range("K27").Value = Application.Round(dYVal, 2)
    'Mouse coordinates to Drawing Object Points.
    'Move the drawing object if the shift key is held down
    If Shift = 1 Then
        With mchtChart
            dXVal = (X * dPixelSize / dZoom - .ChartArea.Left)
            dYVal = (Y * dPixelSize / dZoom - .ChartArea.Top)


            With .Shapes("ovlPointer")
                .Left = dXVal - .Width / 2
                .Top = dYVal - .Height / 2
            End With
        End With
    End If


End Sub

Display More

CHEECOCHONGO · Jan 19th 2016

Re: Resizable userform VBA Class Module Example

I like this but for us dummy's, what exactly is it and how can we put these codes to use for us in the future?

CHEECOCHONGO · Jan 19th 2016

Re: Your Favourite VBA Class Module Example

Thanks for all these codes. I can see a lot of work went into writing these codes. It is very kind of you to post them for others like myself who are trying to learn.

**pike** · Jan 19th 2016

Re: Your Favourite VBA Class Module Example

Hi,
Class modules allow you to create your own objects in your application which can have their own properties and methods like any other object

http://www.cpearson.com/excel/classes.aspx

The one point of creating classes is so that you can encapsulate your code in one place (error handling, updating of data). Classes can help if you develop an application for others . The user doesn't need to worry about how the object works, they only need to understand how to use it's methods and properties (unless they also created the class).

hope that helps

**pike** · May 8th 2016

userform class RaiseEvent OnEnter control

userform class event code from Jaafar Tribak RaiseEvent on enter or exit of control.
This is especially useful when using multiple cascading combobox list which are dependant on each others selection
combobox's don't have this feature

Userform 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


Sub Combobox_List(myCtrl As Control)


    Dim myRng As Range, objCtrl As Control
    Set myRng = ThisWorkbook.Names("petSkill").RefersToRange
    Dim e, v
    With myRng
        v = .Value
    End With
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For Each e In v
            If Not .exists(e) Then .Add e, Nothing
        Next e
        For Each objCtrl In Me.Controls
            If TypeName(objCtrl) Like "ComboBox" And Not objCtrl.Name Like myCtrl.Name And .exists(objCtrl.Value) Then
                .Remove (objCtrl.Value)
            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

Display More

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 & ")"
    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

Display More

**pike** · May 9th 2016

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

Display More

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

Display More

**Ger Plante** · May 9th 2016

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

**pike** · May 9th 2016

Re: Your Favourite VBA Class Module Example

Just stumbled across it here.

**pike** · May 11th 2016

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

Display More

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

**pike** · May 28th 2016

Re: Your Favourite VBA Class Module Example

another gem from Jaafar
Class for Trapping Mouse Clicks on Cells

Your Favourite API or VBA Class Module Example

Participate now!

Share