按照AdamBear(学习再学习)给出的创建IUnknown接口的方法，创建了一个可以使用的COM接口替代一个VB Class，挺有意思

[lihanbing]

按照AdamBear(学习再学习)给出的创建IUnknown接口的方法，
创建了一个可以使用的COM接口替代一个VB Class，挺有意思
下面的代码大部分来自AdamBear(学习再学习)给出的代码例子，
在原来的基础上添加了一个类Class1，然后创建了一个和Class1兼容的接口，
这样就可以通过Class1来调用这个接口的方法

'***************************************************************
' Class1
'***************************************************************
Option Explicit

Public Sub RightMove(ByRef a As Long, ByRef b As Long)
'这个方法没有备用到过，因为这个类都没有创建过
'只是通过它调用下面创建出的接口中对应的函数
End Sub

'***************************************************************
' Module1
'***************************************************************
Option Explicit

'从逻辑上下面的实验代码应该放在另一个标准模块内。


'下面的代码应放在标准模块内。
' 仅仅是演示IUnknown接口
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'声明IUnknown的vTable结构，它有三个入口
Private Type IUnknownVTables
'VTables(2) As Long
'改为Class1的结构，有8个入口
VTables(7) As Long
End Type

'vTables存在这儿
Private m_VTables As IUnknownVTables


'声明IUnknown接口指针结构
Public Type IUnknownInterface
pVTable As Long
End Type

'声明接口指针
Private m_IUnknown As IUnknownInterface

Dim bin(5) As Long

Sub Main()
'本演示代码只能用于IUnknown，虽然你能将它Set成任何接口，
' 但是一旦使用它，就……
Dim obj1 As IUnknown, obj2 As Shape, obj3 As Class1

'填入二进制代码执行的是a=a>>b
bin(0) = &HC24448B
bin(1) = &H448B088B
bin(2) = &H108B0824
bin(3) = &H1089EAD3
bin(4) = &HCC2C033
bin(5) = &H90909000
'bin(0) = &H90000CC2

'Set obj1 = CreateIUnknown()
'可以Set，但不要使用obj2任何属性或方法
'Set obj2 = obj1
'下面的语句会死掉
'obj2.Move 0, 0, 100, 100

'obj2.BackColor = 222
'Set obj1 = Nothing
Dim a As Long, b As Long
'创建一个兼容于Class1的接口
Set obj3 = CreateIUnknown()
a = &HFFFFFFFF
b = 8
'调用Class1的RightMove方法，实际上是调用了IUnknownVTables.VTables(7)所指向的函数
obj3.RightMove a, b
Set obj3 = Nothing
MsgBox Hex(a)
End Sub

'凭空构造一个什么都不做的IUnknown接口
Public Function CreateIUnknown() As Class1 'IUnknown
'开始构造IUnknown的三个入口
With m_VTables
.VTables(0) = FuncPtr(AddressOf QueryInterface)
.VTables(1) = FuncPtr(AddressOf AddRefRelease)
.VTables(2) = FuncPtr(AddressOf AddRefRelease)
.VTables(3) = FuncPtr(AddressOf GetTypeInfoCount)
.VTables(4) = FuncPtr(AddressOf GetTypeInfo)
.VTables(5) = FuncPtr(AddressOf GetIDsOfNames)
.VTables(6) = FuncPtr(AddressOf Invoke)
'用这一行将调用下面的RightMove函数
'.VTables(7) = FuncPtr(AddressOf RightMove)
'而用这一行则调用数组bin里的二进制代码
.VTables(7) = VarPtr(bin(0))
'建立IUnknown接口指针
m_IUnknown.pVTable = VarPtr(.VTables(0))
End With

CopyMemory CreateIUnknown, VarPtr(m_IUnknown), 4
End Function

'得到函数指针
Private Function FuncPtr(ByVal pfn As Long) As Long
FuncPtr = pfn
End Function

'注意，下面仅仅是演示，正确的QI应该根据riid的接口ID，来返回符合要求的接口，
' 或者返回E_NOINTERFACE，以表示不支持要求的接口
Private Function QueryInterface(This As IUnknownInterface, riid As Long, pvObj As Long) As Long
'所有通过接口ID请求接口指针的要求，都返回我们的IUnknown接口指针
' 这里仅仅是演示技术可性行，这样做非常危险，
' 因为我们这里接受所有接口请求，而返回的并不是要求的接口，
' 一旦你用比IUnknown接口的vTable大的接口来访问（除了IUnknown接口外所有接口
' 都比IUnknown接口大），所以不要用别的接口来访问，否则，嘿嘿。
pvObj = VarPtr(This)
Debug.Print "请求返回特定的接口，其请求的riid是：" & riid
End Function

'AddRef和Release都对应到这儿。
Private Function AddRefRelease(ByVal This As Long) As Long
'什么都不做，因为我们没有分配内存，不需要跟踪引用计数
Debug.Print "对我们的IUnknown进行了引用，或将它设成了NoThing"
End Function

'下面的四个函数是IDispatch接口所拥有的函数，基本上所有COM对象都继承此接口
Function GetTypeInfoCount(ByVal This As Long, ByVal pctinfo As Long) As Long

End Function

Function GetTypeInfo(ByVal This As Long, ByVal iTInfo As Long, ByVal lcid As Long, ByVal ppTInfo As Long) As Long

End Function

Function GetIDsOfNames(ByVal This As Long, ByVal riid As Long, ByVal rgszNames As Long, ByVal cNames As Long, ByVal lcid As Long, ByVal rgDispId As Long) As Long

End Function

Function Invoke(ByVal This As Long, ByVal dispIdMember As Long, ByVal riid As Long, ByVal lcid As Long, ByVal wFlags As Long, ByVal pDispParams As Long, ByVal pVarResult As Long, ByVal pExcepInfo As Long, ByVal puArgErr As Long) As Long

End Function

'这个函数用来替换Class1中的RightMove
Function RightMove(ByVal This As Long, ByRef a As Long, ByRef b As Long) As Long
MsgBox "sssssssssssss" & a
End Function