ExportCom (iDispatch/iClassFactory/DLL) with RES-Files

[GPI]

Based on my class definition http://www.purebasic.fr/english/viewtop ... 12&t=68475 I have created this variant to create an Com-Object/DLL-Com-Server.
Special thanks to mk-soft for his solution!

Again the ClassExportCom.pbi in the second post can be used as XIncludeFile() or to create a res-file. The class.pbi from the other thread is needed.


InitExportCom([CreateLogFile])
Should be called at the beginning. It create the Modul ExportCom. A UseModule ExportCom is executed automatically.

now you should define all the classes you want to export. They must not be a SubClass from iUnknown! You can declare this class in Modules.

There are two "Pseudo Types" for return-types of the methods
_P_BStr
You should use this type, when you want to return a string. it is basically a macro of "I". You must return the string with ProcedureReturn ReturnString(str.s).
_P_Dispatch
When you want to return an Dispatch-Object, you should use this. With this an Object can return an object.

When you want to export a property, there are Methods for this, add in the Interface/EndInterface section this two lines:
PROPERTYGET_<property>.<property-type>()
PROPERTYPUT_<property>(Value..<property-type>)
It is possible to only add get without put and put without get.

You can create the methods easily with
Dispatch_PropertyGet(<class>,<property>)
Dispatch_PropertyPut(<class>,<property>)
and this should be called before the DefineClass() statement.

Because my routines use AttachProcess() and DetachProcess(), you can create optional procedures InitDLL() and ExitDLL()

LogClass(type.s,text.s[,*obj])
Create an entry in an logfile. When you specific that no log file should be created, this commands are removed automatically (like the debug command).
For type you can use this constants: #LogClass_Error, #LogClass_Info and #LogClass_Warning

The constant LogClass can be used with CompilerIf/CompilerEndif to add Code only, when a Log file is created.

Code: Select all

CompilerIf #LogClass :dosomething: CompilerEndif

You can change in the InitDLL() the global variable LogClass_FileName. Default is "DLL-Pfad+Name.log".

At the end of the File you must Export the Classes.
ExportCom()
Start the export. Between ExportCom() and EndExportCom() you should only use ExportClass()!

ExportClass(<class>, ProgramId.s, CLSID.s, Description.s, InterfaceString.s)
ProgramId
Name of the Com-Class. You should use this format

Code: Select all

<Program>.<Component>.<Version>

Underlines are not allowed and it should not start with a number.

CLSID
An unique ID (without {})
This small program create a CLSID

Code: Select all

InitExportCom()
my.guid
Define a$
CoCreateGuid_(@my)
a$=GetStringFromGuid(my)
Debug a$

Description
A Description of the object, needed for the registration of the dll.

InterfaceString
This is a copy of Interface/EndInterface as a string. When a Method name starts with "METHOD_" it will be exported without the "METHOD_". This can be usefull to define Methods for internal use and exported use. The string must not contain all elements from the Interface. When you don't want not to export some Methods, simple remove it.

When a Method want to return an object, the class of this object must be "exportet". When you don't want to have this class public, simple set the ProgramID, CLSID and description to "".
EndExportCom()
Finalize the export. No program code should be after this line.

Additional Classes/Macros:
IUnknown
Class

IDIspatch and New_IDispatch(Obj)
Class. Create a new IDispatch-Object with an embedded Object.

