Need to add _AfterUpdate events to a dynamically-created class

[Matrovsky]

Given: I have a dynamically-created userform that makes an entry box for each column of the underlying sheet. It's just an upgraded version of Excel's built-in data entry form with added search functions and some data validation.

Problem: I need to add an AfterUpdate event to the ComboBox class I'm already using. I've tried the techniques posted here by the inestimable Jaafar Tribak, but since I cribbed most of the code to start with and have only a rudimentary understanding of how hooks work, I keep breaking things instead.

Rationale: I'm looking for _AfterUpdate instead of the existing _Change event because there are formulae in the spreadsheet that populate ComboBoxes in the userform based on entries made in other ComboBoxes. So, for example, the user types '4' in ComboBox2 , triggering the _Change event, which writes a '4' to cell A2. Cell B2 now shows a calculated value (8), which should then appear back in the userform in ComboBox3. I have all this working fine, but the _Change event fires after every keypress, writing incomplete/unvalidated data in A1 and creating cascading #VALUE errors from B2.

	A	B
1	4	8	'=A1*2
2	3	6	'=A2*2

Here's the [relevant portions of the] code I'm starting from:

API Module for dynamic form creation (md_Common_API):

Option Explicit
Option Base 1
Option Compare Text

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
#End If
 
Private Const SM_CXSCREEN = 0 'Screen width
Private Const SM_CYSCREEN = 1 'Screen height


 #If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetDC Lib "user32" _
    (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" _
    (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" _
    (ByVal hwnd As Long, ByVal hDC As Long) As Long
 #Else
    Private Declare Function GetDC Lib "user32" _
    (ByVal hwnd As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" _
    (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" _
    (ByVal hwnd As Long, ByVal hDC As Long) As Long
#End If
Private Const LOGPIXELSX = 88 'Pixels/inch in X
'A point is defined as 1/72 inches
Private Const POINTS_PER_INCH As Long = 72
'For 64-bit Excel 2010 and later
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" _
() '() '() '    (ByVal Locale As Long, ByVal LCType As Long, _
    ByVal lpLCData As String, ByVal cchData As Long) As Long

    Private Declare PtrSafe Function GetUserDefaultLCID Lib "kernel32" () As Long
#Else
    Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" _
() '() '() '     (ByVal Locale As Long, ByVal LCType As Long, _
     ByVal lpLCData As String, ByVal cchData As Long) As Long

    Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
#End If
Private Const LOCALE_SSHORTDATE = &H1F


Function DateformatProcedure()
    Dim SDateFormat As String * 9
    Dim lLocale As Long
    Dim LocaleInfo As Long
    Application.ScreenUpdating = False
    'System date format using API functions
    lLocale = GetUserDefaultLCID()
    LocaleInfo = GetLocaleInfo(lLocale, &H1F, SDateFormat, 9)
'    SDateFormat = Replace(SDateFormat, Chr(0), "")
    'Regional date format
    Dim DateOrder As String
    Dim DateSeparator As String
    Dim RDateFormat As String
    With Application
        DateSeparator = "-" '.International(xlDateSeparator)
        Select Case .International(xlDateOrder)
            Case Is = 0
              DateOrder = "month-day-year"
              RDateFormat = "mmm" & DateSeparator & "dd" & DateSeparator & "yy"
            Case Is = 1
              DateOrder = "day-month-year"
              RDateFormat = "dd" & DateSeparator & "mmm" & DateSeparator & "yy"
            Case Is = 2
              DateOrder = "year-month-day"
              RDateFormat = "yy" & DateSeparator & "mm" & DateSeparator & "dd"
            Case Else
              DateOrder = "Error"
        End Select
    End With
    DateformatProcedure = RDateFormat
End Function
'The size of a pixel, in points
Function PointsPerPixel() As Double
    Dim hDC As Long
    Dim lDotsPerInch As Long
    hDC = GetDC(0)
    lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
    PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
    ReleaseDC 0, hDC
End Function
'The width of the screen, in pixels
Function ScreenWidth() As Long
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function
Function ScreenHeight() As Long
    ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
End Function

Class code (cl_dynamicActiveX):

Private Sub DynamicCBX_Change()
   
   Dim cbxno As Long  
   Dim alertTime As Date

   With DynamicCBX
      cbxno = CInt(Right(.Name, Len(.Name) - 8)) ' get number of 
   End With
   With uf_DataEntryForm
      If .LabelItem.Caption = "Criteria" Or .LabelItem.Caption = "Search" Then
         '******************************************************
         'Search function - not relevant to this question
         '******************************************************
         If Len(DynamicCBX.Text) > 1 Then
               Call DataFind
            If searchResultsClicked = False Then 
               Call Trigger_ListDatabase
               Exit Sub
            End If
         Else
               Exit Sub
         End If
      Else
         ''******************************************************
         'Capture change and return to the worksheet
         ''******************************************************
         Call WriteChange(cbxno, DynamicCBX.Text)  'My current workaround uses an OnTime timer in the WriteChange() sub to postpone the event until after the user finishes typing. It's both inelegant and resource-intensive.
         uf_DataEntryForm.CommandButton3.Enabled = True
      End If
   End With
   Call UpdateControls_DEF
End Sub

Private Sub DynamicCBX_AfterUpdate() 'This is what I need to create

UpdateComboValues 'Grabs calculated values from worksheet and inserts into ComboBoxes
End Sub


 ''******************************************************
 'These two subs aren't relevant to the question, but included for completeness. It's just code to track the currently-selected ComboBox:
 ''******************************************************
Private Sub DynamicTBX_KeyDown(ByVal KeyCode As MsForms.ReturnInteger, ByVal Shift As Integer)
   Dim cbxno As Long
   If Startup = False Then
      If KeyCode.Value = 9 Or KeyCode.Value = 13 Then
         With DynamicTBX
               cbxno = CInt(Right(.Name, Len(.Name) - 8))
         End With
         LastSelectedCombo = cbxno + 1
      End If
   End If
End Sub

Private Sub DynamicCBX_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   Dim cbxno As Long

   If Startup = False Then
      With DynamicTBX
         cbxno = CInt(Right(.Name, Len(.Name) - 8))
      End With
      LastSelectedCombo = cbxno

   End If
End Sub

Module code to create form:
To save some scrolling, the important bit is:

               Cbx = "ComboBox" & i
               Set objtext = .Controls.Add(bstrprogid:="forms.ComboBox.1", Name:=Cbx, Visible:=True)
               With objtext...

Complete module code:

Sub FormCreate()
   Dim i As Long, n As Long
   Dim Lbl As Variant, Cbx As Variant
   Dim objtext As Control
   Dim TopPosition As Long, BottomPosition As Long
   Dim sValue As Long

   Set wbk = ActiveWorkbook
   Set ws = wbk.Sheets("MAD")
   Set ws2 = wbk.Sheets("Lists")
   Set ws3 = wbk.Sheets("SearchData")
   rs = 0: cs = 0
   Startup = True ' Flag to prevent recursive updates (both form and pivot tables) on open
  
   With Application
      .ScreenUpdating = False
      .DisplayAlerts = False
      .EnableEvents = True
      
   End With
   With ws
      
      'Check for and clear rows with no entries
         For i = 1 To 10
            UpdateRow = ws.Columns("A").SpecialCells(xlCellTypeConstants).Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
            If WorksheetFunction.CountA(Range(Cells(UpdateRow, 3), Cells(UpdateRow, 50))) = 0 Then
               ws.Cells(UpdateRow, 2).ClearContents
            End If
         Next i
         
      'Locate data
         With ws.Columns("A").SpecialCells(xlCellTypeConstants)
            rmax = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
            r = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
         End With
         cmax = .UsedRange.Columns.Count
         c = .UsedRange.Column
         For i = 1 To cmax
               If .Cells(rmax, c + i - 1).SpecialCells(xlCellTypeConstants).Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row >= rs Then
                  rs = .Columns("A").SpecialCells(xlCellTypeConstants).Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
               End If
         Next i
         
         For i = 1 To rmax
               If .Cells(r + i - 1, Columns.Count).End(xlToLeft).Column >= cs Then
                  cs = .Cells(r + i - 1, Columns.Count).End(xlToLeft).Column
               End If
         Next i
               
         For i = 1 To rs
               If Application.CountA(.Rows(i)) = cs Then
                  r = i
                  Exit For
               End If
         Next i
      
         rs = rs - r
         cs = cs - c + 1
      End With
   '*******************************************
   'Variable userform size using API Function
   '*******************************************
      Dim ufWidthMax As Double, ufHeightMax As Double
      ufWidthMax = Int(ScreenWidth * PointsPerPixel)
      ufHeightMax = Int(ScreenHeight * PointsPerPixel) * 240 / 300
      With ws
        Dim Lenmax1 As Double, Lenmax2 As Double, frameWidth As Double
        Dim cRange As Range
        
        Lenmax1 = 0
        Erase DataHeader
        ReDim Preserve DataHeader(cs)
            
        For i = 1 To cs
           DataHeader(i) = ws.Cells(r, c + i - 1).Value
        Next i
        Erase myNumberFormat
        ReDim Preserve myNumberFormat(cs)
        For i = 1 To cs
           myNumberFormat(i) = ws.Cells(r + 1, c + i - 1).NumberFormat
        Next i
        For i = 1 To cs
           If DataHeader(i) = vbNullString Then 'Check if all columns have headers
                 MsgBox "Be sure that the data contains column headings."
                 Exit Sub
           End If
        Next i
        
        Erase myData
        If rs > 0 Then
           ReDim Preserve myData(rs, cs)
           myData = ws.Cells(r + 1, c).Resize(rs, cs).Value
        End If
      
           
         For i = 1 To cs
               If Left(DataHeader(i), 2) <> "xx" And Left(DataHeader(i), 2) <> "yy" Then
                  If Len(ws.Cells(r, i)) >= Lenmax1 Then
                     Lenmax1 = Len(ws.Cells(r, i)) + 1
                  End If
               End If
               
         Next i
         Lenmax1 = 6 * Lenmax1 'Convert the Number of characters to Points
         If Lenmax1 >= 300 Then
               Lenmax1 = 300
         ElseIf Lenmax1 <= 48 Then
               Lenmax1 = 48
         End If
         Lenmax2 = 1
         If rs > 0 Then
               For Each cRange In ws.Cells(r, c).Resize(rs + 1, cs)
                  If Len(cRange) + 1 >= Lenmax2 Then
                     Lenmax2 = Len(cRange)
                  End If
               Next
         ElseIf rs = 0 Then
            For Each cRange In ws.Cells(r, c).Resize(1, cs)
               If Len(cRange) >= Lenmax2 Then
                  Lenmax2 = Len(cRange)
               End If
            Next
         End If
         Lenmax2 = Lenmax2 * 6
         If Lenmax2 > 250 Then
               Lenmax2 = 250
         ElseIf Lenmax2 < 96 Then
                  Lenmax2 = 96
         End If
         frameWidth = Lenmax1 + Lenmax2 + 30
         
      End With


      With uf_DataEntryForm
         .Caption = ws.Name
         .Top = 80
         .Height = ufHeightMax + 55
         .Width = frameWidth + 115
         
         For i = 1 To 7
           With .Controls("CommandButton" & i)
              .Left = frameWidth + 10 + 12 + 10
              .Top = 24 + 25 * (i - 1)
           End With
         Next i
            
         With .ScrollBar1
               .Top = 6: .Left = frameWidth + 10
               .Height = ufHeightMax - 172
               .Width = 12
               If rs > 0 Then
                  .Min = 1
                  .Max = rmax + 2
                  sValue = 1
                  .Value = sValue
               ElseIf rs = 0 Then
                  .Min = 1
                  .Max = 0 + 1
                  sValue = 1
                  .Value = sValue
               End If
         End With
         
         With .LabelScroll
               .Top = (ufHeightMax - 200) / 2 - 120: .Left = frameWidth + 13
               .Height = ufHeightMax - 250
               .Width = 8
         End With         
        
         With .LabelItem
            .Left = frameWidth + 10 + 12 + 10
            .Top = 6
         End With
         
         With .Frame1
            .Left = 6: .Top = 6: .Width = frameWidth
            .Height = ufHeightMax - 171
            .Caption = ""
            .ZOrder (1)
         End With

' Frame forsearch function, irrelevant to the current question
'         With .Frame2
 '              .Left = 6: .Top = ufHeightMax - 160: .Width = frameWidth + 88: .Height = 178
  '             .Caption = "Complaint Search"
   '            With .listDatabase
    '              .Width = .Width = frameWidth + 50
     '             .Height = 118
      '            .Top = 45
       '        End With
        ' End With
'         Call Add_SearchColumn
 '        With .listDatabase
  '             .Width = frameWidth + 75
   '      End With
         
         'Populate form
         '************
         With .Frame1
            TopPosition = 10
            BottomPosition = BottomPosition + 60
            ReDim Preserve clsArray(1 To cs)
            Dim xCount As Long
            xCount = 8
                  
            For i = 1 To cs
               'Labels
               Lbl = "Label" & i
               .Controls.Add bstrprogid:="forms.label.1", Name:=Lbl, Visible:=True
               
               If Left(DataHeader(i), 2) = "xx" Then 'Section Heading
                  xCount = xCount + 0.5 'Takes up less room so adds less height
               End If
               
               With .Controls(Lbl)
                     .Height = 16: .Width = Lenmax1
                     .Font.Bold = False
                     .Font.size = 11
                     If Left(DataHeader(i), 2) = "xx" Then 'Section headings to break up the form in separate (hidden) columns
                        .Top = 3 + 25 * (i - 1) + xCount: .Left = 6: .Width = frameWidth
                        .Caption = Right(DataHeader(i), Len(DataHeader(i)) - 2)
                        .Font.Bold = True
           ' Special formatting for certain sections of data, irrelevant to current question
'             If Left(DataHeader(i), 7) = "xxStore" Then 'Indent Store section Heading
 '                          .Left = 22:
  '                      End If
   '                  ElseIf Left(DataHeader(i), 2) = "yy" Then 
    '                    .Top = 8 + 25 * (i - 1): .Left = 20
     '                   .Caption = Right(DataHeader(i), Len(DataHeader(i)) - 3)
'
 '                    ElseIf Left(DataHeader(i), 5) = "Store" Then 'Indent Store info
  '                      .Top = 8 + 25 * (i - 1): .Left = 31
   '                     .Caption = DataHeader(i)
    '                 Else
  '                      .Top = 8 + 25 * (i - 1): .Left = 20
   '                     .Caption = DataHeader(i)
    '                 End If
     '                .BorderStyle = 0
      '               BottomPosition = .Top
       '        End With
               
               'ComboBoxes
               Dim tbl As Range
               Cbx = "ComboBox" & i
               Set objtext = .Controls.Add(bstrprogid:="forms.ComboBox.1", Name:=Cbx, Visible:=True)
               With objtext
                  .ShowDropButtonWhen = 0
                  .Height = 16: .Width = Lenmax2
                  .Top = 6 + 25 * (i - 1): .Left = Lenmax1 + 8
                  .Font.Bold = False
                  .Font.size = 10
                  .BorderStyle = fmBorderStyleSingle
                  .BackColor = RGB(255, 255, 255)
                  .BorderColor = &HA9A9A9
                  .Text = Format(.Text, myNumberFormat(i))
                  .ControlTipText = "For multi-line entries, use " & Chr(34) & "Paste Data" & Chr(34) & " button to the right"
                  
                  ' Data Validation/Dropdowns 
                   If Left(DataHeader(i), 2) = "xx" Then 'Section separator
                     .TabStop = False
                     .Height = 1.5: .Width = frameWidth - 25
                     .Top = 15 + 25 * (i - 1) + xCount: .Left = 5
                     .SpecialEffect = 2
                     .ShowDropButtonWhen = 0
                        If Left(DataHeader(i), 7) = "xxStore" Then 'Indent Store section Heading
                           .Width = frameWidth - 25
                           .Left = 25
                        End If
                  ElseIf
                   '...Loads of irrelevant code setting validation and pre-defined values for specific headers... 
                  End If

               End With
               If Left(DataHeader(i), 2) <> "yy" And Left(DataHeader(i), 2) <> "xx" Then 'All ComboBoxes except for section headers, which are just used as visual separators
                  Set clsArray(i).DynamicCBX = objtext
               End If
            Next i

            If BottomPosition > ufHeightMax - 50 - 40 + 6 Then
               .ScrollBars = fmScrollBarsVertical
               .ScrollHeight = (BottomPosition - TopPosition)
               .ScrollWidth = 12
               .ScrollTop = 0

            End If
         End With
         
         If rs = 0 Then
            Call myDataFormReset
         End If
         
         Call CmbStatus
         
         With .ScrollBar1              
               .Value = rmax
         End With


         .Show vbModeless
         .Frame1.ComboBox1.Value = Application.WorksheetFunction.Max(Range("A:A")) + 1
         .Frame1.ComboBox2.Value = Date
         .CommandButton1.Caption = "Add Record"
         '=========================DEBUG CODE =========================================
            '  .Frame1.ComboBox2.Value = ""

            '  .Frame1.ComboBox5.Value = "1F0100 - Red Beans (NonPHO) 9/5#"
         '
            '  Call DataFind
         '  .Frame2.cmbSearchColumn.Value = "Customer"
         '  .Frame2.cmbSearchValue.Value = "EPL"
            
clean:          i = 1
         '====================================================================='
      End With
      
      Dim lastVisibleRow As Long
      With ActiveWindow
         With .VisibleRange
               With .Resize(.Rows.Count - 1, 1)
                  lastVisibleRow = .Row + .Rows.Count - 1
               End With
         End With
         If ActiveCell.Row >= lastVisibleRow Then
               .ScrollRow = .ScrollRow + (.VisibleRange.Rows.Count / 2) + 2
         End If
      End With
      With Application
         .ScreenUpdating = True
         .DisplayAlerts = True
      End With

   LastSelectedCombo = 1
   Startup = False
End Sub

Thank you so much in advance for any help you're able to provide.

 

[Matrovsky]

I'm a new user here so I couldn't edit the OP. Here are some other relevant code snippets that I accidentally left out of the module code:

Option Explicit
Option Compare Text
Option Base 1
Public rs As Long, cs As Long
Private r As Long, c As Long, cmax As Long, rmax As Long
Global DataHeader() As Variant
Global NextComplaint As Long
Private myData() As Variant
Private myNumberFormat() As Variant
Public dateFormat As Variant
Global LastSelectedCombo As Long
Public clsArray() As New cl_dynamicActiveX '(A Class module name is cl_dynamicActiveX)


'...

Sub myDataFormSet()
   Dim i As Long, objtext As Control
   With uf_DataEntryForm.Frame1
      For i = 1 To .Controls.Count / 2 - 2
            Set objtext = .Controls("ComboBox" & i)
            Set clsArray(i).DynamicCBX = objtext
      Next i
   End With
End Sub

Sub myDataFormReset()
   Dim i As Long, j As Long, objtext As Control, UpdateRow As Long
   Application.EnableEvents = False
   With uf_DataEntryForm.Frame1
      'Clear DynamicTXT/clsArray
      For i = 1 To .Controls.Count / 2 - 2
         .Controls("ComboBox" & i).Value = ""
         Set objtext = .Controls("ComboBox" & i)
         Set clsArray(i).DynamicCBX = Nothing
         Set clsArray(i).DynamicCBX = objtext
      Next i
      'Rebuild DynamicTXT/clsArray
      For j = 1 To .Controls.Count / 2 - 2
            Set objtext = .Controls("ComboBox" & j)
            Set clsArray(i).DynamicCBX = objtext
      Next j
   End With

Sub WriteChange(txtNo, txtValue)
   Dim UpdateRowScrl As Long, i As Long
   If txtValue <> "" Then
      uf_DataEntryForm.EnableFormEvents = False
      Set ws = ActiveSheet
      UpdateRowScrl = r + uf_DataEntryForm.ScrollBar1.Value

      If IsDate(txtValue) = True Then
         ws.Cells(UpdateRowScrl, c + txtNo - 1).Value = Format(txtValue, dateFormat)
      Else
         ws.Cells(UpdateRowScrl, c + txtNo - 1).Value = txtValue
      End If

      Call UpdateComboValues_timer(txtNo, txtValue)
      uf_DataEntryForm.CommandButton3.Enabled = True
      uf_DataEntryForm.EnableFormEvents = True
   End If
End Sub

Sub UpdateComboValues(txtNo, txtValue)
   Dim i As Variant, UpdateRowScrl As Long
   Dim formSourceCols() As Variant
   Dim formTargetCols() As Variant
   Dim element As Variant
   Dim columnIsFormSrc As Boolean
   
   If Startup = True Then
      Exit Sub
   End If
   Startup = True

 'check if the updated box is one that needs calculation. Eliding because sensitive info included in code
 ' For each element in...
'       columnIsFormSrc = True/False
 ' Next element

   If columnIsFormSrc = True Then
   UpdateRowScrl = r + uf_DataEntryForm.ScrollBar1.Value
      
      With uf_DataEntryForm.Frame1
         For Each i In formTargetCols
            If .Controls("ComboBox" & i).Value = "" Then 'And ws.Cells(UpdateRowScrl, c + i - 1).Formula = "" Then
               ws.Cells(UpdateRowScrl, c + i - 1).Formula = ws.Cells(200, c + i - 1).Formula
               .Controls("ComboBox" & i).Text = ws.Cells(UpdateRowScrl, c + i - 1).Value
            End If
         Next
        End With
   End If
   Startup = False
End Sub