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 Scripting.Dictionary字典对象按键名Key进行冒泡排序
  2. PT流量作弊工具之RatioMaster
  3. 在VBS中执行Javascript语句
  4. Unicode中的Enclosed CJK Letters and Months
  5. VB6.0中的“取消 Pentium(tm) FDIV 安全性检查”

5 条评论 发表在“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

  3. 神梦无痕说道:

    怎么传递参数呢?

  4. yjgyjgg说道:

    Private Declare Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” (Destination As Any, Source As Any, ByVal Length As Long)
    Declare Function DispCallFunc Lib “oleaut32.dll” (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Function lstrlenW Lib “kernel32.dll” (ByVal lpString As Long) As Long

    Const E_NOINTERFACE As Long = &H80004002

    Private Type DemoVTable
    QueryInterface As Long
    AddRef As Long
    Release As Long
    GetTypeInfoCount As Long
    GetTypeInfo As Long
    GetIDsOfNames As Long
    Invoke As Long
    OpenDemo As Long
    End Type

    Public Type Demo
    pVTable As Long
    cRef As Long
    End Type
    Const E_NOTIMPL = &H80004001
    Public Function NewDemo() As Object

    Static m_VTable As DemoVTable, LE As Demo
    With m_VTable
    .QueryInterface = FuncAddr(AddressOf QueryInterface) ‘0
    .AddRef = FuncAddr(AddressOf AddRef) ‘4
    .Release = FuncAddr(AddressOf Release) ‘8
    .GetTypeInfoCount = FuncAddr(AddressOf GetTypeInfoCount) ’12
    .GetTypeInfo = FuncAddr(AddressOf GetTypeInfo) ’16
    .GetIDsOfNames = FuncAddr(AddressOf GetIDsOfNames) ’20
    .Invoke = FuncAddr(AddressOf Invoke) ’24
    .OpenDemo = FuncAddr(AddressOf OpenDemo) ’28
    End With
    LE.pVTable = VarPtr(m_VTable)
    CopyMemory NewDemo, VarPtr(LE), 4

    End Function

    Private Function QueryInterface(This As Demo, riid As Long, pvObj As Long) As Long

    ‘QueryInterface = E_NOINTERFACE
    If riid = -1315523965 Then
    pvObj = 0
    QueryInterface = E_NOTIMPL
    Else
    pvObj = VarPtr(This)
    QueryInterface = 0
    Exit Function
    End If
    QueryInterface = E_NOTIMPL
    End Function

    Private Function AddRef(This As Demo) As Long
    This.cRef = This.cRef + 1
    End Function

    Private Function Release(This As Demo) As Long
    This.cRef = This.cRef – 1
    End Function

    Function GetTypeInfoCount(This As Demo, ByVal pctinfo As Long) As Long
    GetTypeInfoCount = 0
    pctinfo = 0
    GetTypeInfoCount = E_NOTIMPL
    End Function

    Function GetTypeInfo(This As Demo, ByVal iTInfo As Long, ByVal lcid As Long, ByVal ppTInfo As Long) As Long
    iTInfo = 0
    ppTInfo = 0
    GetTypeInfo = E_NOTIMPL
    End Function

    Function GetIDsOfNames(This As Demo, ByVal riid As Long, ByVal rgszNames As Long, ByVal cNames As Long, ByVal lcid As Long, ByRef rgDispId As Long) As Long
    Dim b() As Byte, s As String, L As Long
    CopyMemory L, ByVal rgszNames, 4
    ReDim b(lstrlenW(L) * 2 – 1)
    CopyMemory b(0), ByVal L, lstrlenW(L) * 2
    s = b
    Select Case s
    Case “test”
    rgDispId = 1
    Case “ttt”
    rgDispId = 2
    End Select
    End Function

    Function Invoke(This As Demo, ByVal dispIdMember As Long, ByVal riid As Long, ByVal lcid As Long, ByVal wFlags As Long, ByVal pDispParams As Long, ByVal pVarResult As Variant, ByVal pExcepInfo As Long, ByVal puArgErr As Long) As Long
    Select Case dispIdMember
    Case 1
    MsgBox “测试”
    Case 2
    MsgBox “ttt”
    End Select
    End Function

    Function OpenDemo(This As Demo) As Long
    MsgBox “test”
    End Function

    Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
    End Function
    调用
    Dim IDB As Object
    Set IDB = NewDemo
    Debug.Print ObjPtr(IDB)
    IDB.test (“123”)
    IDB.ttt

留下回复