VB6拾遗：轻量级COM对象

在VB6中可以用类模块来实现COM对象，其实用UDT（用户定义类型）也可以。

COM只不过是一种二进制标准，只要能在内存中构造出符合这种标准的数据结构，就能实现COM对象。

以下代码摘自Matthew Curland的《Advanced Visual Basic 6》：

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
    
Const E_NOINTERFACE As Long = &H80004002

Private Type LightEmptyVTable
    VTable(2) As Long
End Type

Public Type LightEmpty
    pVTable As Long
End Type

Private m_VTable As LightEmptyVTable
Private m_pVTable As Long

Sub Main()
    Dim LE As LightEmpty
    InitializeLightEmpty LE
End Sub

Public Function InitializeLightEmpty(LE As LightEmpty) As IUnknown
    If m_pVTable = 0 Then
        With m_VTable
            .VTable(0) = FuncAddr(AddressOf QueryInterface)
            .VTable(1) = FuncAddr(AddressOf AddRef)
            .VTable(2) = FuncAddr(AddressOf Release)
            m_pVTable = VarPtr(.VTable(0))
        End With
    End If
    
    With LE
        .pVTable = m_pVTable
        CopyMemory InitializeLightEmpty, VarPtr(.pVTable), 4
    End With
End Function

Private Function QueryInterface _
    (This As LightEmpty, riid As Long, pvObj As Long) As Long
    Debug.Assert False
    pvObj = 0
    QueryInterface = E_NOINTERFACE
End Function

Private Function AddRef(This As LightEmpty) As Long
    Debug.Assert False
End Function

Private Function Release(This As LightEmpty) As Long
    MsgBox "LightEmpty->Release"
End Function

Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function

用结构体（VB6中的户定义类型相当于C语言中的结构体）构造出COM对象，与Jeff Glatt的《COM in plain C》有异曲同工之妙。

问题是VB6为什么会自动调用Release函数？还是得看一下汇编代码：

004018A1  lea     eax, [ebp-14]
004018A4  push    eax
004018A5  call    Module2::InitializeLightEmpty   ; [Module2::InitializeLightEmpty
004018AA  push    eax                             ; /Arg2
004018AB  lea     eax, [ebp-18]                   ; |
004018AE  push    eax                             ; |Arg1 => offset LOCAL.6
004018AF  call    @__vbaObjSet                    ; \MSVBVM60.__vbaObjSet
004018B4  lea     ecx, [ebp-18]
004018B7  call    @__vbaFreeObj                   ; [MSVBVM60.__vbaFreeObj

关键在于InitializeLightEmpty函数的返回值类型是IUnknown，虽然我们并没有用变量保存返回值，但是VB还是会生成一个临时变量来保存。由于该变量的类型是对象，所以要调用__vbaFreeObj来释放对象，__vbaFreeObj内部会调用对象的Release方法，即我们在模块中定义的Release函数。

当然，这个例子并没有太大的实用价值，只不过相当于实现了一个有Class_Terminate事件的结构体。要想实现功能上可以和类模块相媲美的轻量级对象，还必须借助IDL。

比如我们要实现一个DemonBlog对象，该对象有一个Url属性和一个Open方法，可以这么做：

首先写一个IDL定义接口并用midl.exe编译成.tlb添加到VB引用：

[
  uuid(EF6CB73E-01F6-42C9-A560-F3A1B92DC8F8),
  version(1.0)
]
library DemonBlogLib
{
    importlib("stdole2.tlb");

    [
      odl,
      uuid(7694E9F7-238E-43BC-B05F-34C08751E2E0),
      nonextensible
    ]
    interface IDemonBlog : IUnknown {
        [propget]
        HRESULT _stdcall Url([out, retval] BSTR* retVal);
        HRESULT _stdcall Open();
    };
};

新建一个标准模块，代码如下：

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteW" ( _
     ByVal hwnd As Long, _
     ByVal lpOperation As Long, _
     ByVal lpFile As Long, _
     ByVal lpParameters As Long, _
     ByVal lpDirectory As Long, _
     ByVal nShowCmd As Long) As Long

Const E_NOINTERFACE As Long = &H80004002

Private Type DemonBlogVTable
    VTable(4) As Long
End Type

Public Type DemonBlog
    pVTable As Long
End Type

Private m_VTable As DemonBlogVTable
Private m_pVTable As Long

Public Function InitializeDemonBlog(LE As DemonBlog) As IDemonBlog
    If m_pVTable = 0 Then
        With m_VTable
            .VTable(0) = FuncAddr(AddressOf QueryInterface)
            .VTable(1) = FuncAddr(AddressOf AddRef)
            .VTable(2) = FuncAddr(AddressOf Release)
            .VTable(3) = FuncAddr(AddressOf GetUrl)
            .VTable(4) = FuncAddr(AddressOf OpenBlog)
            m_pVTable = VarPtr(.VTable(0))
        End With
    End If
    
    With LE
        .pVTable = m_pVTable
        CopyMemory InitializeDemonBlog, VarPtr(.pVTable), 4
    End With
End Function

Private Function QueryInterface _
    (This As DemonBlog, riid As Long, pvObj As Long) As Long
    Debug.Assert False
    pvObj = 0
    QueryInterface = E_NOINTERFACE
End Function

Private Function AddRef(This As DemonBlog) As Long
    Debug.Assert False
End Function

Private Function Release(This As DemonBlog) As Long
    MsgBox "DemonBlog->Release"
End Function

Private Function GetUrl(This As DemonBlog, Url As String) As Long
    Url = "https://demon.tw"
End Function

Private Function OpenBlog(This As DemonBlog) As Long
    ShellExecute 0, StrPtr("open"), StrPtr("https://demon.tw"), 0, 0, 1
End Function

Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function

再添加一个标准模块，代码如下：

Sub Main()
    Dim DB As DemonBlog
    Dim IDB As IDemonBlog
    
    Set IDB = InitializeDemonBlog(DB)
    MsgBox IDB.Url
    IDB.Open
End Sub

然后可以运行看看效果如何，还不错吧？可能有人要问，用类模块几行代码搞定的事，这样费尽周折的使用轻量级对象到底有什么意义？如果我说这样效率更高（普通对象在堆上分配内存，轻量级对象在堆栈上分配内存），你一定会笑掉大牙。说实话，就本例而已，意义不大。但是不要小看轻量级对象，用它可以实现一些VB6看上去无法实现的东西。

随机文章:

1. VBS调用WMI遍历搜索硬盘文件并计数
2. 在Raspberry Pi树莓派上编译Node.js
3. VBS实现Unicode(UTF-16)转UTF-8
4. 在VBS中执行Javascript语句
5. 用VBS实现Discuz论坛自动回帖程序

这篇文章发布于 2013年09月15日，星期日，20:24，归类于 程序设计。 您可以跟踪这篇文章的评论通过 RSS 2.0 feed。 您可以留下评论，或者从您的站点trackback。