废话少说，直接上代码。
1、VB ActiveEXE 工程。
2、Form1 + Module1 + Class1
3、Form1 Code
Private
Sub
Form_Unload(Cancel
As
Integer
)
Set
oClass1
=
Nothing
End Sub
4、Module1 Code
Option
Explicit
Public
oClass1
As
Class1
Sub
Main()
Set
oClass1
=
New
Class1
Form1.Show
End Sub
5、Class1 Code
Option
Explicit
Private
mPatientID
As
String
Private
Type GUIDs
Data1
As
Long
Data2
As
Integer
Data3
As
Integer
Data4(
0
To
7
)
As
Byte
End
Type
‘
Declares needed to register object in the ROT (Run Object Table)
Private
Const
ACTIVEOBJECT_STRONG
=
0
Private
Const
ACTIVEOBJECT_WEAK
=
1
Private
Declare
Function
CLSIDFromProgID Lib
”
ole32.dll
”
(ByVal ProgID
As
Long
, rclsid
As
GUIDs)
As
Long
Private
Declare
Function
CoDisconnectObject Lib
”
ole32.dll
”
(ByVal pUnk
As
IUnknown, pvReserved
As
Long
)
As
Long
Private
Declare
Function
RegisterActiveObject Lib
”
oleaut32.dll
”
(ByVal pUnk
As
IUnknown, rclsid
As
GUIDs, ByVal dwFlags
As
Long
, pdwRegister
As
Long
)
As
Long
Private
Declare
Function
RevokeActiveObject Lib
”
oleaut32.dll
”
(ByVal dwRegister
As
Long
, ByVal pvReserved
As
Long
)
As
Long
Private
OLEInstance
As
Long
Public
Property
Let
PatientID(ByVal Value
As
String
)
mPatientID
=
Value
End Property
Public
Property
Get
PatientID()
As
String
PatientID
=
mPatientID
End Property
Public
Sub
AddToROT()
Dim
mGuid
As
GUIDs
Dim
lp
As
Long
‘
The magic happens here
‘
This code is responsible for creating the entry in the ROT
‘
Make sure to insert the correct qualified object (class) that
‘
you want in the ROT.
OLEInstance
=
0
lp
=
CLSIDFromProgID(StrPtr(
”
Project1.Class1
”
), mGuid)
If
lp
=
0
Then
lp
=
RegisterActiveObject(Me, mGuid, ACTIVEOBJECT_WEAK, OLEInstance)
End
If
End Sub
Public
Sub
RemoveFromROT()
‘
Once we are done with the main program, lets clean up the rot
‘
by removing the entry for our ActiveX Server/DLL
If
OLEInstance
<>
0
Then
RevokeActiveObject OLEInstance,
0
End
If
CoDisconnectObject Me,
0
End Sub
Private
Sub
Class_Initialize()
AddToROT
mPatientID
=
”
123456
”
End Sub
Private
Sub
Class_Terminate()
RemoveFromROT
End Sub
6、编译，生成EXE，运行。
7、Test Code
Private
Sub
Command1_Click()
Dim
oTestObject
As
Object
Set
oTestObject
=
GetObject
(,
”
Project1.Class1
”
)
If
oTestObject
Is
Nothing
Then
MsgBox
”
Error
”
Else
MsgBox oTestObject.patientid
End
If
End Sub