PureBoard

Das deutsche PureBasic-Forum
https://www.purebasic.fr/german/

ExportCom (iDispatch/iFactory/DLL) mit RES-Files

https://www.purebasic.fr/german/viewtopic.php?t=30144

Seite 1 von 1

ExportCom (iDispatch/iFactory/DLL) mit RES-Files

Verfasst: 08.05.2017 18:57
von GPI
Basierend auf meiner Klassendefinition http://www.purebasic.fr/german/viewtopi ... =8&t=30133 hab ich meine Variante zum erstellen von COM-Objekten/DLL gefunden. Mein Dank hier gilt mk-soft. Ohne seine Lösung wäre das hier nicht möglich.

Die ClassExportCom.pbi in zweiten Post sind wieder per XIncludeFile oder per RES-File (siehe Class-Thread, der oben verlinkt ist) nutzbar und ist so ohne weiteres zutun überall nutzbar.

InitExportCom([CreateLogFile])
Sollte ganz zu Anfang aufgerufen werden, damit werden die nötigen Routinen eingebaut und das Modul ExportCom erstellt. Ein UseModule ExportCom wird automatisch ausgeführt. In jeden Modul, das irgendeine der Funktionen von ExportCom nutzt, sollte es manuell eingefügt werden.

Als nächstes kann man ganz normal die Objekte erstellen. Sie müssen nicht irgendeine SuperClass(Parent) besitzen oder bestimmte Aufrufe enthalten. Die Klassen können auch problemlos in Modulen etc. erstellt werden.

Hier gibt es allerdings zwei PseudoTypen als "RückgabeTyp"
_P_BStr
Wenn man einen String zurückgeben will, muss man als Rückgabetyp eben _P_BStr benutzen. Das ist ein simpel-Macro auf "i". Es wird aber beim Export wichtig. Um einen String zurückzugeben, muss man ProcedureReturn ReturnString(str.s) verwenden.
_P_Dispatch
Wird benötig, wenn man ein Dispatch-Object zurückgeben will. Das ist die einzige Möglichkeit, das ein Objekt ein Objekt zurück gibt.

Wenn man eine Property exportieren will, muss man dafür Methoden benutzen. Es muss also in Interface/EndInterfacebereich ein
PROPERTYGET_<property>.<property-type>()
PROPERTYPUT_<property>(Value..<property-type>)
Es müssen nicht beide rein, wenn man nur Lesen will, reicht PROPERTYGET.
Vor DefineClass() muss man dann nur ein
Dispatch_PropertyGet(<class>,<property>)
Dispatch_PropertyPut(<class>,<property>)
einfügen, dann werden automatisch die passenden Methoden erstellt.

WICHTIG! Es gelten die Einschränkungen von DLL. D.h. bspw. keine Programmcode außerhalb von Proceduren und kein DIM/Lists/Maps außerhalb von Proceduren erstellen! Auch ein zuweisen von globalen Variablen kann problematisch sein.

Da AttachProcess() und DetachProcess() nicht mehr frei Verfügbar sind, muss man auf InitDLL() und ExitDLL() ausweichen. Sie werden als allererstes/letztes aufgerufen.

LogClass(type.s,text.s[,*obj])
Erstellt einen Eintrag in der Logdatei. Wenn keine erstellt werden soll, wird der Aufruf automatisch entfernt - ähnlich wie bei Debug.
Für Type empfehle ich die Konstanten #LogClass_Error, #LogClass_Info und #LogClass_Warning, kann aber auch Prinzipiell jeder String sein. Wenn *obj angegeben wird, dann werden noch ein paar Infos zum Objekt eingetragen.
Mit der Konstante #LogClass kann man Code nur einbinden, wenn auch tatsächlich ein Logfile erstellt wird.

Code: Alles auswählen

CompilerIf #LogClass :dosomething: CompilerEndif
In der InitDLL() kann man auch die Globale Variable LogClass_FileName ändern und so die Logdateinamen ändern. Standard ist der "DLL-Pfad+Name.log".

Wenn das alles erledigt ist, müssen wir definieren, was Exportiert werden soll.

