VBA对象销毁-内存错误

Question

我有一个创建的类对象，该对象具有对其他类的引用（其他任何类都不相互引用）。我遇到一个内存问题，当我遍历并创建该类的实例时，出现“内存不足”错误。类和子例程的简化代码段如下：

类aclsWell

Option Explicit
Option Compare Text
Option Base 1

Private zclsSettings As bclsSettings
Private zclsInfo As bclsInfo
Private zclsProduction As bclsProduction

Private Sub Class_Initialize()
 Set zclsSettings = New bclsSettings: Set zclsSettings.Parent = Me
 Set zclsInfo = New bclsInfo: Set zclsInfo.Parent = Me
 Set zclsProduction = New bclsProduction: Set zclsProduction.Parent = Me
End Sub

Private Sub Class_Terminate()
 Set zclsSettings.Parent = Nothing: Set zclsSettings = Nothing
 Set zclsInfo.Parent = Nothing: Set zclsInfo = Nothing
 Set zclsProduction.Parent = Nothing: Set zclsProduction = Nothing
End Sub

模块：

Sub Test1()

Dim zwell As aclsWell

For i = 1 To 2000
    Set zwell = New aclsWell
    Set zWell = Nothing
Next i

End sub

Test1完成后，excel将使用大约1 GB的数据，如果再次运行，则会收到错误消息。但是，如果我按了VBA窗口中的停止按钮，则内存将清除。有什么方法可以使用VBA模仿停止按钮（例如Application.stopmacro或类似的东西）。还是我关闭对象的方式存在根本问题？非常感谢您的见解。

Answer 1

当引用同时出现时，这很棘手。您将对象设置为Nothing时，引用计数不为零，因此不会触发终止事件。因此，您无法在终止事件中清理引用。

一种选择是创建自己的终止方法。

Public Sub Terminate()
 Set zclsSettings.Parent = Nothing: Set zclsSettings = Nothing
 Set zclsInfo.Parent = Nothing: Set zclsInfo = Nothing
 Set zclsProduction.Parent = Nothing: Set zclsProduction = Nothing

End Sub

Sub Test1()

Dim zwell As aclsWell
Dim i As Long

For i = 1 To 2000
    Set zwell = New aclsWell
    zwell.Terminate
    Set zwell = Nothing
Next i

End Sub

现在，当您单步执行代码时，将触发Class_Terminate事件，因为Terminate方法将引用计数降至零，并且VBA知道它将能够清除该对象。

我使用的方法是将父代的内存位置存储在子代中，并存储为Long（或64位的LongPtr）。 阅读这篇文章，特别是在评论部分的Rob Bruce的评论。

' In your child class
Private m_lngParentPtr As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                               (dest As Any, Source As Any, ByVal bytes As Long)

' The Parent property
Public Property Get Parent() As Class1
    Set Parent = ObjFromPtr(m_lngParentPtr)
End Property
Public Property Set Parent(obj As Class1)
    m_lngParentPtr = ObjPtr(obj)
End Property

'Returns an object given its pointer.
'This function reverses the effect of the ObjPtr function.
Private Function ObjFromPtr(ByVal pObj As Long) As Object
    Dim obj                     As Object
    ' force the value of the pointer into the temporary object variable
    CopyMemory obj, pObj, 4
    ' assign to the result (this increments the ref counter)
    Set ObjFromPtr = obj
    ' manually destroy the temporary object variable
    ' (if you omit this step you’ll get a GPF!)
    CopyMemory obj, 0&, 4
End Function

Answer 2

尝试使用End关键字

Sub Test1()

Dim zwell As aclsWell

For i = 1 To 2000
Set zwell = New aclsWell
Set zWell = Nothing

Next i
End
End sub