Programatically Deleting OLEObject ComboBox Click Event Handler Subs

[thebryce]

Hello everyone!

I am dynamically creating a bunch of ActiveX/OLEObject comboboxes. Each combobox needs to have a dynamically created Click event handler. I am able to do this, no prob.

The problem is that, occasionally during a session I want to delete all of the comboboxes and their associated event handlers and recreate them. The addCombos() method below first deletes existing comboboxes, then tries to delete click event handlers before creating new ones.

I've gotten very close to solving this but the spreadsheet keeps crashing part way through deleting the dynamically created click event handlers. Here's the code, I've got it loaded into "Sheet1":

Public Sub addCombos()


    Dim thisRow As Integer
    Dim thisCol As Integer
    Dim thisLeft As Integer
    Dim thisTop As Integer
    Dim i As Integer
    Dim obj As OLEObject
    Dim thisName As String
    Dim VBProj As Object
    Dim vbCodeMod As Object
    Dim count As Integer
    Dim StartLine As Long
    Dim NumLines As Long
    Dim LineNum As Long
    Dim ProcName As String
    Dim ProcKind As VBIDE.vbext_ProcKind
    
    Application.ScreenUpdating = False
    
    Sheets("Sheet1").Activate
    Set VBProj = ActiveWorkbook.VBProject
    Set vbCodeMod = VBProj.VBComponents(ActiveSheet.CodeName).CodeModule
    
    thisRow = 1
    thisCol = 1
    thisLeft = 0
    thisTop = 0


    ' nuke any existing comboboxes
    For Each obj In ActiveSheet.OLEObjects
        obj.Delete
    Next obj
    
    ' clear existing dynamically created code procedures
    With vbCodeMod
        LineNum = .CountOfDeclarationLines + 1
        Do Until LineNum >= .CountOfLines
            ProcName = .ProcOfLine(LineNum, ProcKind)
            LineNum = .ProcStartLine(ProcName, ProcKind) + _
                    .ProcCountLines(ProcName, ProcKind) + 1
    
            If Left(ProcName, 13) = "TestComboBox_" And Right(ProcName, 6) = "_Click" Then
                StartLine = .ProcStartLine(ProcName, ProcKind)
                NumLines = .ProcCountLines(ProcName, ProcKind)
                .DeleteLines StartLine:=StartLine, count:=NumLines
            End If
        Loop
    End With
    
    ' add a few new combo boxes
    For i = 0 To 5
        thisName = "TestComboBox_" + CStr(i)
        
        Cells(thisRow, thisCol).Select
        With Selection
            thisLeft = .Left
            thisTop = .Top
            .RowHeight = 20
        End With
        
        Set obj = OLEObjects.Add(ClassType:="Forms.ComboBox.1", DisplayAsIcon:=False, Left:=thisLeft, Top:=thisTop, Width:=100, Height:=17)
        With obj
            .name = thisName
            ' now add items to each combobox
            With obj.Object
                .AddItem "Apple"
                .AddItem "Orange"
                .AddItem "Blueberry"
                .Font.Size = 10
            End With
        End With
        
        ' dynamically add the various trigger events for this control,
        ' see:  http://stackoverflow.com/questions/9476481/detecting-event-on-comboboxes-added-at-runtime-on-excel
        vbCodeMod.AddFromString AddEvent(obj.name)
        
        thisRow = thisRow + 1
    Next i
    
End Sub


