Aktuelle Zeit: 27.01.2020 01:32

Alle Zeiten sind UTC + 1 Stunde [ Sommerzeit ]




Ein neues Thema erstellen Auf das Thema antworten  [ 8 Beiträge ] 
Autor Nachricht
 Betreff des Beitrags: ExportCom (iDispatch/iFactory/DLL) mit RES-Files
BeitragVerfasst: 08.05.2017 18:57 
Offline

Registriert: 29.08.2004 13:18
Basierend auf meiner Klassendefinition viewtopic.php?f=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:
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:
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:
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
Zitat:
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:
: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:
: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

_________________
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!


Zuletzt geändert von GPI am 14.05.2017 18:55, insgesamt 2-mal geändert.

Nach oben
 Profil  
Mit Zitat antworten  
 Betreff des Beitrags: Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files
BeitragVerfasst: 08.05.2017 18:58 
Offline

Registriert: 29.08.2004 13:18
so hier die ClassExportCom.pbi
Code:
;    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:
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!

_________________
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!


Zuletzt geändert von GPI am 14.05.2017 18:48, insgesamt 1-mal geändert.

Nach oben
 Profil  
Mit Zitat antworten  
 Betreff des Beitrags: Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files
BeitragVerfasst: 10.05.2017 17:15 
Offline

Registriert: 29.08.2004 13:18
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.

_________________
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!


Nach oben
 Profil  
Mit Zitat antworten  
 Betreff des Beitrags: Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files
BeitragVerfasst: 10.05.2017 18:03 
Offline
Benutzeravatar

Registriert: 24.11.2004 13:12
Wohnort: Germany
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. :)

_________________
Alles ist möglich, fragt sich nur wie...
Projekte ThreadToGUI / EventDesigner V3 / OOP-BaseClass-Modul / OPC-Helper DLL
PB v3.30 / v5.4x - OS Mac Mini OSX 10.xx / Window 10 Pro. (X64) /Window 7 Pro. (X64) / Window XP Pro. (X86) / Ubuntu 14.04
Downloads auf My Webspace


Nach oben
 Profil  
Mit Zitat antworten  
 Betreff des Beitrags: Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files
BeitragVerfasst: 10.05.2017 19:09 
Offline

Registriert: 29.08.2004 13:18
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
Zitat:
- 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.

_________________
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!


Nach oben
 Profil  
Mit Zitat antworten  
 Betreff des Beitrags: Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files
BeitragVerfasst: 10.05.2017 19:43 
Offline
Benutzeravatar

Registriert: 24.11.2004 13:12
Wohnort: Germany
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:

Zitat:
- 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.
Zitat:
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...

_________________
Alles ist möglich, fragt sich nur wie...
Projekte ThreadToGUI / EventDesigner V3 / OOP-BaseClass-Modul / OPC-Helper DLL
PB v3.30 / v5.4x - OS Mac Mini OSX 10.xx / Window 10 Pro. (X64) /Window 7 Pro. (X64) / Window XP Pro. (X86) / Ubuntu 14.04
Downloads auf My Webspace


Nach oben
 Profil  
Mit Zitat antworten  
 Betreff des Beitrags: Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files
BeitragVerfasst: 10.05.2017 20:18 
Offline

Registriert: 29.08.2004 13:18
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.

_________________
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!


Nach oben
 Profil  
Mit Zitat antworten  
 Betreff des Beitrags: Re: ExportCom (iDispatch/iFactory/DLL) mit RES-Files
BeitragVerfasst: 14.05.2017 19:28 
Offline

Registriert: 29.08.2004 13:18
Kleines updates.
Ein Dispatch-Object muss jetzt mit New_IDispatch(*obj) erstellt werden.

_________________
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!


Nach oben
 Profil  
Mit Zitat antworten  
Beiträge der letzten Zeit anzeigen:  Sortiere nach  
Ein neues Thema erstellen Auf das Thema antworten  [ 8 Beiträge ] 

Alle Zeiten sind UTC + 1 Stunde [ Sommerzeit ]


Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 2 Gäste


Sie dürfen keine neuen Themen in diesem Forum erstellen.
Sie dürfen keine Antworten zu Themen in diesem Forum erstellen.
Sie dürfen Ihre Beiträge in diesem Forum nicht ändern.
Sie dürfen Ihre Beiträge in diesem Forum nicht löschen.

Suche nach:
Gehe zu:  
cron

 


Powered by phpBB © 2008 phpBB Group | Deutsche Übersetzung durch phpBB.de
subSilver+ theme by Canver Software, sponsor Sanal Modifiye