ExportCom()
Leitet den Export ein. es sollte jetzt bis EndExportCom() nur noch ExportClass() benutzt werden!

ExportClass(<class>, ProgramId.s, CLSID.s, Description.s, InterfaceString.s)
ProgramId
ist Quasi der Name des COM-Objekts. Darüber werden sie auch gefunden.
Laut Microsoft soll sie folgendes Format haben:
<Program>.<Component>.<Version>
Unterstriche sind nicht erlaubt und darf auch nicht mit einer Ziffer beginnen.

CLSID
muss eine eindeutige ID sein, die fest steht. Sie wird ohne geschweifte Klammern übergeben!
Folgendes Mini-Programm erstellt eine ID

Code: Alles auswählen

InitExportCom()
my.guid
Define a$
CoCreateGuid_(@my)
a$=GetStringFromGuid(my)
Debug a$
Description
Eine Beschreibung, die beim Registieren der DLL gespeichert wird

InterfaceString
Das ist im Prinzip der Bereich zwischen Interface und EndInterface. Diese Methoden werden samt Parameternamen übernommen!
Properties werden richtig umgesetzt, wenn sie wie oben definiert wurden. Sollte ein Methodename "METHOD_<name>" lauten, wird das "METHOD_" abgeschnitten. Damit kann man doppelte Methoden definieren, so das man für interne Routinen eine andere Methode nutzt als die exportierte. Praktisch bspw. für Methoden, die Strings zurückgeben. Will man bestimmte Methoden nicht exportieren, kann man sie hier einfach rauslöschen. Der InterfaceString muss nicht alle Elemente des Interfaces enthalten.

Sollte in einer Methode ein Objekt zurückgegeben werden, dann muss die Klasse des Objekts zwingend exportiert werden! Wenn diese Klasse nicht Public sein soll, dann einfach ProgramId, CLSID und Description leer lassen.

EndExportCom()
damit wird der Export beendet. Nach dieser Zeile sollte kein Programmcode mehr kommen!

Nebenbei gibts noch ein paar Hilfsfunktionen/Klassen:
IUnknown
Klasse, füllt eigentlich nur das Interface mit leben :)

New_IDispatch(Obj) und IDIspatch
Klasse. Das Klasse des eingebundenen Objects muss exportiert werden!

IClassFactory(*vt)
Erstellt eine classFactory. Wird Intern benutzt.

GetStringFromGuid(*guid.guid)
Wandelt ein GUID oder IID oder CLSID (eigentlich alles das selbe) in einen String um und gibt ihn zurück.

GetGuidFromString(guid$,*out.guid)
Und zurück.

Wichtig: Der String wird nicht mit geschweiften Klammern umschlossen.

Ein Beispiel macht alles hoffentlich etwas klarer:

Code: Alles auswählen

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()
Muss natürlich eine DLL erstellen

meine 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
und meine test.bat (die man mit Adminrechten zwecks Registierung aufrufen muss; Pfade muss man anpassen)

Code: Alles auswählen

: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: Alles auswählen

: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

Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files

Verfasst: 08.05.2017 18:58
von GPI
so hier die ClassExportCom.pbi

Code: Alles auswählen

;    Description: ExportCOM-Definition (Work as IncludeFile and as RES-File)
;         Author: GPI
;           Date: 2017-05-14
;     PB-Version: 5.60
;             OS: Windows
;  English-Forum: 
;   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
;}
Und die Class_Export.com.pb

Code: Alles auswählen

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
achtung, Das Ding erzeugt gleich die RES-Datei in Compiler-Verzeichnis!

Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files

Verfasst: 10.05.2017 17:15
von GPI
Kennt ihr das, wenn ihr eine Code schreibt, testen, vollständig zufrieden seid und veröffentlicht und später merkt,dass da ein Fehler drin ist? Und es dann natürlich noch in 64 Bit funktioniert, in 32Bit es Fehlermeldungen wirft, die es gar nicht geben dürfte?

