Form ActiveX control OnAction to call procedure within class

Question

I'm creating a treeview on an Access 365 form. To keep my form code simple, and as I'll be using the treeview on a couple of forms I moved the code into a class module.

The treeview has a right-click event so that new nodes can be added through a pop-up menu.
The problem I'm having is using the OnAction property of my menu control to execute a procedure that is within the class. It works fine if the procedure is in a normal module, but then I have to pass a class reference to the module so I can access variables held within the class.

Basically I want my OnAction to be something like one of the lines of code below:

txtBox.OnAction = "Me.AddNewNode"
txtBox.OnAction = "MyClass.AddNewNode"

To create a Minimal, Reproducible Example:

Create a table called Table1 and add these fields:
- ID - (PK, AutoNumber)
- Desc - (Short Text)
- ParentID - (Number)

Add some data to Table1:

Create a form called Form1 and add the Microsoft TreeView Control, version 6.0 ActiveX control. Call the control TreeView0
Open the VBE and add these references:
- Microsoft Windows Common Controls 6.0 (SP6) (should be added when the treeview is added).
- Microsoft Office 16.0 Access database engine object
- Microsoft Office 16.0 Object Library
Create Class1 class module and add this code (hopefully the problem line is obvious):

Private rst As DAO.Recordset
Private WithEvents TV As MSComctlLib.TreeView
Const KeyPrfx As String = "X"

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

Public Property Set TreeViewControl(ByRef Value As MSComctlLib.TreeView)
    Set TV = Value
End Property

Public Sub OpenRecordSet(SQLString As String)
    Set rst = CurrentDb.OpenRecordSet(SQLString)
End Sub

Public Sub CreateRightClickMenu()
    Dim txtBox As CommandBarComboBox
    On Error Resume Next
        CommandBars("LocationTVMenu").Delete
    On Error GoTo 0
    
    With CommandBars.Add("LocationTVMenu", Position:=msoBarPopup)
        Set txtBox = .Controls.Add(Type:=msoControlEdit)
        txtBox.Caption = "New Location Name:"
                                       '   **********************************************
        txtBox.OnAction = "AddNewNode" '<< ***Call procedure within this class module.***
                                       '   **********************************************
    End With
End Sub

Private Sub AddNewNode()
    MsgBox "Node added!"
End Sub

Public Sub LoadTreeView()
    Dim nodeKey As String
    Dim nodeParent As String
    Dim nodeText As String
    
    TV.Nodes.Clear
    rst.MoveFirst
    Do While Not rst.BOF And Not rst.EOF
        nodeKey = KeyPrfx & CStr(rst.Fields("ID"))
        nodeParent = KeyPrfx & CStr(rst.Fields("ParentID"))
        nodeText = rst.Fields("Desc")
        If Nz(rst.Fields("ParentID"), 0) = 0 Then
            With TV.Nodes.Add(, , nodeKey, nodeText)
                .Tag = rst.Fields("ID")
            End With
        Else
            With TV.Nodes.Add(nodeParent, tvwChild, nodeKey, nodeText)
                .Tag = rst.Fields("ID")
            End With
        End If
        rst.MoveNext
    Loop
End Sub

Private Sub TV_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                       ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
    If Button = 2 Then
        Dim nodX As Node
        ConvertPixelsToTwips x, y
        Set nodX = TV.HitTest(x, y)
        If Not nodX Is Nothing Then
            With CommandBars("LocationTVMenu")
                .Controls("New Location Name:").Text = vbNullString
                .ShowPopup
            End With
        End If
    End If
End Sub

Private Sub ConvertPixelsToTwips(ByRef x As stdole.OLE_XPOS_PIXELS, _
                                 ByRef y As stdole.OLE_YPOS_PIXELS)
    Dim hDC As Long, RetVal As Long, TwipsPerPixelX As Long, TwipsPerPixelY As Long
    Const LOGPIXELSX = 88
    Const LOGPIXELSY = 90
    Const TWIPSPERINCH = 1440
 
    hDC = GetDC(0)
    TwipsPerPixelX = TWIPSPERINCH / GetDeviceCaps(hDC, LOGPIXELSX)
    TwipsPerPixelY = TWIPSPERINCH / GetDeviceCaps(hDC, LOGPIXELSY)
    RetVal = ReleaseDC(0, hDC)
    x = x * TwipsPerPixelX:  y = y * TwipsPerPixelY
End Sub

Add this code to the userform:

Private MyClass As Class1

Private Sub Form_Load()
    Set MyClass = New Class1
    With MyClass
        Set .TreeViewControl = Me.TreeView0.Object
        .OpenRecordSet "Select ID, Desc, ParentID FROM Table1"
        .LoadTreeView
        .CreateRightClickMenu
    End With
End Sub

I've tried various versions of calling the procedure, but nothing has worked so far. No error messages (didn't expect any) - it just doesn't fire the AddNewNode procedure.

Edit: I've got a workaround which is working. Not ideal, but this is a personal project so can rewrite as many times as I like. I haven't added as an answer as I don't think it's the best way to go about it.

I moved Private MyClass As Class1 from the userform to a normal module and made it public.
Added a Property to MyClass so I can get a reference to the recordset in the normal module.
Added this procedure to the normal module:

Public Sub AddNewNode()
    With MyClass.RecordSetReference
        .AddNew
        .Fields("Desc") = CommandBars("LocationTVMenu").Controls("New Location Name:").Text
        .Fields("ParentID") = MyClass.TreeViewControl.SelectedItem.Tag
        .Update
    End With
    MyClass.LoadTreeView
End Sub

Now I just need the treeview to expand any nodes that were expanded before the treeview was reload.

Form ActiveX control OnAction to call procedure within class

0 Answers