IT-Consultant: Frederick J. Harris > Fred's COM (Component Object Model) Tutorials
COM Tutorial #3: Building Local Server With Low Level PowerBASIC Code
Frederick J. Harris:
--- Code: ---#if 0
Here is an example of how to use low level code with PB Win90 to create an out of process COM server which
can be run as a simple stand alone exe by simply executing it, or it can be connected to through the COM system
in the manner of Excel or Word. The program creates an object named class "CC", and the object exposes two
interfaces, e.g., an IX interface and an IY interface. These interfaces contain the worthless functionality
of allowing an integer and a dynamic string to be 'Get/Set'. While useless in a practical sense, it does show
how to create functionality in an out of process COM server object using low level PowerBASIC code.
If started as a stand alone exe by a user, it presents a visual interface where the IX and IY interfaces of
class CC can be exercised to store/retrieve integers and strings. If started by COM's Service Control Manager
(after being registered by using the /r switch on the program's command line when started from a command prompt),
it won't provide any visual interface, but its COM interfaces will be available in the normal programatic manner (while
it won't provide a GUI if started by COM, it will pop up a console window to show what's going on inside it).
My previous two COM examples ( CA and CB ) didn't have much in the way of instance variables, but this one CC -
does, i.e., the integer and string member variables. The string is especially interesting in that it shows
how PowerBASIC strings must be dealt with low level, i.e., at the level of BSTRs, which are OLE COM length
prefixed null terminated strings. To give you an idea of what I'm speaking of, if it hasn't already dawned on
you, if any of the interface functions must get/set a string, that string must be retained in a member variable
of the class CC - which in low level COM is created through a PowerBASIC Type. And Types can't contain dynamic
variable length strings - only fixed length null terminated asciiz strings. So, to store a BSTR (PowerBASIC
Dynamic String) in a Type one must revert to a more primitive form which would be some form of pointer variable
(I used Dword Ptrs here, but any kind of pointer would work, or even just a Dword. Note that if you needed to
dereference the pointer and get at the actual characters, you would need something that incr/decr in 16 bit
steps as its pointing to a unicode character)....
Type CC 'This is an example of what a class looks like in 'low level' COM
lpIX As IXVtbl Ptr 'pointer to IX VTable
lpIY As IYVtbl Ptr 'pointer to IY VTable
m_iXInt As Long 'member (instance) variable of integral type in IX interface
m_iYInt As Long 'member (instance) variable of integral type in IY interface
m_XText As Dword Ptr 'BSTRs are allocated with the OLE String Engine using functions such as
m_YText As Dword Ptr 'SysReAllocString() or SysAllocStringLen() and a pointer is returned.
m_cRef As Long 'reference counting variables for outstanding interfaces of class
End Type
Check out the GetXText() / SetXText() and GetYText() / SetYText() interface functions and you'll see how that's
done. Setting it up like this creates Strings that act exactly like BASIC Dynamic Strings to clients be they
Visual Basic or PowerBASIC. This nastiness becomes an invisible and hidden implementation detail to clients.
To clients that use dynamic strings - they just look like bona fide strings (that's because they are bona fide
strings).
Another issue I want to touch on is 'marshalling'. Marshalling in COM means the arrangement and movement of
interface function parameters and return values between processes. There are three types of marshalling; custom
marshalling, standard marshalling, and type library or universal marshalling. This program uses the easiest
which is universal or type library marshalling.
When this program, i.e., CC.Exe, is registered by starting it with the /r command line argument, the COM function
LoadTypeLibEx() is called in ExeRegisterServer(), and that function reads the TypeLib embedded in the Exe and
creates Interface keys for the IX and IY interfaces, and a typelib key under HKEY_CLASSES_ROOT. Specifically, it
creates all of the following keys in the registry under HKEY_CLASSES_ROOT:
1) Creates HKEY_CLASSES_ROOT\TypeLib\{20000000-0000-0000-0000-000000000023}\1.0
2) Creates HKEY_CLASSES_ROOT\TypeLib\{20000000-0000-0000-0000-000000000023}\1.0\0\win32=C:\Code\PwrBasic\PBWin90\CC\CC.exe '<Yours will be different!
3) Creates HKEY_CLASSES_ROOT\TypeLib\{20000000-0000-0000-0000-000000000023}\Flags
4) Creates HKEY_CLASSES_ROOT\TypeLib\{20000000-0000-0000-0000-000000000023}\1.0\HelpDir
5) Creates HKEY_CLASSES_ROOT\Interface\$IID_IX
6) Creates HKEY_CLASSES_ROOT\Interface\{20000000-0000-0000-0000-000000000021}\ProxyStubClsid={00020424-0000-0000-C000-000000000046}
7) Creates HKEY_CLASSES_ROOT\Interface\{20000000-0000-0000-0000-000000000021}\ProxyStubClsid32={00020424-0000-0000-C000-000000000046}
8) Creates HKEY_CLASSES_ROOT\Interface\{20000000-0000-0000-0000-000000000021}\TypeLib={20000000-0000-0000-0000-000000000023}
9) Creates HKEY_CLASSES_ROOT\Interface\$IID_IY
10) Creates HKEY_CLASSES_ROOT\Interface\{20000000-0000-0000-0000-000000000022}\ProxyStubClsid={00020424-0000-0000-C000-000000000046}
11) Creates HKEY_CLASSES_ROOT\Interface\{20000000-0000-0000-0000-000000000022}\ProxyStubClsid32={00020424-0000-0000-C000-000000000046}
12) Creates HKEY_CLASSES_ROOT\Interface\{20000000-0000-0000-0000-000000000022}\TypeLib={20000000-0000-0000-0000-000000000023}
This is a good bit of stuff, to be sure. None of this is necessary with in process dll servers, but due to the needs
of inter-process marshalling, it becomes necessary for out of process servers. These keys will be created if the
oleautomation attribute is attached to the interface definitions in the interface definition file ( CC.idl ). Here is
what the CC.idl file looks like...
//CC.idl
import "oaidl.idl";
[object, uuid(20000000-0000-0000-0000-000000000021), oleautomation, helpstring("The IX Interface Functions")] //IX
interface IX : IUnknown
{
HRESULT SetXInt([in] int iXVal);
HRESULT GetXInt([out, retval] int* pInt);
HRESULT SetXText([in] BSTR strText);
HRESULT GetXText([out, retval] BSTR* strText);
};
[object, uuid(20000000-0000-0000-0000-000000000022), oleautomation, helpstring("The IY Interface Functions")] //IY
interface IY : IUnknown
{
HRESULT SetYInt([in] int iYVal);
HRESULT GetYInt([out, retval] int* pInt);
HRESULT SetYText([in] BSTR strText);
HRESULT GetYText([out, retval] BSTR* strText);
};
[uuid(20000000-0000-0000-0000-000000000023), version(1.0), helpstring("Class CC With TypeLib")] //LibId
library CCLibrary
{
importlib("stdole32.tlb");
[uuid(20000000-0000-0000-0000-000000000020)]
coclass CC
{
[default] interface IX;
interface IY;
};
};
//End CC.idl
Note that due to the oleautomation attribute being attached to the interface definitions, the oleaut32.dll or universal
marshaller will be used to marshall method parameters. If you locate...
HKEY_CLASSES_ROOT\{00020424-0000-0000-C000-000000000046}\InProcServer32
in your registry, you'll find its value set to oleaut32.dll, which is where the universal marshaller is located. In practical
terms to use the universal marshaller or Type Library Marshalling in your out of process servers you need to use only variant
compliant data types. This includes the usual assembledge of various types of integers, floating point numbers, and BSTRs
(dynamic basic strings), so its not to hard to live with.
I'll just say a word about standard marshalling. When you use the Microsoft Interface Definition Language Compiler ( MIDL )
to compile a *.idl file into a Type Library, there are a number of additional *.c and *.h files produced as output besides the
*.tlb file containing the Type Library. Some of those other files can be compiled into proxy and stub code to be packaged with
a project, but how to do that is beyond the scope of what I wanted to cover here. To do all that you would need to run a C/C++
compiler, and produce alternate data in the registry than listed above.
I'll try to include the CC.tlb file created by using the MIDL compiler on the above CC.idl file. That way, if you are
interested in compiling and running this example, but don't want to fool around with getting the MIDL compiler installed on
your system, you'll be able to do so. The MIDL compiler is installed by many Microsoft products, including Visual Studio,
most or all of the Express versions of the same, as well as the Windows SDK. So I'll try to provide the exact steps you need
to take to create an out of process server using low level PowerBASIC code. In the command line examples of mine below the
path to my project is...
C:\Code\PwrBasic\PBWin90\CC
So, yours may be different and just use yours instead of mine when you see see the above string.
First, compile the CC.rc file just below into a CC.pbr file using the PowerBASIC Windows compiler...
//CC.rc
1 typelib CC.TLB
//End CC.rc
Next, compile the CC.bas project in your PowerBASIC Windows compiler which includes the CC.inc, Main.inc, and Registry.inc
files. Note that you need to use Jose's includes! After you compile the CC.bas file you'll end up with CC.exe, and you can
run that if you like and see the functionality of the program through the user interface elements. However, at this point
it is running as a stand alone exe and the COM subsystem of Windows knows nothing about it and won't be able to connect
to it as an out of process server. For Windows to know about it it must be registered, and to register it we need/want
to embed the type library for the COM Class CC in the exe file.
Take the CC.idl file listed above or the one included in the zip file and compile it with MIDL like so...
C:\Code\PwrBasic\PBWin90\CC>midl cc.idl
After successfully compiling that there should be a CC.tlb file in your working directory. Next use the PowerBASIC TypeLib
Embedder program PBTyp.exe to embed the type library in the CC.exe file just produced by PowerBASIC Windows...
C:\Code\PwrBasic\PBCC50\CC>PBTyp CC.Exe CC.rc
Here is the output from that on my machine from the PBTyp.exe program in your PowerBASIC installation...
PowerBASIC PBTYP TypeLib Embedder - Rev 1.0
Copyright (c) 2007 PowerBASIC Inc.
Module: CC
Target: CC.EXE
TypeLib: CC.TLB
Resource: CC.RC
That should be it and you are ready to register everything with Windows! At the command prompt window where you have
the CC.exe file execute this at the command line...
C:\Code\PwrBasic\PBWin90\CC>CC.exe /r
On my XP or Win2000 systems I get output like the following (cleaned up a bit) after that step in an AllocConsole()
window...
Entering WinMain()
lpCmdLine = /r
Entering Initialize()
IClassFactory_Vtbl.QueryInterface = 4219397
IClassFactory_Vtbl.AddRef = 4219677
IClassFactory_Vtbl.Release = 4219816
IClassFactory_Vtbl.CreateInstance = 4219963
IClassFactory_Vtbl.LockServer = 4221600
Varptr(CCClassFactory) = 4257784
Varptr(CCClassFactory.lpVtbl) = 4257784
Varptr(IClassFactory_Vtbl) = 4257788
CCClassFactory.lpVtbl = 4257788
Called CCClassFactory_QueryInterface()
Called CCClassFactory_AddRef()!
Leaving CCClassFactory_QueryInterface()
pClsFac = 4257784
Leaving Initialize()
Entering blnCmdLineProcessing()
Calling ExeRegisterServer()
Entering ExeRegisterServer()
szPath = C:\Code\PwrBasic\PBWin90\CC\CC.EXE
LoadTypeLib() Succeeded!
Entering RegisterServer()
szExeName = C:\Code\PwrBasic\PBWin90\CC\CC.EXE
szClsid = {20000000-0000-0000-0000-000000000020}
szLibid = {20000000-0000-0000-0000-000000000023}
szKey = CLSID\{20000000-0000-0000-0000-000000000020}
Leaving ExeRegisterServer()
ExeRegisterServer() Apparently Succeeded!
Leaving blnCmdLineProcessing()
At this point you'll probably want to examine your registry under HKEY_CLASSES_ROOT in terms of CLSID, Program ID,
Interface, and TypeLib keys to see everything I've been discussing to this point. After this post I'll try to
provide various example clients in C, C++, VB6, VB.NET, and PowerBASIC to exercise the local exe server. Finally,
you may find additional information about this project from when I first developed it several months ago at this
link including Console Compiler versions...
http://www.jose.it-berater.org/smfforum/index.php?topic=3666.0
#endif
'Tested With PowerBASIC Windows Compiler 9.04 And Jose Roca's Includes v116
#Compile Exe "CC.Exe" 'C:\Code\PwrBasic\PBWin90\CC\CC.Exe
#Dim All 'This program requires Jose Roca's includes. Jose's includes must
#Register None 'not be intermixed with the PowerBASIC includes obtained with
#Include "Win32Api.inc" 'purchase of the PowerBASIC compiler and installed in the WinApi
#Include "ObjBase.inc" 'directory under the PowerBASIC installation path. Jose's includes
#Include "OAIdl.inc" 'should be saved to an addition empty directory such as WinApiEx or
#Include "Main.inc" 'something like that. Under the Options menu of PowerBASIC you can
#Include "Registry.inc" 'then Set the Include Path to Jose's Includes.
#Include "CC.inc"
#Resource "CC.pbr"
Function fnWndProc_OnCreate(wea As WndEventArgs) As Long 'This function will execute whether this program is
Local pCreateStruct As CREATESTRUCT Ptr 'started by a user in the manner of a standard exe,
Local lpCmdLine As Asciiz Ptr 'or whether it was started by the COM Service Control
Local hCtl,pUnk As Dword 'Manager (SCM). If this program was started by SCM
Local Vtbl As Dword Ptr 'it won't create any visible window (it will create
Local hr As Long 'a non-visible window though).
Prnt " Entering fnWndProc_OnCreate()", 1 'Here we want to check if we were loaded by COM's
pCreateStruct=wea.lParam 'Service Control Manager (SCM). If we were there
wea.hInst=@pCreateStruct.hInstance 'would be a "/Embedding" or "-Embedding" in the
lpCmdLine=@pCreateStruct.lpCreateParams 'lpCmdLine parameter, i.e., its length wouldn't be
Prnt " lpCmdLine = " & Str$(lpCmdLine), 1 'zero. The logic just left and below checks this
Prnt " @lpCmdLine = " & @lpCmdLine, 1 'and if the length of this string is zero then this
Prnt " Len(@lpCmdLine) = " & Str$(Len(@lpCmdLine)), 1 'program is to run as a stand alone Exe and present
If Len(@lpCmdLine)=0 Then
hr=CCClassFactory_CreateInstance(Varptr(CCClassFactory), pUnk, $IID_IX, Varptr(pIX))
Prnt " pIX = " & Str$(pIX), 1
Prnt " @pIX = " & Str$(@pIX), 1 'a user interface to the user. Therefore it creates
Vtbl=@pIX 'buttons, labels, and text boxes, and executes a
Prnt " Vtbl = " & Str$(Vtbl), 1 'ShowWindow() call at bottom within the enclosing If.
If FAILED(hr) Then 'If the program was started by COM, then no
Function=-1 : Exit Function 'ShowWindow() is executed, but the window is non-
End If 'theless created not visible.
Call Dword @Vtbl[0] Using ptrQueryInterface(pIX, $IID_IY, pIY) To hr
If SUCCEEDED(hr) Then
Prnt " pIX->QueryInterface(pIY) Succeeded!", 1 'All these CreateWindowEx() calls below are important if this
Else 'program was started as a stand alone exe by a client (not by
Prnt " pIX->QueryInterface(pIY) Failed!", 1 'COM's SCM), as they will provide user interface elements
End If 'with which the user can interact on the visible main program
Prnt " pIY = " & Str$(pIY), 1 'window.
Prnt " @pIY = " & Str$(@pIY), 1
hCtl=CreateWindowEx(0,"static","The IX Interface",%WS_CHILD Or %WS_VISIBLE,215,5,120,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Set X Int",%WS_CHILD Or %WS_VISIBLE,10,35,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,35,40,22,Wea.hWnd,%EDIT_SET_X_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Set X Int",%WS_CHILD Or %WS_VISIBLE,160,35,75,22,Wea.hWnd,%BTN_SET_X_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Get X Int",%WS_CHILD Or %WS_VISIBLE,280,35,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,380,35,40,22,Wea.hWnd,%EDIT_GET_X_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Get X Int",%WS_CHILD Or %WS_VISIBLE,440,35,75,22,Wea.hWnd,%BTN_GET_X_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Set X Text",%WS_CHILD Or %WS_VISIBLE,10,75,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,75,320,22,Wea.hWnd,%EDIT_SET_X_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Set X Text",%WS_CHILD Or %WS_VISIBLE,440,75,75,22,Wea.hWnd,%BTN_SET_X_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Get X Text",%WS_CHILD Or %WS_VISIBLE,10,115,110,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,115,320,22,Wea.hWnd,%EDIT_GET_X_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Get X Text",%WS_CHILD Or %WS_VISIBLE,440,115,75,22,Wea.hWnd,%BTN_GET_X_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","The IY Interface",%WS_CHILD Or %WS_VISIBLE,215,170,120,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Set Y Int",%WS_CHILD Or %WS_VISIBLE,10,195,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,195,40,22,Wea.hWnd,%EDIT_SET_Y_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Set Y Int",%WS_CHILD Or %WS_VISIBLE,160,195,75,22,Wea.hWnd,%BTN_SET_Y_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Get Y Int",%WS_CHILD Or %WS_VISIBLE,280,195,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,380,195,40,22,Wea.hWnd,%EDIT_GET_Y_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Get Y Int",%WS_CHILD Or %WS_VISIBLE,440,195,75,22,Wea.hWnd,%BTN_GET_Y_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Set Y Text",%WS_CHILD Or %WS_VISIBLE,10,235,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,235,320,22,Wea.hWnd,%EDIT_SET_Y_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Set Y Text",%WS_CHILD Or %WS_VISIBLE,440,235,75,22,Wea.hWnd,%BTN_SET_Y_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Get Y Text",%WS_CHILD Or %WS_VISIBLE,10,265,110,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,265,320,22,Wea.hWnd,%EDIT_GET_Y_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Get Y Text",%WS_CHILD Or %WS_VISIBLE,440,265,75,22,Wea.hWnd,%BTN_GET_Y_TEXT,Wea.hInst,Byval 0)
Call ShowWindow(Wea.hWnd, %SW_SHOWNORMAL)
End If
Prnt " Leaving fnWndProc_OnCreate()", 1
fnWndProc_OnCreate=0
End Function
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
Local szBuffer As Asciiz*128
Local strBuffer As String
Local Vtbl As Dword Ptr
Local x,y As Long
Vtbl=@pIX
Select Case As Long Lowrd(Wea.wParam)
Case %BTN_SET_X_INT
Call GetWindowText(GetDlgItem(Wea.hWnd,%EDIT_SET_X_INT),szBuffer,16)
x=Val(szBuffer)
Call Dword @Vtbl[3] Using ptrSetInt(pIX,x)
Case %BTN_GET_X_INT
Call Dword @Vtbl[4] Using ptrGetInt(pIX,x)
szBuffer=Str$(x)
Call SetWindowText(GetDlgItem(Wea.hWnd,%EDIT_GET_X_INT),szBuffer)
Case %BTN_SET_X_TEXT
Call GetWindowText(GetDlgItem(Wea.hWnd,%EDIT_SET_X_TEXT),szBuffer,128)
strBuffer=szBuffer
strBuffer=UCode$(strBuffer)
Call Dword @Vtbl[5] Using ptrSetText(pIX, Byval strBuffer)
Case %BTN_GET_X_TEXT
Call Dword @Vtbl[6] Using ptrGetText(pIX, Byref strBuffer)
strBuffer=ACode$(strBuffer)
Call SetWindowText(GetDlgItem(Wea.hWnd,%EDIT_GET_X_TEXT),Byval Strptr(strBuffer))
Case %BTN_SET_Y_INT
Call GetWindowText(GetDlgItem(Wea.hWnd,%EDIT_SET_Y_INT),szBuffer,16)
y=Val(szBuffer)
Call Dword @Vtbl[3] Using ptrSetInt(pIY,y)
Case %BTN_GET_Y_INT
Call Dword @Vtbl[4] Using ptrGetInt(pIY,y)
szBuffer=Str$(y)
Call SetWindowText(GetDlgItem(Wea.hWnd,%EDIT_GET_Y_INT),szBuffer)
Case %BTN_SET_Y_TEXT
Call GetWindowText(GetDlgItem(Wea.hWnd,%EDIT_SET_Y_TEXT),szBuffer,128)
strBuffer=szBuffer
strBuffer=UCode$(strBuffer)
Call Dword @Vtbl[5] Using ptrSetText(pIY, Byval strBuffer)
Case %BTN_GET_Y_TEXT
Call Dword @Vtbl[6] Using ptrGetText(pIY, Byref strBuffer)
strBuffer=ACode$(strBuffer)
Call SetWindowText(GetDlgItem(Wea.hWnd,%EDIT_GET_Y_TEXT),Byval Strptr(strBuffer))
End Select
fnWndProc_OnCommand=0
End Function
Function fnWndProc_OnPaint(Wea As WndEventArgs) As Long
Local ps As PAINTSTRUCT
Local hDC As Dword
hDC=BeginPaint(Wea.hWnd, ps)
MoveToEx(hDC, 20, 155, Byval 0)
LineTo(hDC, 510, 155)
EndPaint(Wea.hWnd, ps)
fnWndProc_OnPaint=0
End Function
Function fnWndProc_OnClose(Wea As WndEventArgs) As Long
Local Vtbl As Dword Ptr
Local hr As Long
'Control flow can reach this procedure in either
Prnt " Entering fnWndProc_OnClose()", 1 'of two ways. If the program is running as a
Call DestroyWindow(Wea.hWnd) 'stand alone executable execution will occur here
Prnt " pIX = " & Str$(pIX), 1 'when the user clicks the 'x' button in the Window's
Prnt " @pIX = " & Str$(@pIY), 1 'title bar. Alternately, if the program was loaded
Vtbl=@pIX 'by COM, when the client releases its interface
Call DWord @VTbl[2] Using ptrRelease(pIX) To hr 'pointers the reference count held in the g_lLocks
Prnt " pIY = " & Str$(pIY), 1 'global will reach zero in UnLock(), and a WM_CLOSE
Prnt " @pIY = " & Str$(@pIY), 1 'message will be sent to this window, as well as a
Vtbl=@pIY 'PostQuitMessage() to terminate the message queene.
Call DWord @VTbl[2] Using ptrRelease(pIY) To hr
Prnt " Leaving fnWndProc_OnClose()", 1
fnWndProc_OnClose=0
End Function
Function fnWndProc(ByVal hWnd As Long,ByVal wMsg As Long,ByVal wParam As Long,ByVal lParam As Long) As Long
Static wea As WndEventArgs
Register iReturn As Long
Register i As Long
For i=0 To 3
If wMsg=MsgHdlr(i).wMessage Then
wea.hWnd=hWnd: wea.wParam=wParam: wea.lParam=lParam
Call Dword MsgHdlr(i).dwFnPtr Using FnPtr(wea) To iReturn
fnWndProc=iReturn
Exit Function
End If
Next i
fnWndProc=DefWindowProc(hWnd,wMsg,wParam,lParam)
End Function
Sub AttachMessageHandlers()
ReDim MsgHdlr(3) As MessageHandler 'Associate Windows Message With Message Handlers
MsgHdlr(0).wMessage=%WM_CREATE : MsgHdlr(0).dwFnPtr=CodePtr(fnWndProc_OnCreate)
MsgHdlr(1).wMessage=%WM_COMMAND : MsgHdlr(1).dwFnPtr=CodePtr(fnWndProc_OnCommand)
MsgHdlr(2).wMessage=%WM_PAINT : MsgHdlr(2).dwFnPtr=CodePtr(fnWndProc_OnPaint)
MsgHdlr(3).wMessage=%WM_CLOSE : MsgHdlr(3).dwFnPtr=CodePtr(fnWndProc_OnClose)
End Sub
Sub Terminate(Byval lpCmdLine As Asciiz Ptr, Byref regID As Dword)
If InStr(@lpCmdLine,"/Embedding") Or InStr(@lpCmdLine,"-Embedding") Then
Call CoRevokeClassObject(regID)
End If
End Sub
Function WinMain(ByVal hInstance As Long, ByVal hPrev As Long, ByVal lpCmdLine As Asciiz Ptr, ByVal iShow As Long) As Long
Local szAppName As Asciiz*8
Local blnFailure As Long
Local wc As WndClassEx
Local regID As Dword
Local Msg As tagMsg
Call AllocConsole() 'Create console for debug output. If this program was started by COM as a result,
Prnt "Entering WinMain()", 1 'for example, of a CoCreateInstance() call or high level call in PowerBASIC such as
Prnt " lpCmdLine = " & @lpCmdLine, 1 'Let pIX = AnyCom "ComObject.CC", then lpCmdLine will point to a string containing
Call Initialize() '-Embedding or /Embedding. In any case, subs Initialize() and AttachEventHandlers()
Call AttachMessageHandlers() 'have to be called. Initialize() creates an IClassFactory1 object which is an imple-
If CmdLineProcessing(hInstance, lpCmdLine, regID, blnFailure) Then
Waitkey() 'mentation of an important COM concept know as a Class Factory. Class Factories are
Function=0 : Exit Function 'something like the 'new' operator in C++ in that they create a specific kind of
End If 'object. See CCClassFactory_CreateInstance() in CC.inc. That is where a CC object
If blnFailure Then 'is created with low level COM code.
MessageBox(%NULL,"CoRegisterClassObject() Failed! This Is Decidedly Bad!","Error Report!",%MB_ICONERROR)
Function=-1 : Exit Function
End If
szAppName="CC.Exe"
wc.cbSize=SizeOf(wc) : wc.style=%CS_HREDRAW Or %CS_VREDRAW
wc.lpfnWndProc=CodePtr(fnWndProc) : wc.cbClsExtra=0
wc.cbWndExtra=0 : wc.hInstance=hInstance
wc.hIcon=LoadIcon(%NULL, ByVal %IDI_APPLICATION) : wc.hCursor=LoadCursor(%NULL, ByVal %IDC_ARROW)
wc.hbrBackground=%COLOR_BTNFACE+1 : wc.lpszMenuName=%NULL
wc.lpszClassName=VarPtr(szAppName)
Call RegisterClassEx(wc)
hMainWnd=CreateWindowEx(0, szAppName, szAppName, %WS_OVERLAPPEDWINDOW, 400, 200, 545, 350, 0, 0, hInstance, ByVal lpCmdLine)
While GetMessage(Msg,%NULL,0,0)
TranslateMessage Msg
DispatchMessage Msg
Wend
Call Terminate(lpCmdLine, regID)
Prnt "Leaving WinMain()", 1
Waitkey()
WinMain=0
End Function
--- End code ---
In the way of providing some miscellaneous details, here are a few quick notes.
You only need to register the program one time with the /r switch at the command line. To unregister the component do a /u.
I've only tested the program on Win2000/XP. I don't have Vista or Win 7 yet. Not sure what would be involved there.
Every time you compile the Exe with the PowerBASIC compiler, you need to run PBTyp on it to embed the Type Library, at least if you've unregistered the program and want to re-register it. I've had a lot of problems with forgetting to do that while debugging/experimenting with the registry code. Finally, I put a message box in it that will likely catch those scenerios. If you don't unregister it, its not necessary to keep embedding the type library, as it is only being accessed in the exe that one time when LoadTypeLibEx() is called.
If when you run the program you get an error from Windows stating that it can't locate a function in a dll, its probably because you are using one of the older versions of Jose's includes (pre 116). There was a capitalization issue with LoadTypeLibEx() that Jose fixed in his latest release. You can either fix the capitalazation in the include and recompile, or use Jose's latest includes.
Also, you might note if you look close at my WM_CREATE handler that if the program is started just as a stand alone exe, that is, not through SCM, I didn't bother going through COM to create an instance of CC for internal use within the program, but I just called CCClassFactory_CreateInstance() directly. After all, why go through COM when the functions/objects you need are right within the same program? However, with only a very minor change to the code (2 lines) we can create the object through COM. Here is an alternate fnWndProc_OnCreate() function showing this where I just called CoCreateInstance() for an IX pointer instead of using my class factory directly...
--- Code: ---Function fnWndProc_OnCreate(wea As WndEventArgs) As Long 'This function will execute whether this program is
Local pCreateStruct As CREATESTRUCT Ptr 'started by a user in the manner of a standard exe,
Local lpCmdLine As Asciiz Ptr 'or whether it was started by the COM Service Control
Local Vtbl As Dword Ptr 'Manager (SCM). If this program was started by SCM
Local pUnk As IUnknown 'it won't create any visible window (it will create
Local hCtl As Dword 'a non-visible window though).
Local hr As Long
Prnt " Entering fnWndProc_OnCreate()", 1 'Here we want to check if we were loaded by COM's
pCreateStruct=wea.lParam 'Service Control Manager (SCM). If we were there
wea.hInst=@pCreateStruct.hInstance 'would be a "/Embedding" or "-Embedding" in the
lpCmdLine=@pCreateStruct.lpCreateParams 'lpCmdLine parameter, i.e., its length wouldn't be
Prnt " lpCmdLine = " & Str$(lpCmdLine), 1 'zero. The logic just left and below checks this
Prnt " @lpCmdLine = " & @lpCmdLine, 1 'and if the length of this string is zero then this
Prnt " Len(@lpCmdLine) = " & Str$(Len(@lpCmdLine)), 1 'program is to run as a stand alone Exe and present
If Len(@lpCmdLine)=0 Then 'a user interface to the user. Therefore it creates
hr=CoCreateInstance($CLSID_CC,pUnk,%CLSCTX_ALL,$IID_IX,pIX) 'buttons, labels, and text boxes, and executes a
If FAILED(hr) Then 'ShowWindow() call at bottom within the enclosing If.
Function=-1 : Exit Function 'If the program was started by COM, then no
End If 'ShowWindow() is executed, but the window is non-
Vtbl=@pIX 'theless created not visible.
Prnt " Vtbl = " & Str$(Vtbl), 1
Prnt " pIX = " & Str$(pIX), 1
Prnt " @pIX = " & Str$(@pIX), 1
Call Dword @Vtbl[0] Using ptrQueryInterface(pIX, $IID_IY, pIY) To hr
If SUCCEEDED(hr) Then
Prnt " pIX->QueryInterface(pIY) Succeeded!", 1 'All these CreateWindowEx() calls below are important if this
Else 'program was started as a stand alone exe by a client (not by
Prnt " pIX->QueryInterface(pIY) Failed!", 1 'COM's SCM), as they will provide user interface elements
End If 'with which the user can interact on the visible main program
Prnt " pIY = " & Str$(pIY), 1 'window.
Prnt " @pIY = " & Str$(@pIY), 1
hCtl=CreateWindowEx(0,"static","The IX Interface",%WS_CHILD Or %WS_VISIBLE,215,5,120,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Set X Int",%WS_CHILD Or %WS_VISIBLE,10,35,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,35,40,22,Wea.hWnd,%EDIT_SET_X_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Set X Int",%WS_CHILD Or %WS_VISIBLE,160,35,75,22,Wea.hWnd,%BTN_SET_X_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Get X Int",%WS_CHILD Or %WS_VISIBLE,280,35,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,380,35,40,22,Wea.hWnd,%EDIT_GET_X_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Get X Int",%WS_CHILD Or %WS_VISIBLE,440,35,75,22,Wea.hWnd,%BTN_GET_X_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Set X Text",%WS_CHILD Or %WS_VISIBLE,10,75,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,75,320,22,Wea.hWnd,%EDIT_SET_X_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Set X Text",%WS_CHILD Or %WS_VISIBLE,440,75,75,22,Wea.hWnd,%BTN_SET_X_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Get X Text",%WS_CHILD Or %WS_VISIBLE,10,115,110,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,115,320,22,Wea.hWnd,%EDIT_GET_X_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Get X Text",%WS_CHILD Or %WS_VISIBLE,440,115,75,22,Wea.hWnd,%BTN_GET_X_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","The IY Interface",%WS_CHILD Or %WS_VISIBLE,215,170,120,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Set Y Int",%WS_CHILD Or %WS_VISIBLE,10,195,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,195,40,22,Wea.hWnd,%EDIT_SET_Y_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Set Y Int",%WS_CHILD Or %WS_VISIBLE,160,195,75,22,Wea.hWnd,%BTN_SET_Y_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Get Y Int",%WS_CHILD Or %WS_VISIBLE,280,195,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,380,195,40,22,Wea.hWnd,%EDIT_GET_Y_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Get Y Int",%WS_CHILD Or %WS_VISIBLE,440,195,75,22,Wea.hWnd,%BTN_GET_Y_INT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Set Y Text",%WS_CHILD Or %WS_VISIBLE,10,235,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,235,320,22,Wea.hWnd,%EDIT_SET_Y_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Set Y Text",%WS_CHILD Or %WS_VISIBLE,440,235,75,22,Wea.hWnd,%BTN_SET_Y_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"static","Get Y Text",%WS_CHILD Or %WS_VISIBLE,10,265,110,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,265,320,22,Wea.hWnd,%EDIT_GET_Y_TEXT,Wea.hInst,Byval 0)
hCtl=CreateWindowEx(0,"button","Get Y Text",%WS_CHILD Or %WS_VISIBLE,440,265,75,22,Wea.hWnd,%BTN_GET_Y_TEXT,Wea.hInst,Byval 0)
Call ShowWindow(Wea.hWnd, %SW_SHOWNORMAL)
End If
Prnt " Leaving fnWndProc_OnCreate()", 1
fnWndProc_OnCreate=0
End Function
--- End code ---
Frederick J. Harris:
Attached is a Visual Basic 6 project that provides a visual interface to the functionality of CC.exe and connects to it. It creates a form very similiar to the one the CC.exe program creates when executed without any command line parameters. It may not work on your system without some tweaking because the project will contain paths to the CC.exe file that won't likely be valid on your system, so the references will have to be changed. Here is another way you could create the project if you are having difficulties. You could just overwrite the frmCC.frm file with the one in my attachment after you have created the VB project prjCC, and that way you wouldn't have to spend an hour and a half creating buttons, textboxes, etc., to work with the object. If you want to try that, follow these steps...
1) Start Visual Basic 6;
2) Choose 'New Standard Exe Project';
3) From the main menu go to...
Project >> References...
...and locate 'Class CC With TypeLib'
in the References dialog box. Check the check box that you want to
include this reference in the project;
4) Name the form that Visual Basic included in the project as frmCC and
name the project prjCC;
5) Close the project and close Visual Basic 6;
6) Overwrite frmCC.frm created and named above with the attached (in zip)
frmCC.frm file. It has buttons, labels, and text boxes already set up
for you on the form.
7) Re-open Visual Basic 6 and the project and you should be able to fill
in text boxes, click buttons, etc, and use the functionality of the
PowerBASIC created local server. When the VB project runs the PowerBASIC
created AllocConsole() window from the server should open up and give you
debug output from calls being made by VB into the CC.exe server.
Frederick J. Harris:
Here is a PowerBASIC Console Compiler 5.04 Program that connects to CC.exe...
--- Code: ---#Compile Exe
#Dim All
$CLSID_CC = GUID$("{20000000-0000-0000-0000-000000000020}")
$IID_IX = GUID$("{20000000-0000-0000-0000-000000000021}")
$IID_IY = GUID$("{20000000-0000-0000-0000-000000000022}")
Interface IX $IID_IX : Inherit IAutomation
Method SetXInt(Byval iXVal As Long)
Method GetXInt() As Long
Method SetXText(Byval strText As String)
Method GetXText() As String
End Interface
Interface IY $IID_IY : Inherit IAutomation
Method SetYInt(Byval iYVal As Long)
Method GetYInt() As Long
Method SetYText(Byval strText As String)
Method GetYText() As String
End Interface
Function PBMain() As Long
Local strXText, strYText As String
Local hr,iXInt,iYInt As Long
Local pIX As IX
Local pIY As IY
pIX=AnyCom("ComObject.CC")
pIX.SetXInt(5)
pIX.SetXText("Here Is A New IX Interface BSTR!")
iXInt=pIX.GetXInt()
strXText=pIX.GetXText()
Print "iXInt = " iXInt
Print "strXText = " strXText
pIY=pIX
Set pIX = Nothing
pIY.SetYInt(10)
pIY.SetYText("Here Is A New IY Interface BSTR!")
iYInt=pIY.GetYInt()
strYText=pIY.GetYText()
Print "iYInt = " iYInt
Print "strYText = " strYText
Set pIY = Nothing
Waitkey$
PBMain=0
End Function
--- End code ---
Frederick J. Harris:
Oh! I forgot to post the other parts to the CC.exe program - includes and such! They are in the zip, but for lurkers, here they are...
--- Code: ---'CC.inc - Contains Class CC
Declare Function CoRegisterClassObjectPtr Lib "OLE32.DLL" Alias "CoRegisterClassObject" _
( _
Byref rclsid As Guid, _ 'This is an alternate form of CoRegisterClassObject()
Byval pUnknown As Dword, _ 'as the one in Jose's includes doesn't seem to work
Byval dwClsContext As Dword, _ 'with low level do it yourself COM code such as this
Byval flags As Dword, _ '(at least not with mine!).
ByRef lpdwRegister As Dword _
) As Long
'IClassFactory1 Interface Function Pointers
Declare Function ptrCreateInstance (Byval this As Dword, Byval pUnk As Dword, Byref iid As Guid, Byref ppv As Dword) As Long
Declare Function ptrLockServer (Byval this As Dword, Byval blnLock As Long ) As Long
'IX, IY Interface Function Pointer Prototypes
Declare Function ptrQueryInterface (Byval this As Dword, Byref iid As Guid, Byref pUnknown As Dword ) As Long
Declare Function ptrAddRef (Byval this As Dword ) As Dword
Declare Function ptrRelease (Byval this As Dword ) As Dword
Declare Function ptrSetInt (Byval this As Dword, Byval iVal As Long ) As Long
Declare Function ptrGetInt (Byval this As Dword, Byref pVal As Long ) As Long
Declare Function ptrSetText (Byval this As Dword, Byval strText As String ) As Long
Declare Function ptrGetText (Byval this As Dword, Byref ptrText As String ) As Long
$IID_IClassFactory = Guid$("{00000001-0000-0000-C000-000000000046}")
$IID_IUnknown = Guid$("{00000000-0000-0000-C000-000000000046}")
$CLSID_CC = Guid$("{20000000-0000-0000-0000-000000000020}")
$IID_IX = Guid$("{20000000-0000-0000-0000-000000000021}")
$IID_IY = Guid$("{20000000-0000-0000-0000-000000000022}")
$LIBID_CCLibrary = Guid$("{20000000-0000-0000-0000-000000000023}")
Type IXVtbl 'I've covered the creation of COM objects in my first two tutorials in some detail, so I'll
QueryInterface As Dword Ptr 'just give a quick review here. A COM class contains state data, i.e., instance variables,
AddRef As Dword Ptr 'and VTable pointers, i.e., pointers to interfaces. If you look at Type CC below, that is
Release As Dword Ptr 'a COM class, and it contains two VTable (interface) pointers, and five member variables. Its
SetXInt As Dword Ptr 'size is therefore 28 bytes. The 1st two members are, respectively, pointers to the IX and
GetXInt As Dword Ptr 'IY interfaces, which are contiguous blocks of memory containing pointers to the interface
SetXText As Dword Ptr 'functions. Bytes 8 through 24 in Type CC are the four instance variables on which the IX
GetXText As Dword Ptr 'and IY interface functions work. They simply Get/Set these variables. The last four bytes
End Type 'of CC are a reference counting variable that keeps track of how many outstanding references
Type I_X 'there are on Class CC and its interfaces. Type IXVtbl and Type IYVtbl are UDTs which upon
lpIX As IXVtbl Ptr 'creation provide memory space where pointers to the interface functions will be stored. For
End Type 'example, if you look down in this code file around line 180 you'll see the function SetXInt().
Type IYVtbl 'The address of this function retrieved at runtime by the PowerBASIC CodePtr() function will
QueryInterface As Dword Ptr 'be stored in the SetXInt member of IXVtbl. Likewise for the other IXVtbl functions. Note
AddRef As Dword Ptr 'that every interface has QueryInterface, AddRef, and Release pointers stored as the 1st three
Release As Dword Ptr 'function pointers of the interface. This adds reference counting and interface navigation
SetYInt As Dword Ptr 'functionality to the interfaces. These three members are a part of something termed
GetYInt As Dword Ptr 'IUnknown, and if we were using C++ terminology one would say all COM interfaces inherit from
SetYText As Dword Ptr 'IUnknown, which is just another way of aying that every interface has QueryInterface, AddRef,
GetYText As Dword Ptr 'and Release as its 1st three members.
End Type
Type I_Y
lpIY As IYVtbl Ptr 'For this program to be started by COM it has to be registered 1st. You don't use RegSvr32
End Type 'for that. You must open a command prompt window to whatever directory CC.exe is in. Then
Type CC 'you must execute the program with a /r command line parameter...
lpIX As IXVtbl Ptr
lpIY As IYVtbl Ptr ' C:\Code\PwrBasic\PBWin90\CC>CC.exe /r
m_iXInt As Long '
m_iYInt As Long 'Having done that if the registration was successful you should be able to use the program
m_XText As Dword Ptr 'like any other local exe server from C/C++, vb.net, PowerBASIC, etc.
m_YText As Dword Ptr
m_cRef As Long
End Type
Type IClassFactoryVtbl 'When this program starts up in WinMain(), irregardless of whether it was started with
QueryInterface As Dword Ptr 'a command line argument by COM, a Class Factory will be created in Initialize(). If
AddRef As Dword Ptr '/r or /u was passed in for registration/unregistration, the program will simply perform
Release As Dword Ptr 'an early exit from WinMain() and terminate. If however, a /Embedding or -Embedding
CreateInstance As Dword Ptr 'String was passed in to WinMain(), then the program was started by COM's Service Control
LockServer As Dword Ptr 'Manager, and CoRegisterClassObject() needs to be called to register the Class Factory with
End Type 'COM so that it can create an instance of CC for a client. The critical variable passed...
Type IClassFactory1
lpVtbl As IClassFactoryVtbl Ptr
End Type
Global g_szFriendlyName As Asciiz*64 '...into CoRegisterClassObject() is the address of the CCClassFactory variable of type
Global g_szVerIndProgID As Asciiz*64 'IClassFactory1 just defined above. Note in this app CCClassFactory is just a global
Global g_szProgID As Asciiz*64 'variable.
Global CCClassFactory As IClassFactory1 'sizeof() = 4
Global IClassFactory_Vtbl As IClassFactoryVtbl 'sizeof() = 20
Global IX_Vtbl As IXVtbl 'sizeof() = 28
Global IY_Vtbl As IYVtbl 'sizeof() = 28
Global g_hModule As Dword
Global g_lLocks As Long
Global pIX As Dword Ptr 'When COM gets the address of the class factory object, it can then call the all important
Global pIY As Dword Ptr 'CCClassFactory_CreateInstance() function which will create a CC object, that is, a COM object
Global hMainWnd As Dword 'of class ComObject.CC. Note that the above function allocates memory for a CC object with...
Sub CCLock() '...CoTaskMemAlloc(), attaches the VTbl pointers to the object, and
Prnt " Entering CCLock()", 1 'initializes the state (instance) variables of the object to default values.
Prnt " g_lLocks = " & Str$(g_lLocks), 1
Call InterlockedIncrement(g_lLocks)
Prnt " g_lLocks = " & Str$(g_lLocks), 1
Prnt " Leaving CCLock()", 1
End Sub
Sub CCUnLock() 'Its important to realize what keeps this program running if an early exit
If g_lLocks > 0 Then 'doesn't occur due to the registration/unregistration scenerio. If execution
Prnt "Entering CCUnLock()", 1 'reaches the CreateWindow() call in WinMain(), a main program window will be
Prnt " g_lLocks = " & Str$(g_lLocks), 1 'created and the program will enter a message retrieval loop. If the main
Call InterlockedDecrement(g_lLocks) 'program window receives a click on the [x] to terminate it, Release() calls
Prnt " g_lLocks = " & Str$(g_lLocks), 1 'will be made on the globally allocated IX and IY interface variables, and
If g_lLocks=0 Then 'a DestroyWindow() call and PostQuitMessage() call made on the main window
If hMainWnd Then 'and WinMain()'s message pump. If the program was started by COM and the
Call PostQuitMessage(0) 'main window is invisible, a WM_CLOSE message and PostQuitMessage() will be
Call SendMessage(hMainWnd, %WM_CLOSE, 0, 0) 'SendMessag()'ed from CCUnlock() when g_lLocks reaches 0.
End If
End If
Prnt "Leaving CCUnLock()", 1
End If
End Sub
Function IX_QueryInterface(ByVal this As I_X Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Prnt " Called IX_QueryInterface() For IID_IUnknown And this=" & Str$(this), 1
@ppv=this
Call IX_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IX
Prnt " Called IX_QueryInterface() For IID_IX And this=" & Str$(this), 1
@ppv=this
Call IX_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IY
Prnt " Called IX_QueryInterface() For IID_IY And this=" & Str$(this), 1
Incr this
@ppv=this
Call IY_AddRef(this)
Function=%S_OK
Exit Function
Case Else
Prnt "Called IX_QueryInterface()", 1
End Select
Function=%E_NoInterface
End Function
Function IX_AddRef(ByVal this As I_X Ptr) As Long
Local pCC As CC Ptr
Prnt "Called IX_AddRef()", 1
pCC=this
Incr @pCC.m_cRef
IX_AddRef=@pCC.m_cRef
End Function
Function IX_Release(ByVal this As I_X Ptr) As Long
Local pCC As CC Ptr
pCC=this
Decr @pCC.m_cRef
If @pCC.m_cRef=0 Then
Call CoTaskMemFree(this)
Prnt "Called IX_Release() And CC Was Deleted!", 1
Call CCUnLock()
Else
Prnt "Called IX_Release()", 1
End If
Function=@pCC.m_cRef
End Function
Function SetXInt(ByVal this As I_X Ptr, Byval iXVal As Long) As Long
Local pCC As CC Ptr
Prnt "Called SetXInt(" & Trim$(Str$(iXVal)) & ")", 1
pCC=this
@pCC.m_iXInt=iXVal
Function=%S_OK
End Function
Function GetXInt(ByVal this As I_X Ptr, Byref pXVal As Long) As Long
Local pCC As CC Ptr
pCC=this
pXVal=@pCC.m_iXInt
Prnt "Called GetXInt(" & Trim$(Str$(pXVal)) & ")", 1
Function=%S_OK
End Function
Function SetXText(ByVal this As I_X Ptr, Byval strXText As String) As Long
Local pCC As CC Ptr
Prnt "Setting IXText To " & strXText, 1
pCC=this
If SysReAllocString(@pCC.m_XText, Byval Strptr(strXText)) Then
Function=%S_OK
Else
Function=%S_FALSE
End If
End Function
Function GetXText(ByVal this As I_X Ptr, Byref strXText As String) As Long
Local pCC As CC Ptr
pCC=this
If SysReAllocString(strXText, Byval @pCC.m_XText) Then
Function=%S_OK
Else
Function=%S_FALSE
End If
Prnt "IX Text: " & strXText, 1
End Function
Function IY_QueryInterface(ByVal this As I_Y Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Prnt "Called IY_QueryInterface() For IID_IUnknown", 1
Decr this
@ppv=this
Call IX_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IX
Prnt "Called IY_QueryInterface() For IID_IX", 1
Decr this
@ppv=this
Call IX_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IY
Prnt "Called IY_QueryInterface() For IID_IY", 1
@ppv=this
Call IY_AddRef(this)
Function=%S_OK
Exit Function
Case Else
Prnt "Called IY_QueryInterface()", 1
End Select
Function=%E_NoInterface
End Function
Function IY_AddRef(ByVal this As I_Y Ptr) As Long
Local pCC As CC Ptr
Prnt "Called IY_AddRef() - this = " & Str$(this), 1
Decr this
pCC=this
Incr @pCC.m_cRef
IY_AddRef=@pCC.m_cRef
End Function
Function IY_Release(ByVal this As I_Y Ptr) As Long
Local pCC As CC Ptr
Decr this
pCC=this
Decr @pCC.m_cRef
If @pCC.m_cRef=0 Then
Call CoTaskMemFree(this)
Prnt "Called IY_Release() And CC Was Deleted!", 1
Call CCUnLock()
Else
Prnt "Called IY_Release()", 1
End If
Function=@pCC.m_cRef
End Function
Function SetYInt(ByVal this As I_Y Ptr, Byval iYVal As Long) As Long
Local pCC As CC Ptr
Prnt "Called SetYInt(" & Trim$(Str$(iYVal)) & ")", 1
Decr this
pCC=this
@pCC.m_iYInt=iYVal
Function=%S_OK
End Function
Function GetYInt(ByVal this As I_Y Ptr, Byref pYVal As Long) As Long
Local pCC As CC Ptr
Decr this
pCC=this
pYVal=@pCC.m_iYInt
Prnt "Called GetXInt(" & Trim$(Str$(pYVal)) & ")", 1
Function=%S_OK
End Function
Function SetYText(ByVal this As I_Y Ptr, Byval strYText As String) Export As Long
Local pCC As CC Ptr
Prnt "Setting IYText To " & strYText, 1
Decr this
pCC=this
If SysReAllocString(@pCC.m_YText, Byval Strptr(strYText)) Then
Function=%S_OK
Else
Function=%S_FALSE
End If
End Function
Function GetYText(ByVal this As I_Y Ptr, Byref strYText As String) Export As Long
Local pCC As CC Ptr
Decr this
pCC=this
If SysReAllocString(strYText, Byval @pCC.m_YText) Then
Function=%S_OK
Else
Function=%S_FALSE
End If
Prnt "IY Text: " & strYText, 1
End Function
Function CCClassFactory_QueryInterface(ByVal this As IClassFactory1 Ptr, ByRef RefIID As Guid, ByVal pCF As Dword Ptr) As Long
Prnt "Called CCClassFactory_QueryInterface()", 1
If RefIID=$IID_IUnknown Or RefIID=$IID_IClassFactory Then
Call CCClassFactory_AddRef(this)
@pCF=this
Prnt " Leaving CCClassFactory_QueryInterface()", 1
Function=%NOERROR
Exit Function
End If
Function=%E_NoInterface
End Function
Function CCClassFactory_AddRef(ByVal this As IClassFactory1 Ptr) As Long
Prnt "Called CCClassFactory_AddRef()!", 1
'Print " Leaving CCClassFactory_AddRef()!"
CCClassFactory_AddRef=10
End Function
Function CCClassFactory_Release(ByVal this As IClassFactory1 Ptr) As Long
Prnt "Called CCClassFactory_Release()!", 1
'Print " this=" this
'Print " Leaving CCClassFactory_Release()!"
CCClassFactory_Release=20
End Function
Function CCClassFactory_CreateInstance(ByVal this As IClassFactory1 Ptr, ByVal pUnknown As Dword, ByRef RefIID As Guid, ByVal ppv As Dword Ptr) As Long
Local strIXStr, strIYStr As String
Local pIX As I_X Ptr
Local pCC As CC Ptr
Local hr As Long
Prnt "Called CCClassFactory_CreateInstance()", 1
@ppv=%NULL
If pUnknown Then
hr=%CLASS_E_NOAGGREGATION
Exit Function
Else
If RefIID=$IID_IUnknown Or RefIID=$IID_IX Or RefIID=$IID_IY Then
pCC=CoTaskMemAlloc(SizeOf(CC))
If pCC Then
Prnt " pCC =" & Str$(pCC), 1
@pCC.lpIX=VarPtr(IX_Vtbl)
@pCC.lpIY=VarPtr(IY_Vtbl)
Prnt " @pCC.lpIX=" & Str$(@pCC.lpIX), 1
Prnt " @pCC.lpIY=" & Str$(@pCC.lpIY), 1
Prnt "", 1
Prnt " " & Str$(Varptr(@pCC.lpIX)) & " ", 0 : Prnt Str$(@pCC.lpIX), 1
Prnt " " & Str$(Varptr(@pCC.lpIY)) & " ", 0 : Prnt Str$(@pCC.lpIY), 1
Prnt "",1
strIXStr="Default IX Interface String"
strIYStr="Default IY Interface String"
strIXStr=UCode$(strIXStr)
strIYStr=UCode$(strIYStr)
@pCC.m_XText=SysAllocStringLen(Byval Strptr(strIXStr),Len(strIXStr)+1)
@pCC.m_YText=SysAllocStringLen(Byval Strptr(strIYStr),Len(strIYStr)+1)
@pCC.m_iXInt=0 : @pCC.m_iYInt=0 : @pCC.m_cRef=0
pIX=pCC
hr= IX_QueryInterface(pIX,RefIID,ppv)
Prnt " pCC = " & Str$(pCC), 1
Prnt " pIX = " & Str$(pIX), 1
Prnt " @ppv = " & Str$(@ppv), 1
If SUCCEEDED(hr) Then
Call CCClassFactory_AddRef(this)
Call CCLock()
Else
Call CoTaskMemFree(pCC)
CCClassFactory_CreateInstance=%E_FAIL
Prnt "", 1 : Prnt "CreateInstance Failed!", 1
Exit Function
End If
Else
hr=%E_OutOfMemory
Exit Function
End If
Else
hr=%E_FAIL
Exit Function
End If
End If
Prnt "Leaving CBClassFactory_CreateInstance()", 1
CCClassFactory_CreateInstance=%S_Ok
End Function
Function CCClassFactory_LockServer(ByVal this As IClassFactory1 Ptr, Byval flock As Long) As Long
Prnt "Called CCClassFactory_LockServer()", 1
If flock Then
Call CCLock()
Else
Call CCUnLock()
End If
CCClassFactory_LockServer=%NOERROR
End Function
Function ExeRegisterServer(hInstance As Long) As Long
Local strAsciPath,strWideCharPath As String
Local hr,iBytesReturned As Long
Local szPath As Asciiz*256
Local pTypeLib As ITypeLib
Local strPath As String
Prnt " Entering ExeRegisterServer()", 1
If GetModuleFileName(hInstance, szPath, 256) Then
strPath=szPath
Prnt " szPath = " & strPath, 1
strAsciPath=szPath
strWideCharPath=UCode$(strAsciPath & $Nul)
hr=LoadTypeLibEx(Strptr(strWideCharPath), %REGKIND_REGISTER, pTypeLib)
If SUCCEEDED(hr) Then
Prnt " LoadTypeLib() Succeeded!", 1
Set pTypeLib = Nothing
hr=RegisterServer(szPath, $CLSID_CC, $LIBID_CCLibrary, g_szFriendlyName, g_szVerIndProgID, g_szProgID)
Else
Local dwFlags As Dword
Local szError As Asciiz*256
Local strError As String
Prnt " LoadTypeLib() Failed!", 1
iBytesReturned= _
FormatMessage _
( _
dwFlags, _
Byval 0, _
hr, _
MAKELANGID(%LANG_NEUTRAL, %SUBLANG_DEFAULT), _
Byval Varptr(szError), _
256, _
Byval %NULL _
)
If iBytesReturned=0 Then
iBytesReturned=MsgBox("...And That Is To Use PBTyp.exe To Embed The Type Library In The Exe!", %MB_ICONWARNING, "I Know What You Forgot...")
End If
strError=szError
Prnt " iBytesReturned = " & Str$(iBytesReturned), 1
Prnt "szBuffer = " & strError, 1
End If
End If
Prnt " Leaving ExeRegisterServer()", 1
Function=hr
End Function
Function ExeUnRegisterServer(hInstance As Long) As Long
Local hr As Long
Prnt " Entering ExeUnregisterServer()", 1
hr=UnRegisterTypeLib($LIBID_CCLibrary, 1, 0, %LANG_NEUTRAL, %SYS_WIN32)
If SUCCEEDED(hr) Then
Prnt " UnRegisterTypeLib() Succeeded!", 1
hr=UnregisterServer($CLSID_CC, g_szVerIndProgID, g_szProgID)
Else
Prnt " UnRegisterTypeLib() Failed!", 1
End If
Prnt " Leaving ExeUnregisterServer()", 1
Function=hr
End Function
Function CmdLineProcessing _
( _
Byval hInstance As Long, _
Byval lpCmdLine As Asciiz Ptr, _
Byref regID As Dword, _
Byref blnFailure As Long _
) As Long
Local hr As Long
Prnt "Entering blnCmdLineProcessing()", 1
If InStr(@lpCmdLine,"/r") Then
Prnt " Calling ExeRegisterServer()", 1
hr=ExeRegisterServer(hInstance)
If SUCCEEDED(hr) Then
Prnt " ExeRegisterServer() Apparently Succeeded!", 1
Else
Prnt " ExeRegisterServer() Apparently Failed!", 1
End If
Prnt "Leaving blnCmdLineProcessing()", 1
Prnt "", 1
Function=%TRUE
Exit Function
End If
If InStr(@lpCmdLine,"/u") Then
Prnt " Calling ExeUnregisterServer()", 1
hr=ExeUnregisterServer(hInstance)
If SUCCEEDED(hr) Then
Prnt " ExeUnregisterServer Apparently Succeeded!", 1
Else
Prnt " ExeUnregisterServer Apparently Failed!", 1
End If
Prnt "Leaving blnCmdLineProcessing()", 1
Prnt "", 1
Function=%TRUE
Exit Function
End If
If InStr(@lpCmdLine,"/Embedding") Or InStr(@lpCmdLine,"-Embedding") Then
Prnt " Was Loaded By COM!", 1
hr=CoRegisterClassObjectPtr($CLSID_CC, Varptr(CCClassFactory), %CLSCTX_LOCAL_SERVER, %REGCLS_MULTIPLEUSE, regID)
If SUCCEEDED(hr) Then
Prnt " CoRegisterClassObject() Succeeded!", 1
Else
Prnt "CoRegisterClassObject() Failed!", 1
blnFailure=%TRUE
Local dwFlags As Dword
Local szError As Asciiz*256
Local strError As String
dwFlags=%FORMAT_MESSAGE_FROM_SYSTEM
FormatMessage(dwFlags, Byval 0, hr, MAKELANGID(%LANG_NEUTRAL, %SUBLANG_DEFAULT), Byval Varptr(szError), 256, Byval %NULL)
strError=szError
Prnt "strBuffer = " & strError, 1
End If
End If
Prnt "Leaving blnCmdLineProcessing()", 1
Prnt "", 1
Function=%FALSE
End Function
Function Initialize() As Long
Local pClsFac As Dword Ptr
Local hr As Long
Prnt "Entering Initialize()", 1
g_szFriendlyName = "Com Object CC"
g_szProgID = "ComObject.CC.1"
g_szVerIndProgID = "ComObject.CC"
IClassFactory_Vtbl.QueryInterface = CodePtr(CCClassFactory_QueryInterface)
IClassFactory_Vtbl.AddRef = CodePtr(CCClassFactory_AddRef)
IClassFactory_Vtbl.Release = CodePtr(CCClassFactory_Release)
IClassFactory_Vtbl.CreateInstance = CodePtr(CCClassFactory_CreateInstance)
IClassFactory_Vtbl.LockServer = CodePtr(CCClassFactory_LockServer)
CCClassFactory.lpVtbl = VarPtr(IClassFactory_Vtbl)
Prnt " IClassFactory_Vtbl.QueryInterface = " & Str$(IClassFactory_Vtbl.QueryInterface), 1
Prnt " IClassFactory_Vtbl.AddRef = " & Str$(IClassFactory_Vtbl.AddRef), 1
Prnt " IClassFactory_Vtbl.Release = " & Str$(IClassFactory_Vtbl.Release), 1
Prnt " IClassFactory_Vtbl.CreateInstance = " & Str$(IClassFactory_Vtbl.CreateInstance), 1
Prnt " IClassFactory_Vtbl.LockServer = " & Str$(IClassFactory_Vtbl.LockServer), 1
Prnt "", 1
Prnt " Varptr(CCClassFactory) = " & Str$(Varptr(CCClassFactory)), 1
Prnt " Varptr(CCClassFactory.lpVtbl) = " & Str$(Varptr(CCClassFactory.lpVtbl)), 1
Prnt " Varptr(IClassFactory_Vtbl) = " & Str$(Varptr(IClassFactory_Vtbl)), 1
Prnt " CCClassFactory.lpVtbl = " & Str$(CCClassFactory.lpVtbl), 1
IX_Vtbl.QueryInterface = CodePtr(IX_QueryInterface)
IX_Vtbl.AddRef = CodePtr(IX_AddRef)
IX_Vtbl.Release = CodePtr(IX_Release)
IX_Vtbl.SetXInt = CodePtr(SetXInt)
IX_Vtbl.GetXInt = CodePtr(GetXInt)
IX_Vtbl.SetXText = CodePtr(SetXText)
IX_Vtbl.GetXText = CodePtr(GetXText)
IY_Vtbl.QueryInterface = CodePtr(IY_QueryInterface)
IY_Vtbl.AddRef = CodePtr(IY_AddRef)
IY_Vtbl.Release = CodePtr(IY_Release)
IY_Vtbl.SetYInt = CodePtr(SetYInt)
IY_Vtbl.GetYInt = CodePtr(GetYInt)
IY_Vtbl.SetYText = CodePtr(SetYText)
IY_Vtbl.GetYText = CodePtr(GetYText)
hr=CCClassFactory_QueryInterface(VarPtr(CCClassFactory), $IID_IClassFactory, Varptr(pClsFac))
If FAILED(hr) Then
CCClassFactory.lpVTbl=0
hr=%CLASS_E_CLASSNOTAVAILABLE
Exit Function
Else
Prnt " pClsFac = " & Str$(pClsFac), 1
End If
Prnt "Leaving Initialize()", 1 : Prnt "", 1
Function=hr
End Function
--- End code ---
Frederick J. Harris:
Here are Main.inc, Registry.inc, CC.idl, and CC.rc
--- Code: ---'Main.inc
%EDIT_SET_X_INT = 1500
%BTN_SET_X_INT = 1505
%EDIT_GET_X_INT = 1510
%BTN_GET_X_INT = 1515
%EDIT_SET_X_TEXT = 1520
%BTN_SET_X_TEXT = 1525
%EDIT_GET_X_TEXT = 1530
%BTN_GET_X_TEXT = 1535
%EDIT_SET_Y_INT = 1540
%BTN_SET_Y_INT = 1545
%EDIT_GET_Y_INT = 1550
%BTN_GET_Y_INT = 1555
%EDIT_SET_Y_TEXT = 1560
%BTN_SET_Y_TEXT = 1565
%EDIT_GET_Y_TEXT = 1570
%BTN_GET_Y_TEXT = 1575
Type WndEventArgs
wParam As Long
lParam As Long
hWnd As Dword
hInst As Dword
End Type
Type MessageHandler
wMessage As Long
dwFnPtr As Dword
End Type
Declare Function FnPtr(wea As WndEventArgs) As Long
Global MsgHdlr() As MessageHandler
Sub Cls(hStdOut As Dword)
Local csbi As CONSOLE_SCREEN_BUFFER_INFO
Local dwConsoleSize As Dword
Local dwWritten As Dword
Local cdXY As COORD
Call GetConsoleScreenBufferInfo(hStdOut,csbi)
dwConsoleSize=csbi.dwSize.X * csbi.dwSize.Y
Call FillConsoleOutputCharacter(hStdOut,32,dwConsoleSize,cdXY,dwWritten)
Call GetConsoleScreenBufferInfo(hStdOut,csbi)
Call FillConsoleOutputAttribute(hStdOut,csbi.wAttributes,dwConsoleSize,cdXY,dwWritten)
Call SetConsoleCursorPosition(hStdOut,cdXY)
End Sub
Sub Locate(hStdOutput As Dword, x As Integer, y As Integer)
Local cdXY As COORD
cdXY.x=x : cdXY.y=y
Call SetConsoleCursorPosition(hStdOutput,cdXY)
End Sub
Sub Waitkey()
Local dwInputEvents As Dword
Local blnContinue As Long
Local hStdInput As Dword
Local ir As INPUT_RECORD
hStdInput=GetStdHandle(%STD_INPUT_HANDLE)
FlushConsoleInputBuffer(hStdInput)
blnContinue=%TRUE
Do While blnContinue=%TRUE
Call ReadConsoleInput(hStdInput,ir,1,dwInputEvents)
If ir.EventType=%KEY_EVENT Then
blnContinue=%FALSE
End If
Loop
End Sub
Sub Prnt(strLn As String, blnCrLf As Long)
Local iLen, iWritten As Long
Local hStdOutput As Dword
Local strNew As String
hStdOutput=GetStdHandle(%STD_OUTPUT_HANDLE)
If blnCrLf Then
strNew=strLn + $CrLf
End If
iLen = Len(strNew)
WriteConsole(hStdOutput, Byval Strptr(strNew), iLen, iWritten, Byval 0)
End Sub
--- End code ---
--- Code: ---'Registry.inc
Function SetKeyAndValue(Byref szKey As Asciiz, Byref szSubKey As Asciiz, Byref szValue As Asciiz) As Long
Local szKeyBuf As Asciiz*1024
Local lResult As Long
Local hKey As Dword
If szKey<>"" Then
szKeyBuf=szKey
If szSubKey<>"" Then
szKeyBuf=szKeyBuf+"\"+szSubKey
End If
lResult=RegCreateKeyEx(%HKEY_CLASSES_ROOT,szKeyBuf,0,Byval %NULL,%REG_OPTION_NON_VOLATILE,%KEY_ALL_ACCESS,Byval %NULL,hKey,%NULL)
If lResult<>%ERROR_SUCCESS Then
Function=%FALSE
Exit Function
End If
If szValue<>"" Then
Call RegSetValueEx(hKey,Byval %NULL, Byval 0, %REG_SZ, szValue, Len(szValue)+1)
End If
Call RegCloseKey(hKey)
Else
Function=%FALSE
Exit Function
End If
Function=%TRUE
End Function
Function RecursiveDeleteKey(Byval hKeyParent As Dword, Byref lpszKeyChild As Asciiz) As Long
Local dwSize,hKeyChild As Dword
Local szBuffer As Asciiz*256
Local time As FILETIME
Local lRes As Long
dwSize=256
lRes=RegOpenKeyEx(hKeyParent,lpszKeyChild,0,%KEY_ALL_ACCESS,hKeyChild)
If lRes<>%ERROR_SUCCESS Then
Function=lRes
Exit Function
End If
While(RegEnumKeyEx(hKeyChild,0,szBuffer,dwSize,0,Byval 0,Byval 0,time)=%S_OK)
lRes=RecursiveDeleteKey(hKeyChild,szBuffer) 'Delete the decendents of this child.
If lRes<>%ERROR_SUCCESS Then
Call RegCloseKey(hKeyChild)
Function=lRes
Exit Function
End If
dwSize=256
Loop
Call RegCloseKey(hKeyChild)
Function=RegDeleteKey(hKeyParent,lpszKeyChild) 'Delete this child.
End Function
Function RegisterServer(Byref szExeName As Asciiz, Byref ClassId As Guid, Byref LibId As Guid, Byref szFriendlyName As Asciiz, Byref szVerIndProgID As Asciiz, Byref szProgID As Asciiz) As Long
Local szClsid As Asciiz*48, szLibid As Asciiz*48, szKey As Asciiz*64
Local hStdOut As Dword
Local iReturn As Long
hStdOut=GetStdHandle(%STD_OUTPUT_HANDLE)
Prnt " Entering RegisterServer()", 1
Prnt " szExeName = " & szExeName, 1
szClsid=GuidTxt$(ClassId)
szLibid=GuidTxt$(LibId)
If szClsid <> "" And szLibid <> "" Then
Prnt " szClsid = " & szClsid, 1
Prnt " szLibid = " & szLibid, 1
szKey="CLSID\" & szClsid
Prnt " szKey = " & szKey, 1
If IsFalse(SetKeyAndValue(szKey, Byval %NULL, szFriendlyName)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szKey, "LocalServer32", szExeName)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szKey, "ProgID", szProgID)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szKey, "VersionIndependentProgID", szVerIndProgID)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szKey, "TypeLib", szLibid)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szVerIndProgID,Byval %NULL, szFriendlyName)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szVerIndProgID, "CLSID", szClsid)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szVerIndProgID, "CurVer", szProgID)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szProgID, Byval %NULL, "A COM Object Of Class C")) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szProgID, "CLSID", szClsid)) Then
Function=%E_FAIL : Exit Function
End If
Function=%S_OK
Exit Function
Else
Function=%E_FAIL
Exit Function
End If
Prnt " Leaving RegisterServer()", 1
End Function
Function UnregisterServer(Byref ClassId As Guid, Byref szVerIndProgID As Asciiz, Byref szProgID As Asciiz) As Long
Local szClsid As Asciiz*48, szKey As Asciiz*64
Local lResult As Long
szClsid=GuidTxt$(ClassId)
If szClsid<>"" Then
szKey="CLSID\"+szClsid
lResult=RecursiveDeleteKey(%HKEY_CLASSES_ROOT,szKey)
If lResult<>%ERROR_SUCCESS Then
Function=%E_FAIL
Exit Function
End If
lResult=RecursiveDeleteKey(%HKEY_CLASSES_ROOT, szVerIndProgID) 'Delete the version-independent ProgID Key.
If lResult<>%ERROR_SUCCESS Then
Function=%E_FAIL
Exit Function
End If
lResult=recursiveDeleteKey(%HKEY_CLASSES_ROOT, szProgID) 'Delete the ProgID key.
If lResult<>%ERROR_SUCCESS Then
Function=%E_FAIL
Exit Function
End If
Else
Function=%E_FAIL
Exit Function
End If
Function=%S_OK
End Function
--- End code ---
--- Code: ---'CC.idl
import "oaidl.idl";
[object, uuid(20000000-0000-0000-0000-000000000021), oleautomation, helpstring("The IX Interface Functions")] //IX
interface IX : IUnknown
{
HRESULT SetXInt([in] int iXVal);
HRESULT GetXInt([out, retval] int* pInt);
HRESULT SetXText([in] BSTR strText);
HRESULT GetXText([out, retval] BSTR* strText);
};
[object, uuid(20000000-0000-0000-0000-000000000022), oleautomation, helpstring("The IY Interface Functions")] //IY
interface IY : IUnknown
{
HRESULT SetYInt([in] int iYVal);
HRESULT GetYInt([out, retval] int* pInt);
HRESULT SetYText([in] BSTR strText);
HRESULT GetYText([out, retval] BSTR* strText);
};
[uuid(20000000-0000-0000-0000-000000000023), version(1.0), helpstring("Class CC With TypeLib")]
library CCLibrary
{
importlib("stdole32.tlb");
[uuid(20000000-0000-0000-0000-000000000020)]
coclass CC
{
[default] interface IX;
interface IY;
};
};
--- End code ---
--- Code: ---//CC.rc
1 typelib CC.TLB
//end cc.rc
--- End code ---
Navigation
[0] Message Index
[#] Next page
Go to full version