Das hatte ich gestern - mehrere Stunden hab ich gesucht, bis ich den saublöden Fehler in Beispiel-Code gefunden hab, ich hab ein einfaches (*self) vergessen. Naja wenigstens erscheint jetzt in Log eine Fehlermeldung, die auf das Problem hinweist.

Achja, und das Beispiel läuft jetzt wirklich auch ohne das man die RES-Datei erstellen muss.

Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files

Verfasst: 10.05.2017 18:03
von mk-soft
Das kenne ich...

DLL geht mit Windows 7 Pro (VM) und Crash auf Windows 7 Pro (PC)
Die Fehlersuche habe ich Dir ja abgenommen. Globale Variable anlegen mit Wertzuweisung aus einer Funktion geht nicht. Innerhalt einer Procedure kein problem.

Kleiner Tipp!
Du brauchst nicht die Procedure InitDLL() in AttachProcess() verlagern. Kann man auch sie direkt aufrufen. Der Compiler packt alle aufgerufende Proceduren in die interne Procedure PB_DllInit.
In der wird auch am ende die Procedure AttachProcess(hInstance) aufgerufen. Siehe ASM-Output. :)

Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files

Verfasst: 10.05.2017 19:09
von GPI
mk-soft hat geschrieben:Kleiner Tipp!
Du brauchst nicht die Procedure InitDLL() in AttachProcess() verlagern. Kann man auch sie direkt aufrufen. Der Compiler packt alle aufgerufende Proceduren in die interne Procedure PB_DllInit.
In der wird auch am ende die Procedure AttachProcess(hInstance) aufgerufen. Siehe ASM-Output. :)
Ich hab mich hier einfach an die Anleitung gehalten:
https://www.purebasic.com/documentation ... e/dll.html
- Don't write program code outside procedures. The only exception is the declaration of variables or structures.
Aber interessant. Ist aber damit leider ein undokumentiertes Feature und sowas wollte ich vermeiden (wie bspw. die Macro in Macro Erstellung)

Was würde ich für ein ExamineRuntime() geben. Oder ein Runtime für Strukturen/Interface. Es würde soviel einfacher machen :) Anderseits find ich das Rausfinden bei sowas immer recht lustig.

Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files

Verfasst: 10.05.2017 19:43
von mk-soft
GPI hat geschrieben:Was würde ich für ein ExamineRuntime() geben. Oder ein Runtime für Strukturen/Interface. Es würde soviel einfacher machen :) Anderseits find ich das Rausfinden bei sowas immer recht lustig.
Features request :wink:
- Don't write program code outside procedures. The only exception is the declaration of variables or structures.
Mit "Module ... Procedure Init() ... EndProcedure : Init() ... EndModule" hält man die Regel ein.
Müsste aber noch eine Diskussion mit Fred geführt werden. Gerade bei der Verwendung von Modulen in DLL´s.

P.S.
Notes about creating DLL's:
- The declaration of arrays, lists or map with Dim, NewList or NewMap must always be done inside the procedure AttachProcess.
- Don't write program code outside procedures. The only exception is the declaration of variables or structures.
- DirectX initialization routines must not be written in the AttachProcess procedure.
Punkt 1 kann bei Verwendung in Modulen nicht eingehalten werden!!!?
Bei mir habe ich die Map in einer Struktur ausgelagert...

Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files

Verfasst: 10.05.2017 20:18
von GPI
Ich glaube damit sind Globale Sachen gemeint. Der Text ist wohl so alt, da waren DIM/MAPS/LISTS immer global. Die Warnung gilt wohl deswegen, weil diese Schlüsselwörter automatisch Programcode erzeugen.

Wäre auch das nächste, ich hätte gerne, das man Shared auch für Module nutzen kann und auf die "Rootebene" zugreifen kann :)

oder ein Left/Right/Mid mit negativer Längenangabe. Würde das Len()-x ersparen.

Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files

Verfasst: 14.05.2017 19:28
von GPI
Kleines updates.
Ein Dispatch-Object muss jetzt mit New_IDispatch(*obj) erstellt werden.
Alle Zeiten sind UTC+02:00
Seite 1 von 1

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de