vba - 拆除循环引用

Question

以下代码为集合中的每个元素创建循环引用。 UserForm_Terminate 例程中的代码是否足以拆除关系以允许释放内存？或者是否需要使用指针和弱引用？

如果是/不是，测试对象是否已被释放的最佳方法是什么？

用户表单代码:

Option Explicit
Implements IBtnClick

Dim coll As Collection

Private Sub UserForm_Initialize()
Dim x As Long
Dim e As CBtnEvents

Set coll = New Collection

For x = 1 To 5
    Set e = New CBtnEvents
    Set e.btn = Me.Controls.Add("Forms.CommandButton.1")
    e.ID = x
    e.Register Me
    With e.btn
        .Height = 30
        .Width = 30
        .Top = 10
        .Left = .Width * x
    End With
    coll.Add e
Next x

End Sub

Private Sub UserForm_Terminate()
Dim itm

For Each itm In coll
    msgbox itm.ID
    itm.Unregister
Next itm

End Sub

Private Sub IBtnClick_click(ID As Long)
    MsgBox ID
End Sub

IBtnClick 代码:

    Public Sub click(ID As Long)

    End Sub

CBtnEvents 代码:

    Private WithEvents p_btn As MSForms.CommandButton
    Private p_ID As Long
    Private click As IBtnClick

    Public Property Set btn(value As MSForms.CommandButton)
        Set p_btn = value
    End Property

    Public Property Get btn() As MSForms.CommandButton
        Set btn = p_btn
    End Property

    Public Sub Register(value As IBtnClick)
        Set click = value
    End Sub

    Public Sub Unregister()
        Set click = Nothing
    End Sub

    Private Sub p_btn_Click()
        click.click p_ID
    End Sub

    Public Property Get ID() As Long
        ID = p_ID
    End Property

    Public Property Let ID(ByVal lID As Long)
        p_ID = lID
    End Property

    Private Sub Class_Terminate()
        MsgBox p_ID
    End Sub

我已经包含了 VB6 标签，因为我认为这个问题同样适用，但我使用的是 Excel VBA。

Answer 1

这就是我们(手动)保存实例簿记集合的方式:

在每个类/表单/控件中我们都放置这样的东西

Option Explicit
DefObj A-Z
Private Const MODULE_NAME As String = "cTransStub"

'=========================================================================
' Constants and member variables
'=========================================================================

' Consts here

' Vars here
#If DebugMode Then
    Private m_sDebugID          As String
#End If

' Props here

' Methods here

'=========================================================================
' Base class events
'=========================================================================

#If DebugMode Then
    Private Sub Class_Initialize()
        DebugInstanceInit MODULE_NAME, m_sDebugID, Me
    End Sub

    Private Sub Class_Terminate()
        DebugInstanceTerm MODULE_NAME, m_sDebugID
    End Sub
#End If

填充 DebugIDs 集合的帮助器 DebugInstanceInit/Term 子项的示例实现:

Public Sub DebugInstanceInit(sModuleName As String, sDebugID As String, oObj As Object)
    Dim sCount          As String
    Dim lObjPtr         As Long
    Dim sObjCtx         As String

    On Error Resume Next
    sDebugID = sDebugID & GetDebugID()
    If DebugIDs Is Nothing Then
    Else
        ...
        lObjPtr = ObjPtr(oObj)  
        DebugIDs.Add sDebugID & " " & LIB_NAME & "." & sModuleName & "|&H" & Hex(lObjPtr) & "|" & Format$(time, "hh:mm:ss") & "|" & sObjCtx & "|", "#" & sDebugID
    End If
    ...
    If Not DebugConsole Is Nothing Then
        DebugConsole.RefreshConsole
    End If
    On Error GoTo 0
End Sub

Public Sub DebugInstanceTerm(sModuleName As String, sDebugID As String)
    On Error Resume Next
    If DebugIDs Is Nothing Then
    Else
        DebugIDs.Remove "#" & sDebugID
    End If
    ...
    If Not DebugIDs Is Nothing Then
        If DebugIDs.Count = 0 Then
            Debug.Print "DebugIDs collection is empty"; Timer
        End If
    End If
    If Not DebugConsole Is Nothing Then
        DebugConsole.RefreshConsole
    End If
    On Error GoTo 0
End Sub

程序终止后，我们会对 DebugIDs 集合中的任何对象泄漏发出警告。