为什么Terminate事件没有触发？

zlcnkkm

先看代码

'==================================================================================================
'        鼠标类
'==================================================================================================

Option Explicit
Implements DirectXEvent8

Private Const W_BUFFER_SIZE = 2
Private w_Devices As DirectInputDevice8
Private w_EventHandle As Long
Private w_hDeviceWindow As Long
Private w_MouseData(1 To W_BUFFER_SIZE) As DIDEVICEOBJECTDATA
Private w_NumItems As Byte
Private w_DoubleClickTime As Long
Private w_LastClickTime(12 To 19) As Long
Private w_clientRect As RECT
Private w_clientRectWidth As Long
Private w_clientRectHeight As Long

'******************************************************************************************
'    捕捉区域
'

Public Property Get rectX() As Long
    rectX = w_clientRect.Left
End Property

Public Property Let rectX(newRectX As Long)
    w_clientRect.Left = newRectX
End Property

Public Property Get rectY() As Long
    rectY = w_clientRect.Top
End Property

Public Property Let rectY(newRectY As Long)
    w_clientRect.Top = newRectY
End Property

Public Property Get rectWidth() As Long
    rectWidth = w_clientRectWidth
End Property

Public Property Let rectWidth(newRectWidth As Long)
    w_clientRectWidth = newRectWidth
    w_clientRect.Right = w_clientRect.Left + newRectWidth
End Property

Public Property Get rectHeight() As Long
    rectHeight = w_clientRectHeight
End Property

Public Property Let rectHeight(newRectHeight As Long)
    w_clientRectHeight = newRectHeight
    w_clientRect.bottom = w_clientRect.Top + newRectHeight
End Property

Public Property Get clientRect() As RECT
    clientRect = w_clientRect
End Property

Public Property Let clientRect(newRect As RECT)
    w_clientRect = newRect
End Property


'******************************************************************************************
'    初始化鼠标程序 initMouse()
'
'                       DevicehWnd  窗体句柄
'

'使用DirectMouse会隐藏鼠标指针
Public Function initMouse(DevicehWnd As Long) As Boolean
    Set w_Devices = WDInput.CreateDevice("guid_SysMouse")
   
    w_Devices.SetCommonDataFormat DIFORMAT_MOUSE '3键3轴鼠标
    On Error GoTo invalidhWnd
    w_Devices.SetCooperativeLevel DevicehWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE 'DISCL_FOREGROUND Or DISCL_EXCLUSIVE
   
    w_hDeviceWindow = DevicehWnd
   
    '指定w_Devices取得消息
    w_EventHandle = WDDX.CreateEvent(Me)
    w_Devices.SetEventNotification w_EventHandle

    Dim diProp As DIPROPLONG
    diProp.lHow = DIPH_DEVICE
    diProp.lObj = 0
    diProp.lData = W_BUFFER_SIZE    'W_BUFFER_SIZE为局部常量
   
    w_Devices.SetProperty "DIPROP_BUFFERSIZE", diProp
    w_Devices.Acquire
   
    '先定捕捉区域
    Dim clientRect As RECT
    GetClientRect w_hDeviceWindow, w_clientRect
   
    w_DoubleClickTime = GetDoubleClickTime
   
    initMouse = True
    Exit Function
   
invalidhWnd:
    initMouse = False
End Function

Private Sub DirectXEvent8_DXCallback(ByVal eventid As Long)
    If w_Devices Is Nothing Then Exit Sub
   
    On Error Resume Next
    w_NumItems = w_Devices.GetDeviceData(w_MouseData, 0)
   
    If Err.Number = DIERR_NOTACQUIRED Or Err.Number = DIERR_INPUTLOST Then
        'Dim CursorPoint As POINTAPI
        
        ' Move private cursor to system cursor.
        'Call GetCursorPos(CursorPoint)  ' Get position before Windows loses cursor
        'Call ScreenToClient(w_hDeviceWindow, CursorPoint)
        w_Devices.Acquire
        Exit Sub
    End If
   
    'Debug.Print w_clientRect.Top & " " & w_clientRect.bottom
    Dim tmpX As Long, tmpY As Long
    Dim CursorPoint As POINTAPI
               
    GetCursorPos CursorPoint
    ScreenToClient w_hDeviceWindow, CursorPoint
    tmpX = CursorPoint.X
    tmpY = CursorPoint.Y
   
    If tmpX >= w_clientRect.Left And tmpX <= w_clientRect.Right And _
    tmpY >= w_clientRect.Top And tmpY <= w_clientRect.bottom Then
        Dim i As Byte
        Dim mdd As WD_ENUM_INPUT_MESSAGE
        For i = 1 To w_NumItems
            mdd = w_MouseData(i).lOfs
            Select Case mdd
            
                '  同时加入鼠标的相对位置和绝对位置消息
                '      WD_MOUSE_X (WD_MOUSE_Y)  标签为鼠标移动的相对位置
                '      WD_MOUSE_POSITION_X (WD_MOUSE_POSITION_Y)  标签为鼠标的绝对位置
                Case WD_MOUSE_X
                    queueUpMsg WD_INPUT_DEVICES_MOUSE, mdd, CInt(w_MouseData(i).lData)
                    queueUpMsg WD_INPUT_DEVICES_MOUSE, WD_MOUSE_POSITION_X, CLng(tmpX)
                Case WD_MOUSE_Y
                    queueUpMsg WD_INPUT_DEVICES_MOUSE, mdd, CInt(w_MouseData(i).lData)
                    queueUpMsg WD_INPUT_DEVICES_MOUSE, WD_MOUSE_POSITION_Y, CLng(tmpY)
               
                '滚轮的位移
                Case WD_MOUSE_Z
                    queueUpMsg WD_INPUT_DEVICES_MOUSE, mdd, CInt(w_MouseData(i).lData)
                    
                '按键状态设定
                '  -1 按下
                '   0 释放
                '   2 双击
                Case 12 To 19
                    Dim buttonsState As Boolean
                    buttonsState = CBool(w_MouseData(i).lData)
                    
                    queueUpMsg WD_INPUT_DEVICES_MOUSE, mdd, CInt(buttonsState)
                    
                    '双击按键消息
                    If buttonsState Then
                        Dim subtractTime As Long
                        
                        subtractTime = GetTickCount - w_LastClickTime(mdd)
                        If subtractTime <= w_DoubleClickTime Then
                            queueUpMsg WD_INPUT_DEVICES_MOUSE, mdd, 2
                        End If
                        w_LastClickTime(mdd) = GetTickCount
                    End If
                    
                Case Else
                    queueUpMsg WD_INPUT_DEVICES_MOUSE, w_MouseData(i).lOfs, CInt(w_MouseData(i).lData)
            End Select
        Next
    End If