Private Function AddEvent(strIn As String) As String
    AddEvent = "Public Sub " & strIn & "_Click()" & Chr(10) & _
                    "dim newVal As String" & Chr(10) & _
                    "newVal = ActiveSheet.OLEObjects(""" + strIn + """).Object.value" & Chr(10) & _
                    "MsgBox newVal" & Chr(10) & _
                "End Sub"
End Function

The first time I run addCombos() everything works as planned. Comboboxes are created on Sheet1 and event handler subs are inserted at the top of the module.

If I run addCombos() again, it starts will successfully delete the first event handler, TestComboBox_5_Click() but then Excel crashes.

I'm running Excel 2016/64-bit. I have the following VBAProject references set in Tools > References:

• Visual Basic for Applications
• Microsoft Excel 16.0 Object Library
• OLE Automation
• Microsoft Office 16.0 Object Library
• Microsoft Forms 2.0 Object library
• Microsoft Visual Basic for Applications Extensibility 5.3

Thank you very much for any help in advance. I am at my wit's end on this.

 

[Fazza]

hi

What about the loop "Do Until LineNum >= .CountOfLines" when within the loop lines are being deleted? This might cause a problem.

Suggest looping through all the current code lines & creating an array with the replacement lines: no changes to the existing lines en route. Once the new lines are ready, insert all the new lines en masse before deleting any old lines. This approach does work & I recall other ways were problematic. This old code from something in my files demonstrates

HTH. Regards, Fazza

  With MyModule.CodeModule
    
    jLoop = 0
    lLineCountBefore = .CountOfLines
    ReDim asReplacementLines(1 To lLineCountBefore)
    
    For iLoop = 1 To lLineCountBefore
      sOneCodeLine = Trim$(.Lines(iLoop, 1))
      If wanttokeepthisline Then
        jLoop = jLoop + 1
        asReplacementLines(jLoop) = sOneCodeLine
       End If
    Next iLoop
    ReDim Preserve asReplacementLines(1 To jLoop)
    
    Debug.Print "module " & strModuleName & " : take out " & lngLineCountBefore & " line" & IIf(lLineCountBefore <> 1, "s", vbNullString)
    .InsertLines lLineCountBefore + 1, Join$(asReplacementLines, vbCrLf) 'insert replacement code first, then
    .DeleteLines 1, lLineCountBefore 'delete original code afterwards
  End With

 

[Domenic]

Maybe...

    With vbCodeMod
        LineNum = .CountOfLines
        Do While LineNum > .CountOfDeclarationLines
            ProcName = .ProcOfLine(LineNum, ProcKind)
            NumLines = .ProcCountLines(ProcName, ProcKind)
            If Left(ProcName, 13) = "TestComboBox_" And Right(ProcName, 6) = "_Click" Then
                .DeleteLines LineNum - NumLines + 1, NumLines
            End If
            LineNum = LineNum - NumLines
        Loop
    End With

Hope this helps!

 

[Kyle123]

Why not just use a class to handle to events?

It's a lot neater than that approach

 

[thebryce]

@FAZZA & @Dominic, thank you. I will try your suggestions out now and report back.

@Kyle123, I do have some experience with OOP in other languages but was not sure that you could do such stuff with Excel VBA. It's funny, I just ran across an article yesteraday talking about using the Class Modules. I need to learn more about that feature, will look into this now.

 

[thebryce]

Finally got it working. Running addCombos() will dynamically remove any pre-existing, dynamically created _Click() action handlers and replace them with new ones. This uses the VBE .VBProject.VBComponents .CodeModule.AddFromString.AddFromString method to write the new code. It's not the most elegant solution but it works.

Public Sub addCombos()


    Dim thisRow As Integer
    Dim thisCol As Integer
    Dim thisLeft As Integer
    Dim thisTop As Integer
    Dim I As Integer
    Dim obj As OLEObject
    Dim thisName As String
    Dim VBProj As Object
    Dim vbCodeMod As Object
    Dim count As Integer
    Dim StartLine As Long
    Dim NumLines As Long
    Dim LineNum As Long
    Dim ProcName As String
    Dim ProcKind As VBIDE.vbext_ProcKind
    Dim bodyLine As Long
    Dim existingProcedures As Dictionary
    Dim thisExistingProceduresKeys, thisExistingProceduresItems, thisExistingProcedureName As Variant
    Dim itemKeys, itemItems, itemElements As Variant
    Dim controlNamePrefix As String
    Dim keyIndex As Long
    Dim thisProcedureFound As Boolean
    Dim testSubName As String
    
    Sheets("Sheet1").Activate
    Set VBProj = ActiveWorkbook.VBProject
    Set vbCodeMod = VBProj.VBComponents(ActiveSheet.CodeName).CodeModule
    
    thisRow = 1
    thisCol = 1
    thisLeft = 0
    thisTop = 0
    controlNamePrefix = "TestComboBox_"


    ' nuke any existing comboboxes
    For Each obj In ActiveSheet.OLEObjects
        obj.Delete
    Next obj
    
    ' clear existing dynamically created code procedures
    Set existingProcedures = getExistingProcedures("Sheet1", "Sheet1") 'get listing of existing procedures
    
    If existingProcedures.count > 0 Then
        thisExistingProceduresKeys = existingProcedures.Keys
        thisExistingProceduresItems = existingProcedures.Items
            
        For Each thisExistingProcedureName In thisExistingProceduresKeys
            If Left(thisExistingProcedureName, 13) = controlNamePrefix And Right(thisExistingProcedureName, 6) = "_Click" Then
                With vbCodeMod
                        StartLine = .ProcStartLine(thisExistingProcedureName, ProcKind)
                        NumLines = .ProcCountLines(thisExistingProcedureName, ProcKind)
                        .DeleteLines StartLine:=StartLine, count:=NumLines
                End With
            End If
        Next
    End If
   
    Set existingProcedures = Nothing
    
    ' add new combo boxes
    For I = 0 To 3
        thisName = controlNamePrefix + CStr(I)
        
        Cells(thisRow, thisCol).Select
        With Selection
            thisLeft = .Left
            thisTop = .Top
            .RowHeight = 20
        End With
        
        Set obj = OLEObjects.Add(ClassType:="Forms.ComboBox.1", DisplayAsIcon:=False, Left:=thisLeft, Top:=thisTop, Width:=100, Height:=17)
        With obj
            .name = thisName
            ' now add items to each combobox
            With obj.Object
                .AddItem "Apple"
                .AddItem "Orange"
                .AddItem "Blueberry"
                .Font.Size = 10
            End With
        End With
        
        ' dynamically add the various trigger events for this control
        Set existingProcedures = getExistingProcedures("Sheet1", "Sheet1") 'get listing of existing procedures
        thisProcedureFound = False
        
        If existingProcedures.count > 0 Then
            thisExistingProceduresKeys = existingProcedures.Keys
            thisExistingProceduresItems = existingProcedures.Items


            For Each thisExistingProcedureName In thisExistingProceduresKeys
                testSubName = thisName + "_Click"
                If thisExistingProcedureName = testSubName Then
                    thisProcedureFound = True
                    Exit For
                End If
            Next
        End If
        
        If thisProcedureFound = False Then
            vbCodeMod.AddFromString ( _
                "Public Sub " & obj.name & "_Click()" & Chr(10) & _
                Chr(9) + "dim newVal As String" & Chr(10) & _
                Chr(9) + "newVal = ActiveSheet.OLEObjects(""" + obj.name + """).Object.value" & Chr(10) & _
                Chr(9) + "MsgBox newVal" & Chr(10) & _
                "End Sub")
        End If
        
        thisRow = thisRow + 1
        Set existingProcedures = Nothing
    Next I
End Sub


Function getExistingProcedures(ByRef worksheetName As String, ByRef searchModule As String) As Dictionary
    
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    Dim LineNum As Long
    Dim NumLines As Long
    Dim WS As Worksheet
    Dim ProcName As String
    Dim ProcKind As VBIDE.vbext_ProcKind
    Dim dictKey As String
    Dim dictItem As String
    Dim tempDictionary As Dictionary
    
    Set VBProj = ActiveWorkbook.VBProject
    Set VBComp = VBProj.VBComponents(searchModule)
    Set CodeMod = VBComp.CodeModule
    Set WS = ActiveWorkbook.Worksheets(worksheetName)
    Set tempDictionary = New Dictionary
       
    LineNum = CodeMod.CountOfDeclarationLines + 1
    Do While LineNum <= CodeMod.CountOfLines
        dictKey = ""
        dictItem = ""


        ProcName = CodeMod.ProcOfLine(LineNum, ProcKind)
        LineNum = CodeMod.ProcStartLine(ProcName, ProcKind) + CodeMod.ProcCountLines(ProcName, ProcKind) + 1


        dictKey = Trim(ProcName)
        dictItem = Trim(LineNum)
        
        tempDictionary.CompareMode = BinaryCompare
        tempDictionary.Add Key:=(dictKey), Item:=(dictItem)
    Loop
       
    Set getExistingProcedures = tempDictionary
End Function


Function ProcKindString(ProcKind As VBIDE.vbext_ProcKind) As String
    Select Case ProcKind
        Case vbext_pk_Get
            ProcKindString = "Property Get"
        Case vbext_pk_Let
            ProcKindString = "Property Let"
        Case vbext_pk_Set
            ProcKindString = "Property Set"
        Case vbext_pk_Proc
            ProcKindString = "Sub Or Function"
        Case Else
            ProcKindString = "Unknown Type: " & CStr(ProcKind)
    End Select
End Function