IT-Consultant: Frederick J. Harris > Fred's COM (Component Object Model) Tutorials

COM Tutorial #3: Building Local Server With Low Level PowerBASIC Code

(1/3) > >>

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