Как определить, кто ссылается на объект?

[Antonariy]

У проги такая структура (упрощенно):

Код: Выделить всё

ActiveX Control
    класс1(1)
        Класс2(1)
        Класс2(2)
    класс1(2)
        Класс2(1)
        Класс2(2)


Класс 2 так же хранит ссылку на содержащий его экземпляр класса1. Чтобы уничтожить экземпляр класса1, генерирую в нем событие, по которому все принадлежащие ему экземпляры класса2 уничтожают ссылку, а из коллекции контрола удаляю евойным методом. По идее все ссылки на класс удалены, однако Class_Terminate() не происходит. Значит что-то где-то осталось висеть. Все добавления и удаления ссылок из коллекции контрола делаю в самом классе1 при вызове публичного метода типа так:

Код: Выделить всё

Control:
Sub CreateClass1()
Dim c as New Class1
    c.Create Me
End sub

Class1:
Dim lControl
Dim lClasses2 as Collection

Public Sub Create(pControl)
    Set lControl = pControl
    lControl.Class1Collection.Add Me, "p" & ObjPtr(Me)
End Sub

Private Sub Destroy()
    lControl.Class1Collection.Remove "p" & ObjPtr(Me)
    RaiseEvent Destroy 'для экземпляров класса2
End Sub

Private Sub Class_Terminate
    Set lClasses2 = Nothing
    Set lControl = Nothing
End Sub


Вопрос такой: можно ли как-нибудь узнать, какая сволочь не отпускает экземпляр? VB вроде как ведет учет ссылок на экземпляр, может можно для этого задействовать функции msvbvm?

[alibek]

Вроде бы ведется учет количества ссылок, но не то, кто ссылается.

[alibek]

Допустим, есть компонент (класс), в котором имеется коллекция Groups элементов Group. Те, в свою очередь, состоят из коллекции Units элементов Unit.
Код я бы использовал примерно такой:

Код: Выделить всё

'Groups
Option Explicit

Private colGroups As Collection

Public Function Exist(GroupName As String) As Boolean
...
End Function

Public Function Add(GroupName As String) As Group
If Len(GroupName ) = 0 Then Exit Function
If Exist(GroupName ) Then Exit Function
Dim objGroup As Group
Set objGroup = New Group
objGroup.Create Me
objGroup.SetName GroupName
colGroups.Add Key:=CStr(GroupName), Item:=objGroup
Set Add = objGroup
Set objGroup = Nothing
End Function

Public Property Get Item(GroupName As String) As Group
If Not Exist(GroupName) Then Exit Property
Set Item = colGroups.Item(CStr(GroupName))
End Property

Public Property Get Count() As Long
Count = colGroups.Count
End Property

Public Sub Remove(GroupName As String)
If Not Exist(GroupName) Then Exit Sub
Dim objGroup As Group
Set objGroup = colGroups.Item(CStr(GroupName))
Call objGroup.Dispose
Set objGroup = Nothing
colGroups.Remove CStr(Name)
End Sub

Public Sub Clear()
Dim objGroup As Group
While colGroups.Count > 0
  Set objGroup = colSections.Item(1)
  Call objGroup.Dispose
  Set objGroup = Nothing
  colSections.Remove 1
Wend
End Sub

Public Property Get NewEnum() As IUnknown
Set NewEnum = colGroups.[_NewEnum]
End Property

Public Sub Create()
'Nothing
End Sub

Public Sub Dispose()
Call Clear
End Sub

Private Sub Class_Initialize()
Set colGroups = New Collection
Call Create
End Sub

Private Sub Class_Terminate()
Call Dispose
Set colGroups = Nothing
End Sub


Код: Выделить всё

'Group
Option Explicit

Private objParent As Groups
Private objUnits As Units

Private vName As String

Friend Sub SetName(ByVal NewName As String)
vName = NewName
End Sub

Public Property Get Name() As String
Name = vName
End Property

Public Property Get Units() As Units
Set Units = colUnits
End Property

Public Property Get NewEnum() As IUnknown
Set NewEnum = objUnits.[_NewEnum]
End Property

Public Sub Create(Optional Parent As Groups)
Set objParent = Parent
Set objUnits = New Units
objUnits.Create Me
End Sub

Public Sub Dispose()
objUnits.Dispose
Set objUnits = Nothing
Set objParent = Nothing
End Sub

Private Sub Class_Initialize()
Call Create
End Sub

Private Sub Class_Terminate()
Call Dispose
End Sub


Код: Выделить всё

'Units
Option Explicit

Private objParent As Group
Private colUnits As Collection

Public Function Exist(UnitName As String) As Boolean
...
End Function

Public Function Add(UnitName As String) As Group
If Len(UnitName ) = 0 Then Exit Function
If Exist(UnitName ) Then Exit Function
Dim objUnit As Unit
Set objUnit = New Unit
objUnit.Create Me
objUnit.SetName UnitName
colUnits.Add Key:=CStr(ObjPtr(objUnit)), Item:=objUnit
Set Add = objUnit
Set objUnit = Nothing
End Function

Public Property Get Item(ByVal Index As Long) As Unit
If Index < 1 Or Index > colUnits.Count Then Exit Property
Set Item = colUnits.Item(Index)
End Property

Public Property Get Count() As Long
Count = colUnits.Count
End Property

Public Sub Remove(ByVal Index As Long)
If Index < 1 Or Index > colUnits.Count Then Exit Sub
Dim objUnit As Unit
Set objUnit = colUnits.Item(Index)
Call objUnit.Dispose
Set objUnit = Nothing
colUnits.Remove Index
End Sub

Public Sub Clear()
Dim objUnit As Unit
While colUnits.Count > 0
  Set objUnit = colUnits.Item(1)
  Call objUnit.Dispose
  Set objUnit = Nothing
  colUnits.Remove 1
Wend
End Sub

Public Property Get NewEnum() As IUnknown
Set NewEnum = colUnits.[_NewEnum]
End Property

Public Sub Create(Parent As Groups)
Set objParent = Parent
End Sub

Public Sub Dispose()
Call Clear
Set objParent = Nothing
Set colUnits = Nothing
End Sub

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

Private Sub Class_Terminate()
Call Dispose
End Sub


Код: Выделить всё

'Unit
Option Explicit

Private objParent As Units

Private vName As String

Friend Sub SetName(ByVal NewName As String)
vName = NewName
End Sub

Public Property Get Name() As String
Name = vName
End Property

Public Sub Create(Optional Parent As Units)
Set objParent = Parent
End Sub

Public Sub Dispose()
Set objParent = Nothing
End Sub

Private Sub Class_Initialize()
'Nothing
End Sub

Private Sub Class_Terminate()
Call Dispose
End Sub


Что-то подобное. Вроде бы ошибок в процессе набора не сделал

[Antonariy]

Это ты только что натоптал? Мужык
Переделывать нереально, да и уже незачем - эту гадость я отловил. Класс2 содержит класс-коллекцию классов2, которая должна уничтожаться вместе с экземпляром класса2, в этой-то коллекции и сидела еще одна ссылка. Пришлось убивать коллекцию принудительно по событию Destroy, не дожидаясь Class2_Terminate, который иначе никогда не произойдет.

Тем не менее вопрос все еще вызывает интерес.