End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    If w_EventHandle <> 0 Then WDDX.DestroyEvent w_EventHandle

    If Not w_Devices Is Nothing Then w_Devices.Unacquire
   
    Set w_Devices = Nothing
End Sub

此类不能由用户创建，只能让另一个类创建并收集消息（就是输入设备管理类），但测试中发现，管理类执行Set Nothing后，此鼠标类的Terminate事件没有触发，到底是什么原因？请指教

bigbook2000

看这个代码有什么用？主要是看你实例化该类的代码和释放该类的代码

VB6中的内存管理效率还是不算太差的，对象的释放一般不由用户自己控制，即使你调用了Set Nothing，系统会自己确定引用计数是否为0，如果为0，则调用Terminate方法

bigbook2000

此类不能由用户创建，只能让另一个类创建并收集消息（就是输入设备管理类），但测试中发现，管理类执行Set Nothing后

你究竟释放的是哪个类，如果你直接释放了鼠标类，一般不会出现这种情况，如果你直接释放的是管理类，则原则同上

zlcnkkm

哦哦，不好意思，没说清楚。如 bigbook2000 所说，释放的是鼠标类，而且是由管理类执行Set Nothing的，再说，鼠标类只能由管理类创建

说明一下大致的运作方式：管理类创建及注销各输入设备类，并且创建一个队列收集各输入设备的消息；各输入设备类使用回调来响应硬件消息，经处理后向管理类的队列中加入消息。就这样子

bigbook2000

这是一个比较有意思的问题，VB中的内存释放一直是被人忽略，但在游戏开发中却是必须考虑的问题

VB中的对象释放是不能由用户自己管理的，采用的是一种叫做引用计数的技术，到了.NET发展为GC垃圾回收器，不过.NET的垃圾回收器正如他的名字一样非常垃圾

转入正题

假设我们定义了一个用户类(User Class)MyClass

然后我们在别的地方进行实例化

Sub Test()
    Dim a as New MyClass
End Sub

我们在过程Test中生成了一个MyClass实例a，那么当代码执行到End Sub的时候，VB会检测到其他地方不会再使用a了，这个时候，就会调用MyClass的Class_Terminate方法，释放掉a的内存

那么我们再来看一个例子

Dim a as MyClass

Sub Test()
    Set a = New MyClass
End Sub

Sub Release()
    Set a = Nothing
End Sub

这个例子中，当我们调用的Release，执行到Set a = Nothing时候，也会调用MyClass的Class_Terminate方法

再看第三个例子

Dim a as MyClass
Dim b as MyClass

Sub Test()
    Set a = New MyClass
    Set b = a
End Sub

Sub Release()
    Set a = Nothing
End Sub

那么到了调用Release，执行到Set a = Nothing时候，我们会发现并没有调用MyClass的Class_Terminate方法，为什么呢，因为还有一个b在引用a，所以VB并不释放a的内存，实际上b和a是同一个东西，共用同一块内存，对b进行操作就是对a进行操作，反过来也一样，遇到这种情况，我们必须Set b = Nothing，其实如果我们不掉用Set a = Nothing和Set b = Nothing，当整个模块被释放的时候，也会把a和b释放，除非整个模块的引用计数也不为0

就像上面的问题，当设备管理类调用Class_Terminate方法的时候会主动调用鼠标类的Class_Terminate方法，除非鼠标类在其他地方还有引用实例

VB的内存管理机制基本上就是这样，当我们开发游戏的时候，我们时刻要记住的是我们的资源是庞大的，内存是有限的，记得及时释放内存

bigbook2000

顶一下，希望用VB6编写游戏的人能像楼主一样关注这个问题

zlcnkkm

这个问题不是单纯的Set Nothing，哎~~~暂时用不了自家的机子，不能全面调试它，不过我已经检查过N*M次了，不是你们想的那样

问题出在DX那个回调函数，如果把类模块中的有关这个回调的代码全部注释掉的话（所以我把代码帖上来，工程源码可以找找我以前的帖），类的Terminate事件就能触发了，由于我对回调这东东没有研究，所以来请教各位高手！

bigbook2000

VB6的代码就是这样的，如果没有异常，就是通过引用计数实现对象管理，不管是什么，显示的调用Set Nothing，还是隐式的对象释放，如果出现明明写了Set Nothing却不调用Terminate事件，就证明有别的地方在使用它

所谓回调函数，其实是个函数指针

你声明了这个对象Implements DirectXEvent8，并实现了回调函数，意味着这个对象将被其他的对象引用，除非引用他的对象释放，否则不会调用Terminate函数的

zlcnkkm

哦，明白了一点……

但是，声明了Implements DirectXEvent8以后，这个对象还会被谁引用？DirectX8吗？