IClassFactory(*vt)
Class[

GetStringFromGuid(*guid.guid)
Convert a GUID, IID, CLSID (basically they are all the same) in to a string

GetGuidFromString(guid$,*out.guid)
and convert back.

Improtant the GUID-String should be without {}.


An Example

Code: Select all

EnableExplicit

;Only include class.pbi, when no class.pbi.res exist!
CompilerIf Not Defined(_BaseClass,#PB_Structure)
  XIncludeFile "class.pbi"
CompilerEndIf

;Only Include class_exportcom.pbi, when no class_exportcom.pbi.res exist
CompilerIf Not Defined(__ComClass,#PB_Structure)
  #DoLogClass=#True
  XIncludeFile "class_exportcom.pbi"
CompilerElse
  InitExportCom(#True)
CompilerEndIf  

;{ testobj
Interface testobj Extends IDispatch
  Get._p_bstr()
  set(left.i,mid.s,right.i)
  PROPERTYGET_text._p_bstr()
  PROPERTYPUT_text(NewText.s)
  PROPERTYGET_double.d()
  propertyput_double(Value.d)
  propertyget_one.a()
  propertyput_one(value.a)
EndInterface
Structure _testobj Extends _IDispatch
  text.s
  double.d
  one.a
EndStructure
DeclareClass(testobj,IDispatch)

Procedure._p_bstr testobj_get(*self._testobj)
  LogClass(#LogClass_Info,"Return 99",*self)
  ProcedureReturn ReturnString("99")
EndProcedure:AsMethod(testobj,get)
Procedure testobj_set(*self._testobj,l.i,m.s,r.i)
  LogClass(#LogClass_Info,"Get "+l+" - "+m+" - "+r,*self)
  ProcedureReturn l*2
EndProcedure:AsMethod(testobj,set)
Dispatch_PropertyGet(testobj,double)
Dispatch_PropertyPut(testobj,double)
Dispatch_PropertyGet(testobj,text)
Dispatch_PropertyPut(testobj,text)
Dispatch_PropertyGet(testobj,one)
Dispatch_PropertyPut(testobj,one)
Method_QueryInterface(testobj,IDispatch,?iid_TestObj)
DefineClass(testobj,IDispatch)

DataSection
  iid_TestObj: ; "A04DD0C5-9B24-4497-B573-DB5944021046"
  Data.l $A04DD0C5
  Data.w $9B24,$4497
  Data.b $B5,$73,$DB,$59,$44,$02,$10,$46
EndDataSection
;}


DeclareModule Combi
  CompilerIf Defined(class,#PB_Module):UseModule class:CompilerEndIf
  
  
  UseModule ExportCom
  
  
  ;{ retTest
  Interface RetTest Extends BaseClass
    PropertyGet_text._p_BStr()
    maxstr._p_bstr()
  EndInterface
  
  Structure _RetTest Extends _BaseClass
    text.s
  EndStructure
  DeclareClass(rettest,BaseClass)
  ;}
  ;{ test2
  Interface test2 Extends BaseClass
    ReturnObj._p_DISPATCH(text.s)
  EndInterface
  Structure _test2 Extends _BaseClass
  EndStructure
  DeclareClass(test2,BaseClass)
  ;}
EndDeclareModule

Module combi
  Dispatch_PropertyGet(RetTest,text)
  
  Procedure.i rettest_maxstr(*self)
    Static str.s
    If str=""
      str=Space(1024*1024)
    EndIf
    ProcedureReturn ReturnString(str)
    
  EndProcedure:AsMethod(rettest,maxstr)
  
  DefineClass(rettest,BaseClass)
  
  Procedure test2_ReturnObj(*self._test2,text.s)
    Protected *obj._RetTest
    Protected *disp
    
    *obj=RetTest()
    *obj\text=text
    *disp=new_iDispatch(*obj)
    FreeObject(*obj)
    
    ProcedureReturn *disp
  EndProcedure : AsMethod(test2,ReturnObj)
  DefineClass(test2,BaseClass)
EndModule

Procedure InitDLL()
  LogClass_Filename=ProgramFilename()+"myCustomlogfile.txt" ; Optional!
  LogClass(#logclass_info,"Here we are!")
EndProcedure

Procedure ExitDLL()
  logclass(#logclass_info,"Bye")
EndProcedure



ExportCom()
ExportClass(testobj,
            "gpihomeeu.Example1.1",
            GetStringFromGuid(?iid_TestObj),
            "GPIHOME Com Class Example",
            "Get._p_bstr()"+
            "set(left.i,mid.s,right.i)"+
            "PROPERTYGET_text._p_bstr()"+
            "PROPERTYPUT_text(NewText.s)"+
            "PROPERTYGET_double.d()"+
            "propertyput_double(Value.d)"+
            "propertyget_one.a()"+
            "propertyput_one(value.a)")
exportclass(combi::test2,
            "gpihomeeu.Example2.1",
            "FE9FD00C-4F1E-4E79-B514-24C97688BA87",
            "GPIHOME Com Class Example2",
            "ReturnObj._p_DISPATCH(text.s)")
exportclass(combi::RetTest,
            "","","",
            "PropertyGet_text._p_BStr()"+
            "maxstr._p_BStr()")
EndExportCOM()

This Code should create an Example.DLL.

Test.vbs

dim obj,ret,test
set obj = createobject("gpihomeeu.Example1.1")
msgbox obj.get
ret=obj.set (12, "Muhaha", 23)
msgbox ret
obj.text = "VBS-Text-Test"
msgbox obj.text
test=obj.text
obj.double = 1.235
msgbox obj.double
obj.one =123
msgbox obj.one

dim obj2,obj3
set obj2 = CreateObject("gpihomeeu.Example2.1")
set obj3 = obj2.ReturnObj ("obj2test")
msgbox "obj3:" & obj3.text

dim xx ,i
test=obj3.maxstr
msgbox "one call - Open TaskManager and check Memory"

for i=1 to 100
xx=obj3.maxstr
next

msgbox "many calls - used memory should be the same"

set obj = Nothing
set obj2=Nothing
set obj3=nothing
set obj=CreateObject("gpihomeeu.Example1.1")
obj.double=4.5
msgbox obj.double

And my Test.bat (should be started with Admin rights and you must correct the paths.

Code: Select all

:start
%systemroot%\System32\regsvr32.exe "C:\Users\GPI\Documents\!PureBasic\objtest\example.dll"
%windir%\System32\wscript.exe "C:\Users\GPI\Documents\!PureBasic\objtest\!Example.vbs"
%systemroot%\System32\regsvr32.exe -u "C:\Users\GPI\Documents\!PureBasic\objtest\example.dll"
pause

goto start

bzw 32bit:

Code: Select all

:start
%systemroot%\Syswow64\regsvr32.exe "C:\Users\GPI\Documents\!PureBasic\objtest\example32.dll"
%windir%\Syswow64\wscript.exe "C:\Users\GPI\Documents\!PureBasic\objtest\!Example.vbs"
%systemroot%\Syswow64\regsvr32.exe -u "C:\Users\GPI\Documents\!PureBasic\objtest\example32.dll"
pause

goto start

[GPI]

ClassExportCom.pbi

Code: Select all

;    Description: ExportCOM-Definition (Work as IncludeFile and as RES-File)
;         Author: GPI
;           Date: 2017-05-14
;     PB-Version: 5.60
;             OS: Windows
;  English-Forum: http://www.purebasic.fr/english/viewtopic.php?f=12&t=68476
;   French-Forum: 
;   German-Forum: http://www.purebasic.fr/german/viewtopic.php?f=8&t=30144
; -----------------------------------------------------------------------------
; Compile this file with /RESIDENT for create a RES file
; OR use it as IncludeFile (UseModul Class)
;
; Changelog 1.2
;    CHANGE: New_IDispatch(*obj) - when you want to create a Dispatch, use this routine.
; 
; Changelog 1.1
;    - Bugfix

;http://www.codeguru.com/cpp/com-tech/activex/tutorials/article.php/c5567/Step-by-Step-COM-Tutorial.htm
;https://msdn.microsoft.com/en-us/library/cc237842.aspx
;https://msdn.microsoft.com/en-us/library/windows/desktop/ms688707(v=vs.85).aspx
;<Program>.<Component>.<Version>,
;dispid .w
;lcid .l

;{ Warper for IncludeFile
CompilerIf #PB_Compiler_IsMainFile=#False
  CompilerIf Not Defined(BaseClass,#PB_Structure)
    XIncludeFile "class.pbi"
  CompilerEndIf
  
  CompilerIf Defined(DoLogClass,#PB_Constant) 
    CompilerIf #DoLogClass
      DeclareModule ExportCom
        #LogClass=#True
      CompilerIf #False:EndDeclareModule:CompilerEndIf;Correction of the Indention
    CompilerElse
      DeclareModule ExportCom
        #LogClass=#False
      CompilerIf #False:EndDeclareModule:CompilerEndIf;Correction of the Indention
    CompilerEndIf
  CompilerElse
    DeclareModule ExportCom
      #LogClass=#False
    CompilerIf #False:EndDeclareModule:CompilerEndIf;Correction of the Indention
  CompilerEndIf

    EnableExplicit
    CompilerIf Defined(Class,#PB_Module)
      UseModule Class
    CompilerEndIf
  CompilerIf #False:EndDeclareModule:CompilerEndIf;Correction of the Indention  
CompilerEndIf
;}

#ExportCom_Version=$0102

;{ Macros
Macro ReturnString(string)
  SysAllocString_(string)
EndMacro
Macro BStr(string)
  SysAllocString_(string)
EndMacro
Macro FreeBStr(string)
  SysFreeString_(string)
EndMacro
Macro _p_BStr
  i
EndMacro
Macro _p_DISPATCH
  i
EndMacro
Macro LogClass(type,text,class=0)
  CompilerIf #LogClass
    __LogClass(type,text,#PB_Compiler_Procedure,class)
  CompilerEndIf  
EndMacro
Macro Method_QueryInterface(class,parentClass,classiid)
  Procedure class#_QueryInterface(*self._iunknown,*riid.iid,*out_Object.integer)
    
    ;LogClass(#logclass_info,"Test for "+GetStringFromGuid(*riid),*self)
    Protected count
    If *out_Object=0 Or *riid=0
      LogClass(#LogClass_Error,"No Pointer",*self)
      ProcedureReturn #E_POINTER
    EndIf
    If CompareMemory(*riid, classiid, SizeOf(iid))
      count=ReferenceObject(*self)
      LogClass(#LogClass_Info,"OK ("+count+")",*self)
      *out_Object\i=*self
      ProcedureReturn #S_OK 
    EndIf
    
    CompilerIf Defined(parentClass#_QueryInterface,#PB_Procedure)
      ProcedureReturn parentClass#_QueryInterface(*self,*riid,*out_Object)
    CompilerElseIf Defined(parentclass#_GetVTable__,#PB_Procedure)
      ProcedureReturn CallFunctionFast(PeekI(parentclass#_GetVTable__()+OffsetOf(iunknown\QueryInterface())),*self,*riid,*out_Object)
    CompilerElse    
      CompilerIf #LogClass
        Protected a$
        a$=GetStringFromGuid(*riid)
        If a$="342D1EA0-AE25-11D1-89C5-006008C3FBFC"
          a$="IClassFactoryEx" 
        ElseIf a$="FC4801A3-2BA9-11CF-A229-00AA003D7352"
          a$="IObjectWithSite"
        ElseIf a$="A6EF9860-C720-11D0-9337-00A0C90DCAA9"
          a$="IDispatchEx"
        EndIf
        LogClass(#LogClass_error,"Interface not supported: "+a$,*self)
      CompilerEndIf
      
      ProcedureReturn #E_NOINTERFACE    
    CompilerEndIf  
  EndProcedure:AsMethod(class,QueryInterface)
EndMacro

Macro Dispatch_PropertyGet(class,property)
  CompilerSelect TypeOf(_#class\property)
    CompilerCase #PB_Byte
      Procedure.b class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
    CompilerCase #PB_Ascii
      Procedure.a class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
    CompilerCase #PB_Word
      Procedure.w class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
    CompilerCase #PB_Unicode
      Procedure.u class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
    CompilerCase #PB_Long
      Procedure.l class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
    CompilerCase #PB_Quad
      Procedure.q class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
    CompilerCase #PB_Float
      Procedure.f class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
    CompilerCase #PB_Double
      Procedure.d class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
    CompilerCase #PB_String
      Procedure.i class#_PROPERTYGET_#property(*self._#class):ProcedureReturn ReturnString(*self\property):EndProcedure
  CompilerEndSelect
  AsMethod(class,PROPERTYGET_#property)  
EndMacro
Macro Dispatch_PropertyPut(class,property)
  CompilerSelect TypeOf(_#class\property)
    CompilerCase #PB_Byte
      Procedure class#_PROPERTYPUT_#property(*self._#class,value.b):*self\property=value:EndProcedure
    CompilerCase #PB_Ascii
      Procedure class#_PROPERTYPUT_#property(*self._#class,value.a):*self\property=value:EndProcedure
    CompilerCase #PB_Word
      Procedure class#_PROPERTYPUT_#property(*self._#class,value.w):*self\property=value:EndProcedure
    CompilerCase #PB_Unicode
      Procedure class#_PROPERTYPUT_#property(*self._#class,value.u):*self\property=value:EndProcedure
    CompilerCase #PB_Long 
      Procedure class#_PROPERTYPUT_#property(*self._#class,value.l):*self\property=value:EndProcedure
    CompilerCase #PB_Quad
      Procedure class#_PROPERTYPUT_#property(*self._#class,value.q):*self\property=value:EndProcedure
    CompilerCase #PB_Float
      Procedure class#_PROPERTYPUT_#property(*self._#class,value.f):*self\property=value:EndProcedure
    CompilerCase #PB_Double
      Procedure class#_PROPERTYPUT_#property(*self._#class,value.d):*self\property=value:EndProcedure
    CompilerCase #PB_String
      Procedure class#_PROPERTYPUT_#property(*self._#class,value.s):*self\property=value:EndProcedure
  CompilerEndSelect
  AsMethod(class,PROPERTYPUT_#property)
EndMacro

Macro __ExportCounter
  MacroExpandedCount
EndMacro
Macro ExportCom()
  ProcedureDLL AttachThread(Instance)
    ;LogClass(#LogClass_Info,"Attach Thread "+Hex(Instance))
  EndProcedure
  ProcedureDLL DetachThread(Instance)
    ;LogClass(#LogClass_Info,"Detach Thread "+Hex(Instance))
  EndProcedure
  ProcedureDLL AttachProcess(Instance)
    Protected a$,nb,*cc.__ComClass
    Protected *nVT.__Class_nVT
    
    CompilerIf Defined(InitDll,#PB_Procedure)
      InitDll()
    CompilerEndIf 
    
    LogClass(#LogClass_Info,"------- DLL load -------");+Hex(Instance))
    Global Dim __ComClass.__ComClass(PeekI(?label))
  EndMacro
  Macro ExportClass(class,pid,ciid,desc,InterfacedataString)  
    
    *cc=__ComClass(__ExportCounter-1)
    *cc\ProgramID= pid
    *cc\CLSID= ciid
    *cc\Description= desc
    GetGuidFromString(*cc\CLSID,*cc\iid)
    *cc\vt=class#_GetVTable__()
    
    If *cc\vt
      *nvt=*cc\VT-SizeOf(__Class_nVT)
      *nvt\exportclass=*cc
      a$=PeekS(*nvt\classname);PeekS(PeekI(*cc\vt-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\ClassName)))
    Else
      a$=""
    EndIf
    
    *cc\interfacedata=__Create_InterfaceData(*cc\vt, InterfacedataString)
    If *cc\interfacedata
      If CreateDispTypeInfo_(*cc\interfacedata,#LOCALE_SYSTEM_DEFAULT,@ *cc\typeinfo)=#S_OK
        LogClass(#LogClass_Info,"ITypeInfo created for "+a$)
      Else
        LogClass(#LogClass_Error,"Can't create ITypeInfo for "+a$)
      EndIf
    Else
      LogClass(#LogClass_Error,"Can't create InterfaceData for "+a$)
    EndIf
  EndMacro
  
  Macro EndExportCom()    
    
    DataSection 
      label:
      Data.i __ExportCounter-2
    EndDataSection
  EndProcedure
  
  ProcedureDLL DetachProcess(Instance) ;-DetachProcess
    Protected a$
    LogClass(#LogClass_Info,"------- DLL unload -------");+Hex(Instance))
    
    Protected i
    For i=0 To ArraySize(__ComClass())
      If __ComClass(i)\ClassFactory
        __ComClass(i)\ClassFactory\Release()
        __ComClass(i)\ClassFactory=0
      EndIf
      
      If __ComClass(i)\vt
        a$=PeekS(PeekI(__ComClass(i)\vt-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\ClassName)))
      Else
        a$=""
      EndIf
      
      If __ComClass(i)\typeinfo
        __ComClass(i)\typeinfo\Release()
        __ComClass(i)\typeinfo=0
      EndIf
      LogClass(#LogClass_Info,"Free TypeInfo for "+a$)
      If __ComClass(i)\interfacedata
        __Free_InterfaceData(__ComClass(i)\interfacedata)
        __ComClass(i)\interfacedata=0
      EndIf  
    Next
    CompilerIf Defined(ExitDll,#PB_Procedure)
      ExitDll()
    CompilerEndIf  
    LogClass(#LogClass_HR,"")
    LogClass("","")
  EndProcedure
  

  ProcedureDLL DllGetClassObject(*rclsid,*riid,*out_object.integer);- DllGetClassObject
    Protected i,hres
    
    If *out_object=0 Or *rclsid=0 Or *riid=0
      LogClass(#LogClass_error,"pointer is zero")
      ProcedureReturn #E_INVALIDARG
    EndIf
    
    *out_object\i=0
    
    hres= #CLASS_E_CLASSNOTAVAILABLE  
    If CompareMemory(*riid,?IID_IClassFactory,SizeOf(iid))
      For i=0 To ArraySize(__ComClass())
        If __ComClass(i)\clsid<>"" And __ComClass(i)\programid<>"" And __ComClass(i)\Description<>"" And 
           CompareMemory(*rclsid,__ComClass(i)\iid,SizeOf(iid))
          
          If __ComClass(I)\ClassFactory=0
            __ComClass(I)\ClassFactory=IClassFactory(__ComClass(i)\vt)
          EndIf  
          If __ComClass(I)\ClassFactory
            __ComClass(i)\ClassFactory\AddRef()
            
            *out_object\i=__ComClass(I)\ClassFactory
            CompilerIf #logclass
              Protected a$=GetClassIdName(__ComClass(i)\vt)
            CompilerEndIf  
            hres=#S_OK
          EndIf  
          Break
        EndIf
      Next
      
      CompilerIf #LogClass
        If hres=#S_OK
          LogClass(#LogClass_Info,"New IClassFactory@"+Hex(*out_object\i)+" with "+a$)
        Else
          LogClass(#LogClass_Error,"Class not available "+GetStringFromGuid(*rclsid))
        EndIf
      Else
        LogClass(#LogClass_Error,"Only support for IClassFactory "+GetStringFromGuid(*riid))
      CompilerEndIf  
      
    EndIf
    
    ProcedureReturn hres  
  EndProcedure
  
  ProcedureDLL DllCanUnloadNow();- DllCanUnloadNow
    Protected i
    Protected *nVT.__Class_nVT
    Protected hres=#S_OK
    Protected count=0
    
    CompilerIf #logclass
      Protected a$
      a$=" Lock:"+IClassFactory_LockCount+
                              " IDispatch:"+CountObject(IDispatch)+
                              " IClassFactory:"+CountObject(IClassFactory)
    CompilerEndIf
    
    count=IClassFactory_LockCount
    count+ CountObject(IDispatch)
    count+ CountObject(IClassFactory) 
    For i=0 To ArraySize(__ComClass())
      *nVT=__ComClass(I)\vt-SizeOf(__Class_nVT)
      count+ *nvt\count
      If __ComClass(i)\ClassFactory
        count- 1
      EndIf
      
      CompilerIf #LogClass
        a$+" "+ PeekS(*nvt\ClassName) +":"+ *nVT\Count
      CompilerEndIf
      
    Next
    
    If count<>0
      hres=#S_FALSE
    EndIf
    
    CompilerIf #LogClass
      a$="Count:"+count+" "+a$
    
      If hres=#S_OK
        LogClass(#LogClass_Info,"ok "+a$)
      Else
        LogClass(#LogClass_Info,"False "+a$)
      EndIf
    CompilerEndIf
    
    ProcedureReturn hres
  EndProcedure
  
  ProcedureDLL DllUnregisterServer();-DllUnregisterServer
    Protected a$,i,hres=#S_OK
    
    For i=0 To ArraySize(__ComClass())
      If __ComClass(i)\clsid<>"" And __ComClass(i)\ProgramID<>"" And __ComClass(i)\Description<>""
        a$="{"+ __ComClass(i)\CLSID +"}"
        
        If RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + a$ + "\ProgId")         <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
        If RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + a$ + "\InprocServer32") <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
        If RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + a$)                     <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
        
        If RegDeleteKey_(#HKEY_CLASSES_ROOT, __ComClass(i)\ProgramID + "\CLSID") <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
        If RegDeleteKey_(#HKEY_CLASSES_ROOT, __ComClass(i)\ProgramID)            <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
        LogClass(#LogClass_info,"Unregister "+ __ComClass(i)\ProgramID+" "+ a$)
      EndIf
    Next
    
    CompilerIf #LogClass
      If hres=#ERROR_SUCCESS    
        LogClass(#LogClass_Info,"OK")
      Else
        LogClass(#LogClass_Error,"Can't delete RegKeys")
      EndIf
    CompilerEndIf
    ProcedureReturn hres
  EndProcedure
  
  Procedure Regkey__(key.s,value.s);-RegKey__
    Protected hres=#S_OK,hKey.i
    
    If RegCreateKeyEx_(#HKEY_CLASSES_ROOT, key, 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)=#ERROR_SUCCESS
      If  RegSetValueEx_(hKey, "", 0, #REG_SZ, value, StringByteLength(value) + 2)<>#ERROR_SUCCESS
        hres=#E_UNEXPECTED
      EndIf
      If RegCloseKey_(hKey)<>#ERROR_SUCCESS
        hres=#E_UNEXPECTED
      EndIf
    Else
      hres=#E_UNEXPECTED
    EndIf
    ProcedureReturn hres
  EndProcedure
  
  ProcedureDLL DllRegisterServer();-DllRegisterServer
    Protected DLL_Name.s
    Protected i.i,hres=#S_OK
    Protected a$
    
    DLL_Name = ProgramFilename()
    
    For i=0 To ArraySize(__ComClass())
      If __ComClass(i)\clsid<>"" And __ComClass(i)\ProgramID<>"" And __ComClass(i)\Description<>"" And __ComClass(i)\iid
        a$="{"+ __ComClass(i)\CLSID +"}"
        
        If Not(regkey__(__ComClass(i)\ProgramID         ,__ComClass(i)\Description)       =#S_OK And 
               regkey__(__ComClass(i)\ProgramID+"\CLSID",a$)                              =#S_OK And          
               regkey__("CLSID\"+a$                     ,__ComClass(i)\Description)       =#S_OK And 
               regkey__("CLSID\"+a$+"\InprocServer32"   ,DLL_Name)                        =#S_OK And 
               Regkey__("CLSID\"+a$+"\ProgId"           ,__ComClass(i)\ProgramID )        =#S_OK)
          
          hres=#E_UNEXPECTED
          Break
        EndIf
        LogClass(#LogClass_info,"Register "+ __ComClass(i)\ProgramID+" "+ a$)
      EndIf
    Next
    
    If hres<>#ERROR_SUCCESS 
      
      DllUnregisterServer()
      
      CompilerIf #LogClass
        LogClass(#LogClass_Error,"Can't create RegKeys")
      Else
        LogClass(#LogClass_Info,"OK")
      CompilerEndIf
      
    EndIf
    ProcedureReturn hres
    
  EndProcedure
  
  CompilerIf #PB_Compiler_ExecutableFormat<>#PB_Compiler_DLL ;Or #PB_Compiler_Debugger
    AttachProcess(0)
  CompilerEndIf
  
  
EndMacro
;}

;{ Constants
#DISPID_UNKNOWN=-1
#DISPID_VALUE=0
#DISPID_PROPERTYPUT=-3

Enumeration CALLCONV 
  #CC_FASTCALL    = 0
  #CC_CDECL       = 1
  #CC_MSCPASCAL   = ( #CC_CDECL + 1 )
  #CC_PASCAL      = #CC_MSCPASCAL
  #CC_MACPASCAL   = ( #CC_PASCAL + 1 )
  #CC_STDCALL     = ( #CC_MACPASCAL + 1 )
  #CC_FPFASTCALL  = ( #CC_STDCALL + 1 )
  #CC_SYSCALL     = ( #CC_FPFASTCALL + 1 )
  #CC_MPWCDECL    = ( #CC_SYSCALL + 1 )
  #CC_MPWPASCAL   = ( #CC_MPWCDECL + 1 )
  #CC_MAX         = ( #CC_MPWPASCAL + 1 )
EndEnumeration

#VT_PBByte=#VT_I1
#VT_PBAscii=#VT_UI1
#VT_PBWord=#VT_I2
#VT_PBUnicode=#VT_UI2
#VT_PBLong=#VT_I4
#VT_PBQuad=#VT_I8
#VT_PBFloat=#VT_R4
#VT_PBDouble=#VT_R8
#VT_PBString=#VT_BSTR
CompilerIf #PB_Compiler_Processor=#PB_Processor_x64
  #VT_PBInteger=#VT_I8
CompilerElse
  #VT_PBInteger=#VT_I4
CompilerEndIf
;}

;{ Structures
Structure __ComClass
  ProgramID.s
  CLSID.s
  Description.s
  iid.iid
  *vt
  *interfacedata
  *typeinfo.ITypeinfo
  *ClassFactory.IClassFactory
EndStructure

Structure __pbvariant
  vt.w
  wReserved1.w
  wReserved2.w
  wReserved3.w
  StructureUnion
    Ascii.a
    Byte.b
    Word.w
    Unicode.u
    Long.l
    Quad.q
    Float.f
    Double.d
    *String
    Integer.i    
    *Pointer
  EndStructureUnion
EndStructure
Structure PBVariant
  StructureUnion
    vt.w
    PB.__pbvariant
    Variant.variant
  EndStructureUnion
EndStructure

Structure INTERFACEDATA Align #PB_Structure_AlignC 
  *pmethdata
  cMembers.l
EndStructure

Structure MethodData Align #PB_Structure_AlignC 
  *szName;OLECHAR   
  *ppdata;PARAMDATA 
  dispid.l;
  iMeth.l ;
  cc.l    ;CALLCONV
  cArgs.l ;
  wFlags.w;
  vtReturn.u;VARTYPE   
EndStructure

Structure PARAMDATA Align #PB_Structure_AlignC 
  *szName;OLECHAR
  vt.u   ;VARTYPE
EndStructure

;}

Macro InitExportCom(DoLogFile=#False)
 
  CompilerIf Not Defined(ExportCom,#PB_Module)
    DeclareModule ExportCom
      CompilerIf Defined(Class,#PB_Module)
        UseModule Class
      CompilerEndIf
      EnableExplicit
    CompilerEndIf  
    
    CompilerIf #CLASS_Version<$0104
      CompilerError "Outdated Class.pbi"
    CompilerEndIf
    
    CompilerIf Not Defined(LogClass,#PB_Constant)
      #LogClass=DoLogFile
    CompilerEndIf
    
    CompilerIf #LogClass
      Global LogClass_FileName.s
      Declare __LogClass(Type.s,Text.s,Proc.s,*class.BaseClass=0)
      #LogClass_Error="ERROR"
      #LogClass_Info="INFO"
      #LogClass_Warning="WARNING"
      #LogClass_HR="-"
      #LogClass_FormatDate="%dd.%mm.%yyyy %hh:%ii:%ss"
    CompilerEndIf
    
    CompilerIf #PB_Compiler_Processor=#PB_Processor_x86
      #__Create_Interfacedata_CC=#CC_STDCALL
    CompilerElse
      #__Create_Interfacedata_CC=#CC_FASTCALL
    CompilerEndIf
    
    DataSection
      IID_ITypeInfo: ;00020401-0000-0000-C000-000000000046
      Data.l $00020401
      Data.w $0000,$0000
      Data.b $C0,$00,$00,$00,$00,$00,$00,$46
      
      IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
      Data.l $00000000
      Data.w $0000,$0000
      Data.b $C0,$00,$00,$00,$00,$00,$00,$46
      
      IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
      Data.l $00020400
      Data.w $0000,$0000
      Data.b $C0,$00,$00,$00,$00,$00,$00,$46
      
      IID_IClassFactory: ; 00000001-0000-0000-C000-000000000046
      Data.l $00000001
      Data.w $0000,$0000
      Data.b $C0,$00,$00,$00,$00,$00,$00,$46

    EndDataSection
    
    
    Declare.s GetStringFromGuid(*guid.guid)
    Declare GetGuidFromString(guid$,*out.guid)
    CompilerIf #LogClass
      Declare __LogClass(Type.s,Text.s,Proc.s,*class.BaseClass=0)
    CompilerEndIf
    Declare __Create_InterfaceData(*VT,inter.s,cc=#__Create_Interfacedata_CC)
    Declare __Free_InterfaceData(*data.INTERFACEDATA)
    
    Structure _IUnknown Extends _BaseClass
    EndStructure
    DeclareClass(IUnknown)
   
    Structure _IDispatch Extends _IUnknown
      *TypeInfo.iTypeInfo
      *obj.BaseClass
    EndStructure
    ThreadSafe_DeclareClass(IDispatch,IUnknown)
    
    Structure _IClassFactory Extends _IUnknown
      *vt
      *iid
    EndStructure
    Global IClassFactory_LockCount.i
    threadsafe_DeclareClass(IClassFactory,IUnknown,(*VT))
    
    DeclareClassHelper__()
    Declare IUnknown_QueryInterface(class,parentClass,classiid)
    Declare IDispatch_QueryInterface(class,parentClass,classiid)
    Declare IClassFactory_QueryInterface(class,parentClass,classiid)
    Declare New_IDispatch(*obj.BaseClass=0)
  EndDeclareModule
  
  Module ExportCom  
    CompilerIf Not Defined(class,#PB_Module)
      DefineClassHelper__()
    CompilerEndIf    
    
    Procedure.s GetStringFromGuid(*guid.guid);-ExportCom::GetStringFormGuid
      Protected guidstr.s
      If *guid
        guidstr=RSet(Hex(*guid\Data1,#PB_Long),8,"0")+"-"+
                RSet(Hex(*guid\data2,#PB_Word),4,"0")+"-"+
                RSet(Hex(*guid\Data3,#PB_Word),4,"0")+"-"+
                RSet(Hex(*guid\data4[0],#PB_Byte),2,"0")+RSet(Hex(*guid\data4[1],#PB_Byte),2,"0")+"-"+
                RSet(Hex(*guid\data4[2],#PB_Byte),2,"0")+RSet(Hex(*guid\data4[3],#PB_Byte),2,"0")+
                RSet(Hex(*guid\data4[4],#PB_Byte),2,"0")+RSet(Hex(*guid\data4[5],#PB_Byte),2,"0")+
                RSet(Hex(*guid\data4[6],#PB_Byte),2,"0")+RSet(Hex(*guid\data4[7],#PB_Byte),2,"0")
      EndIf
      ProcedureReturn guidstr
    EndProcedure
    
    Procedure GetGuidFromString(guid$,*out.guid);ExportCom::GetGuidFromString
      If *out And Len(guid$)=36
        If Mid(guid$,9,1)="-" And Mid(guid$,14,1)="-" And Mid(guid$,19,1)="-" And Mid(guid$,24,1)="-"
          *out\Data1=Val("$"+Mid(guid$,1,8))
          *out\data2=Val("$"+Mid(guid$,10,4))
          *out\data3=Val("$"+Mid(guid$,15,4))
          *out\Data4[0]=Val("$"+Mid(guid$,20,2))
          *out\Data4[1]=Val("$"+Mid(guid$,22,2))
          *out\Data4[2]=Val("$"+Mid(guid$,25,2))
          *out\Data4[3]=Val("$"+Mid(guid$,27,2))
          *out\Data4[4]=Val("$"+Mid(guid$,29,2))
          *out\Data4[5]=Val("$"+Mid(guid$,31,2))
          *out\Data4[6]=Val("$"+Mid(guid$,33,2))
          *out\Data4[7]=Val("$"+Mid(guid$,35,2))      
          ProcedureReturn #True
        EndIf  
      EndIf
      ProcedureReturn #False
    EndProcedure
    
    CompilerIf #LogClass
      Procedure.s __LSet(str.s,l)
        If Len(str)<l
          str=LSet(str,l)
        EndIf
        ProcedureReturn str
      EndProcedure
      Procedure __LogClass(Type.s,Text.s,Proc.s,*class.BaseClass=0);-ExportCom::__LogClass
        Static mutex,out
        Protected class$,info$
        
        If type="" And text="" And *class=0
          If out
            CloseFile(out)
            out=0
          EndIf
          ProcedureReturn #True
        EndIf
        
        If mutex=0
          mutex=CreateMutex()
        EndIf
        
        LockMutex(mutex)
        
        If *class<>0
          class$=GetObjectClassName(*class)+"@"+Hex(*class)
        Else
          class$="-@-"
        EndIf
        
        If type=#LogClass_HR
          info$=""
        Else
          info$="["+FormatDate(#LogClass_FormatDate,Date())+~"]"+
                __LSet("["+type+~"]",9)+
                __LSet("["+class$+~"]",30)+
                __LSet("["+proc+~"]",30)+                    
                text
        EndIf
        
        Debug info$
        CompilerIf #PB_Compiler_Debugger=0  
          If LogClass_FileName=""
            LogClass_FileName=ProgramFilename()
            LogClass_FileName=Left(LogClass_FileName,Len(LogClass_FileName)-Len(GetExtensionPart(LogClass_FileName)))+"log"
          EndIf
          If out=0            
            out= OpenFile(#PB_Any,LogClass_FileName,#PB_File_Append|#PB_File_SharedRead |#PB_File_SharedWrite|#PB_File_NoBuffering)
          EndIf  
          If out
            WriteStringN(out,info$) 
            FlushFileBuffers(out)
          EndIf
        CompilerEndIf
        
        UnlockMutex(mutex)
      EndProcedure
    CompilerEndIf
    
    Procedure __VariantType(Type);-ExportCom::__VariantType
      Protected ret
      Select Type
        Case 'B','b':ret=#VT_PBByte
        Case 'A','a':ret=#VT_PBAscii
        Case 'W','w':ret=#VT_PBWord
        Case 'U','u':ret=#VT_PBUnicode
        Case 'L','l':ret=#VT_PBLong
        Case 'Q','q':ret=#VT_PBQuad
        Case 'F','f':ret=#VT_PBFloat
        Case 'D','d':ret=#VT_PBDouble
        Case 'S','s':ret=#VT_PBString
        Case 'I','i':ret=#VT_PBInteger
        Default:Ret=#VT_PBInteger
          Debug "Illegal __VariantType "+Type+" "+Chr(Type)
      EndSelect
      ProcedureReturn ret
    EndProcedure
    
    Procedure __Create_InterfaceData(*VT,inter.s,cc=#__Create_Interfacedata_CC);-ExportCom::__Create_InterfaceData
      Protected MethodCount,i
      Protected line.s, Method.s, MethodType.s, Para.s, Flag.w, Offset.l,vt_type.w
      Protected *data.INTERFACEDATA,*MD.MethodData
      Protected ParaCount,pi,MaxParaCount
      Protected *para,*PA.PARAMDATA,*ParaCurrent
      Protected ParaName.s,ParaType.s
      Protected id,idCount
      NewMap ids()
      
      inter=UCase(ReplaceString(inter," ",""))
      
      MethodCount=CountString(inter,")")
      
      For i=1 To MethodCount
        line.s=StringField(inter.s,i,")")
        Para=StringField(line,2,"(")
        If Para<>""
          MaxParaCount+CountString(para,",")+1
        EndIf
      Next
      
      *Data=AllocateMemory(SizeOf(INTERFACEDATA) + SizeOf(MethodData) * MethodCount + SizeOf(PARAMDATA)*MaxParaCount)
      ;logclass(#LogClass_info,"Size:"+Str(SizeOf(INTERFACEDATA) + SizeOf(MethodData) * MethodCount + SizeOf(PARAMDATA)*MaxParaCount))
      
      If *Data
        *MD=*data+SizeOf(INTERFACEDATA)
        *ParaCurrent=*MD+ SizeOf(MethodData) * MethodCount
        
        *data\cMembers=MethodCount
        *data\pmethdata=*MD
        
        For i=1 To MethodCount
          line.s=StringField(inter.s,i,")")
          
          Method=StringField(StringField(line,1,"("),1,"=")
          MethodType=StringField(Method,2,"."):If MethodType="": MethodType="i" :EndIf
          Method=StringField(Method,1,".")
          Offset=Class_GetIndex__(*vt,method)
          Select MethodType
            Case "_P_BSTR": vt_type=#VT_PBString
            Case "_P_DISPATCH":vt_type=#VT_DISPATCH
            Default:vt_type=__VariantType(Asc(MethodType))          
          EndSelect
          
          If Left(method,12)="PROPERTYGET_"
            method=Mid(Method,13)
            Flag=#DISPATCH_PROPERTYGET
          ElseIf Left(method,12)="PROPERTYPUT_"
            method=Mid(Method,13)
            Flag=#DISPATCH_PROPERTYPUT
            vt_type=#VT_NULL
          ElseIf Left(method,7)="METHOD_"
            method=Mid(method,8)
            Flag=#DISPATCH_METHOD
          Else
            Flag=#DISPATCH_METHOD
          EndIf
          
          If ids(method)=0
            idCount+1
            ids()=idCount
          EndIf
          id=ids()  
          
          ;LogClass(#LogClass_Info,""+id+" Method:"+Method+" type:"+MethodType+" "+vt_type+" Flag:"+flag+" offset:"+offset)
          
          Para=StringField(line,2,"(")
          If Para=""
            ;LogClass(#LogClass_Info,"  NO PARAMETER")
            ParaCount=0
            *para=0
          Else
            ParaCount=CountString(para,",")+1
            *para=*ParaCurrent
            
            ;LogClass(#LogClass_Info, "  PARA")
            *PA=*para
            For pi=1 To ParaCount
              ParaName=StringField(StringField(Para,pi,","),1,"=")
              ParaType=Trim(StringField(ParaName,2,".")):If ParaType="": ParaType="i" :EndIf
              ParaName=Trim(StringField(ParaName,1,"."))
              If Left(ParaName,1)="*"
                ParaName=Mid(ParaName,2)
                ParaType="*"
              EndIf
              
              ;LogClass(#LogClass_Info,"    "+ParaName+" "+ParaType)
              
              *pa\szName=BSTR(ParaName)
              *pa\vt=__VariantType(Asc(ParaType))
              *pa+SizeOf(PARAMDATA)
            Next
            ;LogClass(#LogClass_Info,"  ENDPARA")
            
            *ParaCurrent=*pa
          EndIf
          
          *MD\szName=BSTR(Method)
          *MD\ppdata=*para
          *MD\dispid=id
          *MD\iMeth=Offset 
          *MD\cc=cc
          *MD\cArgs=ParaCount
          *MD\wFlags=flag
          *MD\vtReturn=vt_type
          *MD + SizeOf(MethodData)
          
          CompilerIf #LogClass
            If offset<0
              LogClass(#LogClass_error,"Method not found:"+method+" "+para)
            EndIf            
          CompilerEndIf
          
        Next
        
      EndIf
      ;logclass(#logclass_info,"last:"+Str(*ParaCurrent-*data))
      ;LogClass(#LogClass_Info,"OK @"+Hex(*data))
      ProcedureReturn *data
    EndProcedure
    
    Procedure __Free_InterfaceData(*data.INTERFACEDATA);-ExportCom::__Free_InterfaceData
      Protected i,pi
      Protected *MD.MethodData
      Protected *pa.PARAMDATA
      
      ;LogClass(#LogClass_Info,"Free @"+Hex(*data))
      
      If *data
        *md=*data\pmethdata
        For I=1 To *data\cMembers
          If *md\szName
            FreeBStr(*md\szName)
          EndIf
          
          *pa=*md\ppdata
          For PI=1 To *md\cArgs
            If *pa\szName
              FreeBStr(*pa\szName)
            EndIf
            
            *pa+SizeOf(PARAMDATA)
          Next      
          
          *md+SizeOf(MethodData)
        Next    
        FreeMemory(*data)
      EndIf  
    EndProcedure    
    
    
    ;{ ExportCom::IUnknown
    Procedure IUnknown_AddRef(*self._IUnknown)
      Protected ref=ReferenceObject(*self)
      LogClass(#LogClass_Info,"Count: "+ref,*self)
      ProcedureReturn ref
    EndProcedure:AsMethod(IUnknown,Addref)
    
    Procedure IUnknown_Release(*self._IUnknown)
      Protected Result
      LogClass(#LogClass_Info,"Count: "+Str(CountReferenceObject(*self)-1),*self)
      result=FreeObject(*self)
      ProcedureReturn result
    EndProcedure:AsMethod(IUnknown,Release)
    
    Method_QueryInterface(IUnknown,BaseClass,?IID_IUnknown)
    
    DefineClass(IUnknown,BaseClass)
    
    ;}
    
    
    ;{ ExportCom::IDispatch   
    Procedure New_IDispatch(*obj.BaseClass=0)
      Protected *typeinfo.ITypeInfo
      Protected *cc.__ComClass
      Protected *nVT.__Class_nVT
      Protected *this.IUnknown
      Protected *self._iDispatch
      
      If IsClassObject(iDispatch,*obj)
        *self=*obj
      Else
        *self=iDispatch()
        If *self=0
          ProcedureReturn 0
        EndIf
      EndIf
      
      If IsObject(*obj)=#False
        LogClass(#LogClass_Error,"Object is not valid")
        FreeObject(*self)
        ProcedureReturn 0
      EndIf
      
      *nvt=PeekI(*obj)-SizeOf(__Class_nVT)
      *cc=*nvt\ExportClass
      If *cc 
        *typeinfo=*cc\typeinfo
      EndIf  
      
      If *typeinfo<>0 And *typeinfo\QueryInterface(?IID_ITypeInfo,@ *self\TypeInfo)=#S_OK
        If IsClassObject(IUnknown,*obj)
          *this=*obj
          *this\AddRef()
        Else
          ReferenceObject(*obj)
        EndIf
        *self\obj=*obj
        LogClass(#LogClass_Info,"Embedded object "+GetObjectClassName(*obj)+"@"+Hex(*obj),*self)
        ProcedureReturn *self
      Else
        LogClass(#LogClass_Error,"ITypeInfo is not valid")
        FreeObject(*self)
        ProcedureReturn 0
      EndIf
    EndProcedure
    
    Procedure IDispatch___Destructor(*self._IDispatch)
      Protected *this.IUnknown
      If *self<>*self\obj 
        If IsClassObject(IUnknown,*self\obj)
          *this=*self\obj
          *this\Release()
        Else
          FreeObject(*self\obj)
        EndIf  
      EndIf
      *self\TypeInfo\Release()
      *self\obj=0
      *self\TypeInfo=0
      LogClass(#LogClass_Info,"Free",*self)
    EndProcedure
    
    Procedure IDispatch___CopyConstructor(*self._IDispatch,*org)
      Protected *this.IUnknown
      LogClass(#LogClass_Info,"Copy from "+Hex(*org),*self)
      If IsClassObject(IUnknown,*self\obj)
        *this=*self\obj
        *this\AddRef()
      Else
        ReferenceObject(*self\obj)
      EndIf
      *self\TypeInfo\AddRef()
      ProcedureReturn #True
    EndProcedure
    
    Method_QueryInterface(IDispatch,IUnknown,?IID_IDispatch)
   
    Procedure IDispatch_GetTypeInfoCount(*self._IDispatch,*out_long.long)
      If *out_long=0
        LogClass(#LogClass_Error,"No Pointer",*self)
        ProcedureReturn #E_POINTER
      EndIf
      
      *out_long\l=1
      LogClass(#LogClass_Info,"Return:"+*out_long\l,*self)
      
      ProcedureReturn #S_OK
    EndProcedure: AsMethod(IDispatch,GetTypeInfoCount)
    
    Procedure IDispatch_GetTypeInfo(*self._IDispatch,iTInfo.l,lcid.l,*out_ITypeInfo.integer)
      Protected count
      If *out_ITypeInfo=0
        LogClass(#LogClass_Error,"No Pointer",*self)
        ProcedureReturn #E_POINTER
      EndIf
      If iTInfo<>0
        LogClass(#LogClass_Error,"Bad Index "+iTInfo,*self)
        ProcedureReturn #DISP_E_BADINDEX
      EndIf
      
      *out_ITypeInfo\i=*self\TypeInfo
      count=*self\TypeInfo\AddRef()
      LogClass(#LogClass_Info,"TypeInfo Count:"+Str(count),*self)
      ProcedureReturn #NOERROR  
    EndProcedure: AsMethod(IDispatch,GetTypeInfo)
    
    Procedure IDispatch_Invoke(*self._IDispatch,dispIdMember.w,*riid,lcid.l,wFlags.w,*pDispParams.DISPPARAMS,*pVarResult.PBVariant,*pExcepInfo,*puArgErr)
      Protected result
      ;logclass(#logclass_info,""+dispIdMember+" "+*pDispParams\cArgs+" "+*pDispParams\cNamedArgs+" "+wFlags+" "+*pExcepInfo+" "+*puArgErr)
      LockObject(*self)
      ;result=DispInvoke_(*self\obj,*self\TypeInfo,dispIdMember,wFlags,*pDispParams,*pVarResult,*pExcepInfo,*puArgErr)
      result=*self\typeinfo\Invoke(*self\obj,dispIdMember,wFlags,*pDispParams,*pVarResult,*pExcepInfo,*puArgErr)
      UnlockObject(*self)
            
      CompilerIf #LogClass
        If result=-2147352560 ;$80020010
          logclass(#LogClass_Error,"Invalid callee - missing (*self)?",*self)
        EndIf
        Protected a$,res.s
        If *pVarResult And result=#S_OK
          Select *pVarResult\vt
            Case #VT_PBAscii:a$=StrU(*pVarResult\PB\Ascii)+"a"
            Case #VT_PBByte:a$=Str(*pVarResult\PB\Byte)+"b"
            Case #VT_PBDouble:a$=StrD(*pVarResult\PB\Double)+"d"
            Case #VT_PBFloat:a$=StrF(*pVarResult\PB\Float)+"f"
            Case #VT_PBInteger:a$=Str(*pVarResult\PB\Integer)+"i"
            Case #VT_PBLong:a$=Str(*pVarResult\PB\Long)+"l"
            Case #VT_PBQuad:a$=Str(*pVarResult\PB\Quad)+"q"
            Case #VT_PBString:
              If *pVarResult\pb\string
                a$=Chr(34)+PeekS(*pVarResult\PB\String,20)+Chr(34)
              Else
                a$="NULL$"
              EndIf        
            Case #VT_PBUnicode:a$=StrU(*pVarResult\PB\Unicode)+"u"
            Case #VT_PBWord:a$=Str(*pVarResult\PB\Word)+"w"
            Case #VT_DISPATCH:a$="IDispatch"
            Default
              a$="<unknown>"
          EndSelect
        Else
          a$="<none>"
        EndIf
        a$="Result:"+a$
        If wFlags&#DISPATCH_METHOD
          a$="METHOD "+a$
        ElseIf wFlags&#DISPATCH_PROPERTYGET
          a$="GET "+a$
        ElseIf wFlags&#DISPATCH_PROPERTYPUT
          a$="PUT "+a$
        EndIf
        Select result
          Case #S_OK:res="S_OK"
          Case #DISP_E_BADPARAMCOUNT:res="Bad parameter count"
          Case #DISP_E_BADVARTYPE:res="Bad Variant type in DISPPARAMS"
          Case #DISP_E_EXCEPTION:res="Application needs to raise an exception"
          Case #DISP_E_MEMBERNOTFOUND:res="Member not found"
          Case #DISP_E_NONAMEDARGS:res="Named arguments are not supported"
          Case #DISP_E_OVERFLOW:res="Overflow in DISPPARAMS"
          Case #DISP_E_PARAMNOTFOUND:res="Parameter ID not found"
          Case #DISP_E_TYPEMISMATCH:res="Parameter type mismatch"
          Case #DISP_E_PARAMNOTOPTIONAL:res="Missing Parameter"
          Default :res= "Unknown ("+result+")"
        EndSelect
        If result=#S_OK
          LogClass(#LogClass_Info,"ID:"+dispIdMember+" "+a$+" "+res,*self)
        Else
          LogClass(#LogClass_Error,"ID:"+dispIdMember+" "+a$+" "+res,*self)
        EndIf
      CompilerEndIf
      
      ProcedureReturn result
    EndProcedure:AsMethod(IDispatch,Invoke)
    
    Procedure IDispatch_GetIDsOfNames(*self._IDispatch,*riid,*rgszNames,cNames.l,lcid.l,*rgDispId)
      Protected result
      
      result=DispGetIDsOfNames_(*self\TypeInfo, *rgszNames, cNames,*rgDispId)
      
      CompilerIf #LogClass
        Protected a$
        If *rgszNames And PeekI(*rgszNames)
          a$="Name:"+PeekS(PeekI(*rgszNames))
        EndIf
        
        If *rgDispId 
          a$+" ID:"+PeekW(*rgDispId)
        EndIf
        
        If result=#S_OK 
          LogClass(#LogClass_Info,a$+" S_OK",*self)
        Else
          If result=#E_OUTOFMEMORY
            a$+" Out of memory"
          ElseIf result=#DISP_E_UNKNOWNNAME
            a$+" Unknown name"
          Else
            a$+" Unknown ("+result+")"
          EndIf
          LogClass(#LogClass_Error,a$,*self)
        EndIf
      CompilerEndIf
      
      ProcedureReturn result
    EndProcedure:AsMethod(IDispatch,GetIDsOfNames)
    
    DefineClass(IDispatch,IUnknown)
    
    ;}
    
    ;{ ExportCom::IClassFactory
    Method_QueryInterface(IClassFactory,IUnknown,?IID_IClassFactory)
    
    Procedure IClassFactory___Constructor(*self._IClassFactory,*vt)
      If *vt=0
        LogClass(#LogClass_Info,"Missing parameter",*self)
        ProcedureReturn #False
      EndIf
      
      *self\vt=*vt
      LogClass(#LogClass_info,"New ClassFactory for Class "+GetClassIDName(*vt),*self)
      ProcedureReturn #True
    EndProcedure
    
    Procedure IClassFactory___Destructor(*self._IClassFactory)
      LogClass(#LogClass_Info,"Free ClassFactory for Class "+GetClassIDName(*self\vt),*self)
    EndProcedure
    
    Procedure IClassFactory_LockServer(*self._IClassFactory,Bool.i)
      LockObject(*self)
      If bool=0
        If IClassFactory_LockCount>0
          IClassFactory_LockCount-1
        EndIf
      Else
        IClassFactory_LockCount+1
      EndIf
      UnlockObject(*self)
      
      LogClass(#LogClass_Info,"Count:"+ IClassFactory_LockCount+" (Class "+GetClassIDName(*self\vt)+")",*self)
      ProcedureReturn #S_OK
    EndProcedure:AsMethod(IClassFactory,LockServer)
    
    Procedure IClassFactory_CreateInstance(*self._IClassFactory,*pUnkOuter,*riid,*out_Object.Integer)
      Protected *obj
      Protected *nVT.__Class_nVT=*self\VT-SizeOf(__Class_nVT)
      
      If *out_Object=0
        LogClass(#LogClass_Error,"No Pointer",*self)
        ProcedureReturn #E_POINTER
      EndIf
      
      *out_Object\i=#Null
      
      If *pUnkOuter
        LogClass(#LogClass_Error,"Aggregation is not supported",*self)
        ProcedureReturn #CLASS_E_NOAGGREGATION
      EndIf
      
      If CompareMemory(*riid, ?IID_IUnknown, SizeOf(iid)) Or CompareMemory(*riid, ?IID_IDispatch, SizeOf(iid))
        
        *obj=CallFunctionFast(*nVT\new)
        If *obj
          *out_Object\i=new_IDispatch(*obj)
          FreeObject(*obj)
          If *out_Object\i
            LogClass(#LogClass_Info,"New IDispatch "+GetClassIdName(*self\vt)+"@"+Hex(*out_Object\i),*self)
            ProcedureReturn #S_OK
          EndIf
        EndIf
        
        LogClass(#LogClass_Error,"Out of Memory",*self)
        ProcedureReturn #E_OUTOFMEMORY
      EndIf
      
      LogClass(#LogClass_Error,"Class not available ("+GetClassIdName(*self\vt)+")",*self)
      ProcedureReturn #CLASS_E_CLASSNOTAVAILABLE
    EndProcedure:AsMethod(IClassFactory,CreateInstance)
    
    DefineClass(IClassFactory,IUnknown,(*VT))
    ;}
  EndModule
  UseModule ExportCom
EndMacro

;{ Warper for IncludeFile
CompilerIf #PB_Compiler_IsMainFile=#False
  InitExportCom(#True)
  UndefineMacro InitExportCom
CompilerEndIf
;}

Class_Export.com.pb

Code: Select all

CompilerIf #True
OpenConsole()
  a=RunProgram(#PB_Compiler_Home+"Compilers\pbcompiler.exe",Chr(34)+#PB_Compiler_File+"i"+Chr(34)+" /IGNORERESIDENT "+Chr(34)+#PB_Compiler_Filename+".res"+Chr(34)+" /RESIDENT "+Chr(34)+#PB_Compiler_Home+"Residents\"+#PB_Compiler_Filename+".res"+Chr(34),#PB_Compiler_Home,#PB_Program_Open|#PB_Program_Wait)
  If ProgramExitCode(a)
    Input()
  EndIf
  CloseProgram(a)
  CloseConsole()
  End
CompilerEndIf

Warning: This instant create the res-file in the compiler-directory