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 = "http://demon.tw"
End Function

Private Function OpenBlog(This As DemonBlog) As Long
    ShellExecute 0, StrPtr("open"), StrPtr("http://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. GetFileInformationByHandle函数
  2. 文件属性中“大小”和“占用空间”的区别
  3. VBS基础教程第五篇
  4. VBS获取文件的SDDL字符串
  5. “WindowsLive.Writer.CoreServices.HttpRequestHelper”的类型初始值设定项引发异常

2 条评论 发表在“VB6拾遗:轻量级COM对象”上

  1. coo_boi说道:

    awesome job! man,ur so cool & pro. expecting your next work.

  2. wcymiss说道:

    Demon,我发现用dispcallfunc可以不借助IDL:
    Sub Main()
    Dim DB As DemonBlog
    Dim IDB As IUnknown
    Dim URL As String
    Dim ret As Long
    Set IDB = InitializeDemonBlog(DB)
    Call DispCallFunc(ObjPtr(IDB), 12, 1, vbLong, 1, vbLong, VarPtr(VarPtr(URL)) – 8, ret)
    Call DispCallFunc(ObjPtr(IDB), 16, 1, vbLong, 0, 0, 0, ret)
    End Sub

留下回复