VBA自定义TextBox类置于MultiPage控件时事件失效求助

我为窗体创建了自定义TextBox类clsBusinessCaseTextBoxEvents，直接放置在窗体上时相关事件可正常触发，但将其放置在MultiPage控件上时事件完全失效。

注：VBA原生不支持OnEnter、OnExit、BeforeUpdate和AfterUpdate事件（VB中支持），因此我通过调用Windows API的ConnectToConnectionPoint函数实现这些事件的功能。

相关代码片段 #

clsBusinessCaseTextBoxEvents代码 #

Public WithEvents objTextBox As MSForms.TextBox
Private objParent As clsBusinessCaseEventControl

'------------------------------------------
'Initialize
'------------------------------------------
Public Sub Initialize(Parent As clsBusinessCaseEventControl)
     Set Me.Parent = Parent
     With Parent.UserForm.Controls
         'Set objTextBox = .Add("Forms.TextBox.1")
     End With
End Sub

'------------------------------------------
'Parent Property
'------------------------------------------
Public Property Set Parent(sglValue As clsBusinessCaseEventControl)
     Set objParent = sglValue
End Property
 
Public Property Get Parent() As clsBusinessCaseEventControl
     Set Parent = objParent
End Property

clsBusinessCaseEventControl代码 #

Private colCollection As Collection
Private objUserForm As UserForm

Public Event Change(objTextBox As clsBusinessCaseTextBoxEvents)
Public Event AfterUpdate(objTextBox As clsBusinessCaseTextBoxEvents)
Public Event Enter(objTextBox As clsBusinessCaseTextBoxEvents)

Public Property Set UserForm(frmUserForm As UserForm)
    Set objUserForm = frmUserForm
End Property

Public Property Get UserForm() As UserForm
    Set UserForm = objUserForm
End Property

Public Function AddTextBox() As clsBusinessCaseTextBoxEvents
    Dim objTextBox As clsBusinessCaseTextBoxEvents
    Set objTextBox = New clsBusinessCaseTextBoxEvents
'
    objTextBox.Initialize Me
End Function

Private Sub Class_Initialize()
    Set colCollection = New Collection
End Sub

示例事件代码 #

Public Sub Enter(objTextBox As clsBusinessCaseTextBoxEvents)
    RaiseEvent Enter(objTextBox)
End Sub

普通模块添加TextBox类实例的代码 #

Dim objTextBoxControl  As control
Set objTextBoxControl = frmBusinessCase.mtpBusinessCase.Page0.Controls.Add("Forms.TextBox.1", strTextBoxName, True)

Windows API相关实现代码 #

'==================================================================================================================
'############ Section BEGIN for: OnEnter, OnExit, BeforeUpdate and AfterUpdate ####################################
'------------------------------------------------------------------------------------------------------------------
'
'Unlike VB, VBA does not bring across the 'OnEnter, 'OnExit', 'BeforeUpdate' and 'AfterUpdate' events as methods
'into it's textbox class.
'
'Instead, to obtain this functionality, it is necessary to make a Windows API call to 'ConnectToConnectionPoint'
'
'The code in these partitioned blocks deals with these functions using this Windows API call
'------------------------------------------------------------------------------------------------------------------

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
    Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
#Else
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
    Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
#End If
'==================================================================================================================
'############ Section END for: OnEnter, OnExit, BeforeUpdate and AfterUpdate ####################################
'==================================================================================================================

'==================================================================================================================
'############ Section BEGIN for: OnEnter, OnExit, BeforeUpdate and AfterUpdate ####################################
'==================================================================================================================
Public Property Let SetControlEvents(ByVal TextBox As Object, ByVal SetEvents As Boolean)

    Const S_OK = &H0
    Static lCookie As Long
    Dim tIID As GUID
    
    Set objTextBox = TextBox
    If IIDFromString(StrPtr("{00020400-0000-0000-C000-000000000046}"), tIID) = S_OK Then
        Call ConnectToConnectionPoint(Me, tIID, SetEvents, TextBox, lCookie)
        If lCookie Then
            'Debug.Print "Connection set for: " & TextBox.Name
            'MsgBox "Connection set for: " & TextBox.Name
        Else
            'Debug.Print "Connection failed for: " & TextBox.Name
        End If
    End If

End Property

Public Sub OnEnter()

    'Attribute OnEnter.VB_UserMemId = &H80018202
    'Debug.Print "[ENTER EVENT] " & oTextBox.Name & vbTab & "Value: " & vbTab & oTextBox.Value
    MsgBox "On Enter"

    Call TurnActiveFieldToYellow(objTextBox)
    Call FormBusinessCaseDollarFieldsBlue(objTextBox)

End Sub

问题原因及修正方案 #

1. API调用参数顺序错误 #

ConnectToConnectionPoint的参数顺序被颠倒，正确逻辑是：第一个参数是要绑定事件的控件（TextBox），第四个参数是接收事件的自定义类实例。原代码把两者位置搞反，导致非窗体容器下的事件连接失败。

修正代码：

Call ConnectToConnectionPoint(TextBox, tIID, SetEvents, Me, lCookie)

2. 自定义类实例未关联到MultiPage容器 #

原AddTextBox方法只默认绑定到窗体控件，未支持MultiPage的Page作为父容器，且普通模块直接创建原生TextBox，未关联到自定义类，导致事件绑定逻辑未执行。

修正clsBusinessCaseEventControl的AddTextBox方法：

Public Function AddTextBox(Optional parentCtrl As Object = Nothing) As clsBusinessCaseTextBoxEvents
    Dim objTextBox As clsBusinessCaseTextBoxEvents
    Dim nativeTextBox As MSForms.TextBox
    
    Set objTextBox = New clsBusinessCaseTextBoxEvents
    objTextBox.Initialize Me
    
    ' 确定父容器，默认用窗体，否则用传入的容器（比如MultiPage的Page）
    If parentCtrl Is Nothing Then
        Set nativeTextBox = Me.UserForm.Controls.Add("Forms.TextBox.1")
    Else
        Set nativeTextBox = parentCtrl.Controls.Add("Forms.TextBox.1")
    End If
    
    ' 绑定事件
    objTextBox.SetControlEvents nativeTextBox, True
    ' 将自定义类实例加入集合，防止被垃圾回收销毁
    colCollection.Add objTextBox
    
    Set AddTextBox = objTextBox
End Function

3. 静态Cookie导致多实例冲突 #

SetControlEvents中使用Static lCookie As Long会让所有TextBox实例共享同一个Cookie，后续创建的控件会覆盖之前的事件连接，导致MultiPage上的控件事件失效。

修正为实例级变量：
在clsBusinessCaseTextBoxEvents模块顶部声明：

Private lCookie As Long ' 每个实例独立的Cookie，避免冲突

4. 普通模块创建代码修正 #

改用自定义控件容器的方法创建TextBox，确保关联到自定义类：

Dim objEventControl As clsBusinessCaseEventControl
Dim customTextBox As clsBusinessCaseTextBoxEvents

Set objEventControl = New clsBusinessCaseEventControl
Set objEventControl.UserForm = frmBusinessCase

' 在MultiPage的Page0上创建自定义TextBox
Set customTextBox = objEventControl.AddTextBox(frmBusinessCase.mtpBusinessCase.Page0)
customTextBox.objTextBox.Name = strTextBoxName

内容的提问来源于stack exchange，提问作者JonS