Module BaseClass ClassDispatch inclusive ClassFactory

Share your advanced PureBasic knowledge/code with the community.
User avatar
mk-soft
Always Here
Always Here
Posts: 5313
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Module BaseClass ClassDispatch inclusive ClassFactory

Post by mk-soft »

This is the first version for create com-dll´s and can testing with 'VBScript'.
With 32bit DLL on 64bit OS you need 'c:\window\SysWow64\wscript.exe'.

There are three ways to create the methods:

1. Method
The method has the same arguments as the Dispatch Invoke.

2. Method
It creates its own method 'DispInvoke' with the arguments of Dispatch Invoke.
To do this, you create a procedure with the prefix 'Disp' for the method.
The method is called from this.

3. Method
A method is created with additional type information about the arguments. Methods with up to eight arguments can be defined.

For this, give the following keys for the types.
- Bool, Integer, Long, Quad, Float, Double, String, Date, Variant

In addition, there are the following types for the return value of the method
- Void, Object


Define Properties:
There is the possibility to define the properties for direct access.

For this, there are the following macros.
- UseProperty(sProperty), DefineProperty(Name), DefinePropertyDate(Name),
- DefinePropertyVariant(Name), DefinePropertyVariantByRef(Name)
And with own property name
- DefinePropertyAs(Name, sProperty) and DefinePropertyDateAs(Name, sProperty)
- DefinePropertyVariantAs(Name, sProperty, DefinePropertyVariantByRefAs(Name, sProperty)


Developer's diagnosis:
To test the COM DLL, there is the possibility to create logfiles.
For this, there are the macros 'ClassDebug' and 'ClassDebugEx'
To remove all debugging functions, the constant '#EnableClassDebug' is set to false.


For the COM DLL you need a separate CLSID.
This can be created with the following code.

Code: Select all

Procedure.s CreateCLSID()
  Protected Uuid.iid, result.s, i
  UuidCreate_(Uuid.iid)
  result = "DataSection" + #CRLF$
  result + "  CLSID_App:" + #CRLF$
  result + "  Data.l $" + RSet(Hex(Uuid\Data1), 8, "0") + #CRLF$
  result + "  Data.w $" + RSet(Hex(Uuid\Data2), 4, "0")
  result + ", $" + RSet(Hex(Uuid\Data3), 4, "0") + #CRLF$
  result + "  Data.b $" + RSet(Hex(Uuid\Data4[0]), 2, "0")
  For i = 1 To 7
    result + ", $" + RSet(Hex(Uuid\Data4[i]), 2, "0")
  Next
  result + #CRLF$
  result + "EndDataSection" + #CRLF$
  Debug result
EndProcedure :CreateCLSID()
How to Register DLL:
Registry DLL
For Registry DLL as 32bit DLL
%systemroot%\SysWow64\regsvr32.exe "FolderToDLL\YourDLL.dll"
As 64Bit DLL
%systemroot%\System32\regsvr32.exe "FolderToDLL\YourDLL.dll"

For Unregistry DLL as 32bit DLL
%systemroot%\SysWow64\regsvr32.exe -u "FolderToDLL\YourDLL.dll"
As 64Bit DLL
%systemroot%\System32\regsvr32.exe - u "FolderToDLL\YourDLL.dll"
To the overview I have created a new example :wink:
Last edited by mk-soft on Sat May 20, 2017 4:14 pm, edited 49 times in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5313
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by mk-soft »

Update v1.29
- Optimize result of object

Modul_BaseClassDispatch.pb

Code: Select all

;-TOP

; Comment : Module as Object Class Dispatch inclusive Class Factory
; Author  : mk-soft
; Version : v1.29
; Created : 04.03.2017
; Updated : 05.06.2017
; Link GE : http://www.purebasic.fr/german/viewtopic.php?f=8&t=30103
; Link EN : http://www.purebasic.fr/english/viewtopic.php?f=12&t=68101

; ***************************************************************************************

;- Begin Declare Module ClassCommon

DeclareModule ClassCommon
  
  #EnableClassDebug = #True ; Set to False for remove all class debug functions
  
  ; ---------------------------------------------------------------------------
  
  Structure udtObjectCounter
    Count.i
    Mutex.i
  EndStructure
  
  Global __ObjectCounter.udtObjectCounter
  
  Macro GlobalObjectCounter(fLock)
    LockMutex(ClassCommon::__ObjectCounter\Mutex)
    If fLock
      ClassCommon::__ObjectCounter\Count + 1
    Else
      If ClassCommon::__ObjectCounter\Count > 0
        ClassCommon::__ObjectCounter\Count - 1
      EndIf
    EndIf
    UnlockMutex(ClassCommon::__ObjectCounter\Mutex)
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  Structure udtArrayVariant
    Arg.Variant[0]
  EndStructure
  
  ; ---------------------------------------------------------------------------
  
  ;-- Public Debug Functions
  
  Global __IsClassDebug
  
  Declare ClassDebugLogging(Modul.s, Function.s, Info.s, *Object)
  Declare EnableClassDebug(Enable = #True)
  
  Macro ClassDebug(Info, Object=0)
    CompilerIf #EnableClassDebug
      ClassDebugLogging(#PB_Compiler_Module, #PB_Compiler_Procedure, Info, Object)
    CompilerEndIf
  EndMacro
  
  Macro ClassDebugEx(Modul, Function, Info, Object=0)
    CompilerIf #EnableClassDebug
      ClassDebugLogging(Modul, Function, Info, Object)
    CompilerEndIf
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ;-- Public Help Functions
  Declare.s GetGuidString(*Guid.GUID)
  
  Declare.i GetVariantBool(*vArg.Variant)
  Declare.i GetVariantInteger(*vArg.Variant)
  Declare.i GetVariantLong(*vArg.Variant)
  Declare.q GetVariantQuad(*vArg.Variant)
  Declare.f GetVariantFloat(*vArg.Variant)
  Declare.d GetVariantDouble(*vArg.Variant)
  Declare.s GetVariantString(*vArg.Variant)
  Declare.i GetVariantDate(*vArg.Variant)
  Declare.i GetVariantVariant(*vArg.Variant)
  
  Declare SetVariantBool(*vArg.Variant, Value.i)
  Declare SetVariantInteger(*vArg.Variant, Value.i)
  Declare SetVariantLong(*vArg.Variant, Value.i)
  Declare SetVariantQuad(*vArg.Variant, Value.q)
  Declare SetVariantFloat(*vArg.Variant, Value.f)
  Declare SetVariantDouble(*vArg.Variant, Value.d)
  Declare SetVariantString(*vArg.Variant, Value.s)
  Declare SetVariantDate(*vArg.Variant, Date.i)
  Declare SetVariantVariant(*vArg.Variant, *Value.Variant)
  Declare SetVariantObject(*vArg.Variant, *Object)
  
  ; ---------------------------------------------------------------------------
  
  DataSection
    IID_INull: ; {00000000-0000-0000-0000-000000000000}
    Data.l $00000000
    Data.w $0000,$0000
    Data.b $00,$00,$00,$00,$00,$00,$00,$00
    
    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_IDispatchEx: ; {A6EF9860-C720-11D0-9337-00A0C90DCAA9}
    Data.l $A6EF9860
    Data.w $C720, $11D0
    Data.b $93, $37, $00, $A0, $C9, $0D, $CA, $A9
    
    IID_IClassFactory: ; {00000001-0000-0000-C000-000000000046}
    Data.l $00000001
    Data.w $0000,$0000
    Data.b $C0,$00,$00,$00,$00,$00,$00,$46
    
    IID_IClassFactoryEx: ; {342D1EA0-AE25-11D1-89C5-006008C3FBFC}
    Data.l $342D1EA0
    Data.w $AE25,$11D1
    Data.b $89,$C5,$00,$60,$08,$C3,$FB,$FC
  EndDataSection
  
  ; ---------------------------------------------------------------------------
  
EndDeclareModule

; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;- Begin Module ClassCommon

Module ClassCommon
  
  EnableExplicit
  
  ; ---------------------------------------------------------------------------
  
  Procedure InitClassCommon()
    __ObjectCounter\Mutex = CreateMutex()
  EndProcedure : InitClassCommon()
  
  ; ---------------------------------------------------------------------------
  
  Procedure ClassDebugLogging(Modul.s, Function.s, Info.s, *Object)
    CompilerIf #EnableClassDebug
      Static file.s, mutex.i
      Protected id, Object.s
      If __IsClassDebug
        If Not Bool(file)
          mutex = CreateMutex()
          LockMutex(mutex)
          file = ProgramFilename()
          file = ReplaceString(file, ".dll", ".log", #PB_String_NoCase)
          file = ReplaceString(file, ".exe", ".log", #PB_String_NoCase)
          id = OpenFile(#PB_Any, file, #PB_File_Append)
          If id
            If *object
              Object = " [" + Hex(*Object) + "]"
            EndIf
            WriteStringN(id, "Start Logging: " + FormatDate("%yyyy-%mm-%dd %hh:%ii:%ss", Date()), #PB_Ascii)
            WriteStringN(id, "[" + Modul + "." + Function + "] " + Info + Object, #PB_Ascii)
            CloseFile(id)
          EndIf
          UnlockMutex(mutex)
        Else
          LockMutex(mutex)
          id = OpenFile(#PB_Any, file, #PB_File_Append)
          If id
            If *object
              Object = " [" + Hex(*Object) + "]"
            EndIf
            WriteStringN(id, "[" + Modul + "." + Function + "] " + Info + Object, #PB_Ascii)
            CloseFile(id)
          EndIf
          UnlockMutex(mutex)
        EndIf
      EndIf
    CompilerEndIf
  EndProcedure
  
  Procedure EnableClassDebug(Enable = #True)
    __IsClassDebug = Enable
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetGuidString(*Guid.GUID)
    Protected msg.s
    msg = "{"
    msg + RSet (Hex(*Guid\Data1   , #PB_Long), 8, "0") + "-"
    msg + RSet (Hex(*Guid\Data2   , #PB_Word), 4, "0") + "-"
    msg + RSet (Hex(*Guid\Data3   , #PB_Word), 4, "0") + "-"
    msg + RSet (Hex(*Guid\Data4[0], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[1], #PB_Byte), 2, "0") + "-"
    msg + RSet (Hex(*Guid\Data4[2], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[3], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[4], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[5], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[6], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[7], #PB_Byte), 2, "0")
    msg + "}"
    ProcedureReturn msg
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  ;-- Help functions get variant value
  Procedure.i GetVariantBool(*vArg.Variant)
    Protected r1, vArg.Variant
    r1 = #False
    If VariantChangeType_(vArg, *vArg, 0, #VT_BOOL) = #S_OK
      If vArg\bool
        r1 = #True
      EndIf
    EndIf
    VariantClear_(vArg)
    ProcedureReturn r1
  EndProcedure
  
  Procedure.i GetVariantInteger(*vArg.Variant)
    Protected r1.i, vArg.Variant
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
      If *vArg\vt = #VT_I4
        ProcedureReturn *vArg\lVal
      EndIf
    CompilerElse
      If *vArg\vt = #VT_I8
        ProcedureReturn *vArg\llVal
      EndIf
    CompilerEndIf
    r1 = 0
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
      If VariantChangeType_(vArg, *vArg, 0, #VT_I4) = #S_OK
        r1 = vArg\lVal
      EndIf
    CompilerElse
      If VariantChangeType_(vArg, *vArg, 0, #VT_I8) = #S_OK
        r1 = vArg\llVal
      EndIf
    CompilerEndIf
    VariantClear_(vArg)
    ProcedureReturn r1
  EndProcedure
  
  Procedure.i GetVariantLong(*vArg.Variant)
    Protected r1.i, vArg.Variant
    If *vArg\vt = #VT_I4
      ProcedureReturn *vArg\lVal
    EndIf
    r1 = 0
    If VariantChangeType_(vArg, *vArg, 0, #VT_I4) = #S_OK
      r1 = vArg\lVal
    EndIf
    VariantClear_(vArg)
    ProcedureReturn r1
  EndProcedure
  
  Procedure.q GetVariantQuad(*vArg.Variant)
    Protected r1.q, vArg.Variant
    If *vArg\vt = #VT_I8
      ProcedureReturn *vArg\llVal
    EndIf
    r1 = 0
    If VariantChangeType_(vArg, *vArg, 0, #VT_I8) = #S_OK
      r1 = vArg\llVal
    EndIf
    VariantClear_(vArg)
    ProcedureReturn r1
  EndProcedure
  
  Procedure.f GetVariantFloat(*vArg.Variant)
    Protected r1.f, vArg.Variant
    If *vArg\vt = #VT_R4
      ProcedureReturn *vArg\fltVal
    EndIf
    r1 = 0.0
    If VariantChangeType_(vArg, *vArg, 0, #VT_R4) = #S_OK
      r1 = vArg\fltVal
    EndIf
    VariantClear_(vArg)
    ProcedureReturn r1
  EndProcedure
  
  Procedure.d GetVariantDouble(*vArg.Variant)
    Protected r1.d, vArg.Variant
    If *vArg\vt = #VT_R8
      ProcedureReturn *vArg\dblVal
    EndIf
    r1 = 0.0
    If VariantChangeType_(vArg, *vArg, 0, #VT_R8) = #S_OK
      r1 = vArg\dblVal
    EndIf
    VariantClear_(vArg)
    ProcedureReturn r1
  EndProcedure
  
  Procedure.s GetVariantString(*vArg.Variant)
    Protected r1.s, vArg.Variant
    r1 = ""
    If *vArg\vt = #VT_BSTR
      r1 = PeekS(*vArg\bstrVal)
      ProcedureReturn r1
    EndIf
    If VariantChangeType_(vArg, *vArg, 0, #VT_BSTR) = #S_OK
      r1 = PeekS(vArg\bstrVal)
    EndIf
    VariantClear_(vArg)
    ProcedureReturn r1
  EndProcedure
  
  Procedure.i GetVariantDate(*vArg.Variant) ; Result PB_Date
    Protected r1.i, vArg.Variant
    r1 = 0
    If *vArg\vt = #VT_DATE
      r1 = (*vArg\date  - 25569.0) * 86400.0
      ProcedureReturn r1
    EndIf
    If VariantChangeType_(vArg, *vArg, 0, #VT_DATE) = #S_OK
      r1 = (vArg\date  - 25569.0) * 86400.0
    EndIf
    VariantClear_(vArg)
    ProcedureReturn r1
  EndProcedure
  
  Procedure.i GetVariantVariant(*vArg.Variant) ; Result pointer to varint (ByRef)
    ProcedureReturn *vArg
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  ;-- Help functions set variant value
  Procedure SetVariantBool(*vArg.Variant, Value.i)
    VariantClear_(*vArg)
    *vArg\vt = #VT_BOOL
    If Value
      *vArg\bool = #VARIANT_TRUE
    Else
      *vArg\bool = #VARIANT_FALSE
    EndIf
  EndProcedure
  
  Procedure SetVariantInteger(*vArg.Variant, Value.i)
    VariantClear_(*vArg)
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
      *vArg\vt = #VT_I4
      *vArg\lVal = Value
    CompilerElse
      *vArg\vt = #VT_I8
      *vArg\llVal = Value
    CompilerEndIf
  EndProcedure
  
  Procedure SetVariantLong(*vArg.Variant, Value.i)
    VariantClear_(*vArg)
    *vArg\vt = #VT_I4
    *vArg\lVal = Value
  EndProcedure
  
  Procedure SetVariantQuad(*vArg.Variant, Value.q)
    VariantClear_(*vArg)
    *vArg\vt = #VT_I8
    *vArg\llVal = Value
  EndProcedure
  
  Procedure SetVariantFloat(*vArg.Variant, Value.f)
    VariantClear_(*vArg)
    *vArg\vt = #VT_R4
    *vArg\fltVal = Value
  EndProcedure
  
  Procedure SetVariantDouble(*vArg.Variant, Value.d)
    VariantClear_(*vArg)
    *vArg\vt = #VT_R8
    *vArg\dblVal = Value
  EndProcedure
  
  Procedure SetVariantString(*vArg.Variant, Value.s)
    VariantClear_(*vArg)
    *vArg\vt = #VT_BSTR
    *vArg\bstrVal = SysAllocString_(Value)
  EndProcedure
  
  Procedure SetVariantDate(*vArg.Variant, Date.i)
    VariantClear_(*vArg)
    *vArg\vt = #VT_DATE
    *vArg\date = Date / 86400.0 + 25569.0
  EndProcedure
  
  Procedure SetVariantVariant(*vArg.Variant, *vValue.Variant)
    VariantClear_(*vArg)
    VariantCopy_(*vArg, *vValue)
  EndProcedure
  
  Procedure SetVariantObject(*vArg.Variant, *Object)
    VariantClear_(*vArg)
    If *Object
      *vArg\vt = #VT_DISPATCH
      *vArg\pdispVal = *Object
    Else
      *vArg\vt = #VT_ERROR
      *vArg\scode = #E_OUTOFMEMORY
    EndIf
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
EndModule

;- End Module ClassCommon

; ***************************************************************************************

;-Begin Declare Module ClassDispatch

DeclareModule ClassDispatch
  
  ; ---------------------------------------------------------------------------
  
  ; Internal Class Manager
  
  Prototype ProtoInvoke(*This)
  Prototype ProtoInvokeDispatch(*This, DispId.i, *iid.IID, lcid.i, Flags.i, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
  
  Structure udtInvoke
    *Invoke.ProtoInvoke
  EndStructure
  
  Structure udtMethode
    Index.i
  EndStructure
  
  Structure udtProperty
    Index.i
    Type.i
    Offset.i
  EndStructure
  
  Structure udtClass
    Array *vTable(6)
    Array *vDispInvoke(6)
    Map vMethodeID.udtMethode()
    Map vPropertyID.udtProperty()
    List Initalize.udtInvoke()
    List Dispose.udtInvoke()
    cDispInvoke.i
    Mutex.i
  EndStructure
  
  Structure udtClasses
    Map Entry.udtClass()
  EndStructure
  
  Global Class.udtClasses
  
  ; ---------------------------------------------------------------------------
  
  ; BaseClass declaration
  
  Structure sBaseSystem
    *vTable
    *Self.udtClass
    RefCounter.i
    Mutex.i
  EndStructure
  
  ;-- Public Structure
  Structure sClassDispatch
    System.sBaseSystem
  EndStructure
  
  ;-- Public Interface
  Interface iClassDispatch
    QueryInterface(*riid, *addr)
    AddRef()
    Release()
    GetTypeInfoCount(*CntTypeInfo.Integer)
    GetTypeInfo(TypeInfo.i, LocalId.i, *ppTypeInfo.Integer)
    GetIDsOfNames(*iid.IID, *Names, cntNames.i, lcid.i, *DispId)
    Invoke(DispId.i, *iid.IID, lcid.i, Flags.i, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
  EndInterface
  
  ; ---------------------------------------------------------------------------
  
  Macro dq
    "
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ;-- Macros to defined object
  
  ; Added New Class
  Declare AddClass(ClassName.s, ClassExtends.s, Size) ; Internal
  
  Macro NewClass(ClassInterface, ClassExtends=ClassDispatch)
    ; Interface helper
    Interface __Interface Extends ClassInterface
    EndInterface
    ; Add Class
    AddClass(#PB_Compiler_Module, dq#ClassExtends#dq, SizeOf(__Interface) / SizeOf(integer))
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ; Macro for init object (default)
  Macro InitObject(sProperty)
    Protected *Object.sProperty
    *Object = AllocateStructure(sProperty)
    If *Object
      GlobalObjectCounter(#True)
      *Object\System\vTable = Class\Entry(#PB_Compiler_Module)\vTable()
      *Object\System\Self = @Class\Entry(#PB_Compiler_Module)
      *Object\System\RefCounter = 0
      *Object\System\Mutex = CreateMutex()
      If Not *Object\System\Mutex
        Debug "Error: CreateMutex Class '" + #PB_Compiler_Module + "'!"
        FreeStructure(*Object)
        *Object = 0
        GlobalObjectCounter(#False)
      Else
        LockMutex(*Object\System\Self\Mutex)
        ForEach *Object\System\Self\Initalize()
          *Object\System\Self\Initalize()\Invoke(*Object)
        Next
        UnlockMutex(*Object\System\Self\Mutex)
      EndIf
    EndIf
    ProcedureReturn *Object
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ; Macros for init object (advanced)
  Macro AllocateObject(Object, sProperty)
    Object = AllocateStructure(sProperty)
    If Object
      GlobalObjectCounter(#True)
      Object\System\vTable = Class\Entry(#PB_Compiler_Module)\vTable()
      Object\System\Self = @Class\Entry(#PB_Compiler_Module)
      Object\System\RefCounter = 0
      Object\System\Mutex = CreateMutex()
      If Not Object\System\Mutex
        Debug "Error: CreateMutex Class '" + #PB_Compiler_Module + "'!"
        FreeStructure(Object)
        Object = 0
        GlobalObjectCounter(#False)
      EndIf
    EndIf
  EndMacro
  
  Macro InitalizeObject(Object, sProperty=)
    If Object
      LockMutex(Object\System\Self\Mutex)
      ForEach Object\System\Self\Initalize()
        Object\System\Self\Initalize()\Invoke(Object)
      Next
      UnlockMutex(Object\System\Self\Mutex)
    EndIf
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ; Macros for clone object
  Macro CloneObject(This, Clone, sProperty)
    Clone = AllocateStructure(sProperty)
    If Clone
      GlobalObjectCounter(#True)
      CopyStructure(This, Clone, sProperty)
      Clone\System\RefCounter = 0
      Clone\System\Mutex = CreateMutex()
      If Not Clone\System\Mutex
        Debug "Error: CreateMutex Class '" + #PB_Compiler_Module + "'!"
        FreeStructure(Clone)
        Clone = 0
        GlobalObjectCounter(#False)
      EndIf
    EndIf
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  Macro LockObject(This)
    LockMutex(This\System\Mutex)
  EndMacro
  
  Macro UnlockObject(This)
    UnlockMutex(This\System\Mutex)
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ;-- Macros to defined Initalize, Dispose, Methode
  
  ; Add Procedure as Initalize Object
  Macro AsInitalizeObject(Name)
    Procedure __AddInitalizeObject#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        LastElement(Class\Entry()\Initalize())
        AddElement(Class\Entry()\Initalize())
        Class\Entry()\Initalize()\Invoke = @Name()
      EndIf
    EndProcedure : __AddInitalizeObject#Name()
  EndMacro
  
  ; Add Procedure as Dispose Object
  Macro AsDisposeObject(Name)
    Procedure __AddDisposeObject#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        LastElement(Class\Entry()\Dispose())
        AddElement(Class\Entry()\Dispose())
        Class\Entry()\Dispose()\Invoke = @Name()
      EndIf
    EndProcedure : __AddDisposeObject#Name()
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ; Add Procedure as Methode Dispatch or Overwrite Inheritance Methode Dispatch
  Macro AsMethode(Name)
    Procedure __AddMethode#Name()
      Protected MethodeID
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        MethodeID = OffsetOf(__Interface\Name()) / SizeOf(integer)
        Class\Entry()\vTable(MethodeID) = @Name()
        Class\Entry()\vMethodeID(LCase(dq#Name#dq))\Index = MethodeID
        CompilerIf Defined(Disp#Name, #PB_Procedure)
          Class\Entry()\vDispInvoke(MethodeID) = @Disp#Name()
        CompilerElse
          Class\Entry()\vDispInvoke(MethodeID) = @Name()
        CompilerEndIf
      EndIf
    EndProcedure : __AddMethode#Name()
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ; Add Procedure as Methode or Overwrite Inheritance Methode with creating Disp[MethodeName]
  
  ; Added Purebasic unknown Datatype for DispInvoke and Properties
  #PB_None = 1000
  #PB_Void = 1001
  #PB_Object = 1002
  #PB_Bool = 1003
  #PB_Date = 1004
  #PB_Variant = 1005
  #PB_VariantByRef = 1006
  
  ; Help stucture for DispInvoke
  Structure udtDispResult
    StructureUnion
      Void.i
      *Object
      Bool.i
      Integer.i
      Long.l
      Quad.q
      Float.f
      Double.d
      Date.i
      *Variant
    EndStructureUnion
    String.s
  EndStructure
  
  Macro AsMethodeDisp(Name, tResult=Void, tArg1=None, tArg2=None, tArg3=None, tArg4=None, tArg5=None, tArg6=None, tArg7=None, tArg8=None)
    Procedure Disp#Name(*this.__Interface, DispId.l, *iid.IID, lcid.l, Flags.w, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
      Protected r1.udtDispResult, cArgs, *vArgs.udtArrayVariant
      CompilerIf #PB_#tArg8 <> #PB_None
        #ParamCount#Name = 8
      CompilerElseIf #PB_#tArg7 <> #PB_None
        #ParamCount#Name = 7
      CompilerElseIf #PB_#tArg6 <> #PB_None
        #ParamCount#Name = 6
      CompilerElseIf #PB_#tArg5 <> #PB_None
        #ParamCount#Name = 5
      CompilerElseIf #PB_#tArg4 <> #PB_None
        #ParamCount#Name = 4
      CompilerElseIf #PB_#tArg3 <> #PB_None
        #ParamCount#Name = 3
      CompilerElseIf #PB_#tArg2 <> #PB_None
        #ParamCount#Name = 2
      CompilerElseIf #PB_#tArg1 <> #PB_None
        #ParamCount#Name = 1
      CompilerElse
        #ParamCount#Name = 0
      CompilerEndIf
      ; Check parameter count
      cArgs = *DispParams\cArgs
      *vArgs = *DispParams\rgvarg
      If cArgs <> #ParamCount#Name
        ProcedureReturn #DISP_E_BADPARAMCOUNT
      EndIf
      ; Invoke methode
      CompilerSelect #ParamCount#Name
        CompilerCase 0
          r1\tResult = *this\Name()
        CompilerCase 1
          r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[0]))
        CompilerCase 2
          r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[1]),
                                  GetVariant#tArg2(*vArgs\Arg[0]))
        CompilerCase 3
          r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[2]),
                                  GetVariant#tArg2(*vArgs\Arg[1]),
                                  GetVariant#tArg3(*vArgs\Arg[0]))
        CompilerCase 4
          r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[3]),
                                  GetVariant#tArg2(*vArgs\Arg[2]),
                                  GetVariant#tArg3(*vArgs\Arg[1]),
                                  GetVariant#tArg4(*vArgs\Arg[0]))
        CompilerCase 5
          r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[4]),
                                  GetVariant#tArg2(*vArgs\Arg[3]),
                                  GetVariant#tArg3(*vArgs\Arg[2]),
                                  GetVariant#tArg4(*vArgs\Arg[1]),
                                  GetVariant#tArg5(*vArgs\Arg[0]))
        CompilerCase 6
          r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[5]),
                                  GetVariant#tArg2(*vArgs\Arg[4]),
                                  GetVariant#tArg3(*vArgs\Arg[3]),
                                  GetVariant#tArg4(*vArgs\Arg[2]),
                                  GetVariant#tArg5(*vArgs\Arg[1]),
                                  GetVariant#tArg6(*vArgs\Arg[0]))
        CompilerCase 7
          r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[6]),
                                  GetVariant#tArg2(*vArgs\Arg[5]),
                                  GetVariant#tArg3(*vArgs\Arg[4]),
                                  GetVariant#tArg4(*vArgs\Arg[3]),
                                  GetVariant#tArg5(*vArgs\Arg[2]),
                                  GetVariant#tArg6(*vArgs\Arg[1]),
                                  GetVariant#tArg7(*vArgs\Arg[0]))
        CompilerCase 8
          r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[7]),
                                  GetVariant#tArg2(*vArgs\Arg[6]),
                                  GetVariant#tArg3(*vArgs\Arg[5]),
                                  GetVariant#tArg4(*vArgs\Arg[4]),
                                  GetVariant#tArg5(*vArgs\Arg[3]),
                                  GetVariant#tArg6(*vArgs\Arg[2]),
                                  GetVariant#tArg7(*vArgs\Arg[1]),
                                  GetVariant#tArg8(*vArgs\Arg[0]))
          
      CompilerEndSelect
      ; Write result
      CompilerIf #PB_#tResult <> #PB_Void
        If *vResult
          SetVariant#tResult(*vResult, r1\tResult)
          If *vResult\vt <> #VT_ERROR
            ProcedureReturn #S_OK
          Else
            ProcedureReturn *vResult\scode
          EndIf
        Else
          ProcedureReturn #S_OK
        EndIf
      CompilerElse
        ProcedureReturn #S_OK
      CompilerEndIf
    EndProcedure : AsMethode(Name)
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ;-- Macros to defined Properties
  
  Macro NextPropertyID
    (1000 + MacroExpandedCount)
  EndMacro
  
  Macro UseProperty(sProperty)
    Structure __Property Extends sProperty
    EndStructure
  EndMacro
  
  Macro DefineProperty(Name)
    Procedure __AddProperty#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = TypeOf(__Property\Name)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(__Property\Name)
      EndIf
    EndProcedure : __AddProperty#Name()
  EndMacro
  
  Macro DefinePropertyDate(Name)
    Procedure __AddProperty#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_Date
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(__Property\Name)
      EndIf
    EndProcedure : __AddProperty#Name()
  EndMacro
  
  Macro DefinePropertyVariant(Name)
    Procedure __AddProperty#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_Variant
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(__Property\Name)
      EndIf
    EndProcedure : __AddProperty#Name()
  EndMacro
  
  Macro DefinePropertyVariantByRef(Name)
    Procedure __AddProperty#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_VariantByRef
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(__Property\Name)
      EndIf
    EndProcedure : __AddProperty#Name()
  EndMacro
  
  Macro DefinePropertyAs(Name, sProperty)
    Procedure __AddPropertyAs#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = TypeOf(sProperty)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(sProperty)
      EndIf
    EndProcedure : __AddPropertyAs#Name()
  EndMacro
    
  Macro DefinePropertyDateAs(Name, sProperty)
    Procedure __AddPropertyAs#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_Date
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(sProperty)
      EndIf
    EndProcedure : __AddPropertyAs#Name()
  EndMacro
  
  Macro DefinePropertyVariantAs(Name, sProperty)
    Procedure __AddPropertyAs#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_Variant
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(sProperty)
      EndIf
    EndProcedure : __AddPropertyAs#Name()
  EndMacro
  
  Macro DefinePropertyVariantByRefAs(Name, sProperty)
    Procedure __AddPropertyAs#Name()
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_VariantByRef
        Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(sProperty)
      EndIf
    EndProcedure : __AddPropertyAs#Name()
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ;-- Debugger Functions
  
  Macro ShowInterface(ClassName=#PB_Compiler_Module)
    CompilerIf #PB_Compiler_Debugger
      Define __index
      Debug "Interface " + ClassName
      Debug "{"
      If FindMapElement(ClassDispatch::Class\Entry(), ClassName)
        For __index = 0 To ArraySize(ClassDispatch::Class\Entry()\vTable()) - 1
          ForEach ClassDispatch::Class\Entry()\vMethodeID()
            If ClassDispatch::Class\Entry()\vMethodeID()\Index = __index
              Debug " - MethodeID " + ClassDispatch::Class\Entry()\vMethodeID()\Index + " - " + MapKey(ClassDispatch::Class\Entry()\vMethodeID()) + "()"
              Break
            EndIf
          Next
        Next
      Else
        Debug " - Interface not found."
      EndIf
      Debug "}"
    CompilerEndIf
  EndMacro
  
  Macro ShowClasses()
    CompilerIf #PB_Compiler_Debugger
      ForEach ClassDispatch::Class\Entry()
        Define __index
        Debug "Interface " + MapKey(ClassDispatch::Class\Entry())
        Debug "{"
        For __index = 0 To ArraySize(ClassDispatch::Class\Entry()\vTable()) - 1
          ForEach ClassDispatch::Class\Entry()\vMethodeID()
            If ClassDispatch::Class\Entry()\vMethodeID()\Index = __index
              Debug " - MethodeID " + ClassDispatch::Class\Entry()\vMethodeID()\Index + " - " + MapKey(ClassDispatch::Class\Entry()\vMethodeID()) + "()"
              Break
            EndIf
          Next
        Next
        Debug "}"
      Next
    CompilerEndIf
  EndMacro
  
  Macro CheckInterface(InterfaceName)
    CompilerIf #PB_Compiler_Debugger
      CompilerIf Defined(InterfaceName, #PB_Interface)
        Define __SizeOfInterface = SizeOf(InterfaceName) / SizeOf(Integer)
        Define __IndexOfInterface
        For __IndexOfInterface = 0 To __SizeOfInterface - 1
          If Class\Entry(#PB_Compiler_Module)\vTable(__IndexOfInterface) = 0
            Debug "Error: Invalid Interface " + dq#InterfaceName#dq + " by MethodeID " + __IndexOfInterface
            ShowInterface()
            CallDebugger
          EndIf
        Next
      CompilerElse
        Debug "Error: Interface not exists"
        CallDebugger
      CompilerEndIf
    CompilerEndIf
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
EndDeclareModule

; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;- Begin Module ClassDispatch

Module ClassDispatch
  
  EnableExplicit
  
  UseModule ClassCommon
  
  ; ---------------------------------------------------------------------------
  
  #DISPID_VALUE = 0
  #DISPID_UNKNOWN = -1
  #DISPID_PROPERTYPUT = -3
  #DISPID_NEWENUM = -4
  #DISPID_EVALUATE = -5
  #DISPID_CONSTRUCTOR = -6
  #DISPID_DESTRUCTOR = -7
  #DISPID_COLLECT = -8
  
  Structure udtArrayString
    Name.string[0]
  EndStructure
  
  Structure udtArrayLong
    lVal.l[0]
  EndStructure
  
  ; ---------------------------------------------------------------------------
  
  Procedure AddClass(ClassName.s, ClassExtends.s, Size)
    Protected r1
    If FindMapElement(Class\Entry(), ClassExtends)
      r1 = AddMapElement(Class\Entry(), ClassName)
    Else
      Debug "Error: Extends Class '" + ClassExtends + "' not exists!"
      CallDebugger
    EndIf
    If r1
      CopyStructure(Class\Entry(ClassExtends), Class\Entry(ClassName), udtClass)
      ReDim Class\Entry(ClassName)\vTable(Size)
      ReDim Class\Entry(ClassName)\vDispInvoke(Size)
      Class\Entry(ClassName)\cDispInvoke = Size
      Class\Entry(ClassName)\Mutex = CreateMutex()
    Else
      Debug "Warning: Class '" + ClassName + "' not initalized!"
    EndIf
    ProcedureReturn r1
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure QueryInterface(*This.sClassDispatch, *riid, *Object.integer)
    If CompareMemory(*riid, ?IID_IDispatch, 16)
      ClassDebug("Interface IDispatch ok", *This)
      LockMutex(*This\System\Mutex)
      *Object\i = *This : *This\System\RefCounter + 1
      UnlockMutex(*This\System\Mutex)
      ProcedureReturn #S_OK
    EndIf
    If CompareMemory(*riid, ?IID_IUnknown, 16)
      ClassDebug("Interface IUnknown ok", *This)
      LockMutex(*This\System\Mutex)
      *Object\i = *This : *This\System\RefCounter + 1
      UnlockMutex(*This\System\Mutex)
      ProcedureReturn #S_OK
    EndIf
    ClassDebug("Error: Interface not exists " + GetGuidString(*riid), *This)
    *Object\i = 0
    ProcedureReturn #E_NOINTERFACE
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure AddRef(*This.sClassDispatch)
    LockMutex(*This\System\Mutex)
    *This\System\RefCounter + 1
    ClassDebug("RefCounter: " + Str(*This\System\RefCounter), *This)
    UnlockMutex(*This\System\Mutex)
    ProcedureReturn *This\System\RefCounter
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure Release(*This.sClassDispatch)
    With *This\System
      LockMutex(*This\System\Mutex)
      If \RefCounter = 0
        LockMutex(*This\System\Self\Mutex)
        If LastElement(\Self\Dispose())
          Repeat
            \Self\Dispose()\Invoke(*This)
          Until PreviousElement(\Self\Dispose()) = 0
        EndIf
        UnlockMutex(*This\System\Self\Mutex)
        ClassDebug("Object Released", *This)
        FreeMutex(*This\System\Mutex)
        FreeStructure(*This)
        GlobalObjectCounter(#False)
        ProcedureReturn 0
      Else
        \RefCounter - 1
        ClassDebug("RefCounter: " + Str(*This\System\RefCounter), *This)
      EndIf
      UnlockMutex(*This\System\Mutex)
      ProcedureReturn \RefCounter
    EndWith
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure GetTypeInfoCount(*This.sClassDispatch, *CntTypeInfo.Integer)
    ClassDebug("No typeinfo count")
    *CntTypeInfo\i = 0
    ProcedureReturn #S_OK
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure GetTypeInfo(*This.sClassDispatch, TypeInfo.i, LocalId.i, *ppTypeInfo.Integer)
    ClassDebug("No typeinfo")
    ProcedureReturn #E_NOTIMPL
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure GetIDsOfNames(*This.sClassDispatch, *iid.IID, *Names.udtArrayString, cntNames.i, lcid.i, *DispId.udtArrayLong)
    Protected Name.s, index, cnt, r1
    If Not *Names
      ClassDebug("Error: Name invalid arg", *This)
      ProcedureReturn #E_POINTER
    EndIf
    If Not *DispId
      ClassDebug("Error: DispID invalid arg", *This)
      ProcedureReturn #E_POINTER
    EndIf
    r1 = #S_OK
    cnt = cntNames - 1
    If cnt
      ClassDebug("Count of Names: " + cntNames, *This)
    EndIf
    For index = 0 To cnt
      Name.s = LCase(*Names\Name[index]\s)
      If FindMapElement(*This\System\Self\vMethodeID(), Name)
        *DispId\lVal[index] = *This\System\Self\vMethodeID()\Index
        ClassDebug(*Names\Name[index]\s + ": DispID " + Str(*DispId\lVal[index]), *This)
      ElseIf FindMapElement(*This\System\Self\vPropertyID(), Name)
        *DispId\lVal[index] = *This\System\Self\vPropertyID()\Index
        ClassDebug(*Names\Name[index]\s + ": DispID " + Str(*DispId\lVal[index]), *This)
      Else
        *DispId\lVal[index] = #DISPID_UNKNOWN
        r1 = #DISP_E_UNKNOWNNAME
      EndIf
    Next
    ProcedureReturn r1
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure Invoke(*This.sClassDispatch, DispId.i, *iid.IID, lcid.i, Flags.i, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
    Protected result, cArgs, *vArgs.udtArrayVariant, cNamedArgs, *DispIdNamedArgs.udtArrayLong
    Protected *pInteger.Integer, *pLong.Long, *pQuad.Quad, *pFloat.Float, *pDouble.Double, *pString.String, *pPointer.Integer, *Variant.Variant
    Protected vDispInvoke.ProtoInvokeDispatch
    
    With *This\System\Self
      ; Check Parameters
      If Not CompareMemory(*iid, ?IID_INULL, SizeOf(IID))
        ClassDebug("Error: IID unknown interface " + GetGuidString(*iid), *This)
        ProcedureReturn #DISP_E_UNKNOWNINTERFACE
      EndIf
      If *DispParams = 0
        ClassDebug("Error: Pointer DispParams invalid", *This)
        ProcedureReturn #DISP_E_PARAMNOTOPTIONAL
      EndIf
      ; Check DispId 
      If DispId <= 1000
        ; Methode
        If *DispParams\cNamedArgs
          ClassDebug("Error: DispInvoke not support named arguments", *This)
          ProcedureReturn #DISP_E_NONAMEDARGS
        EndIf
        If DispId < 7 Or DispId >= \cDispInvoke
          ClassDebug("Error: DispID invalid index", *This)
          ProcedureReturn #DISP_E_BADINDEX
        EndIf
        If \vDispInvoke(DispId) = 0
          ClassDebug("Error: DispID invalid index", *This)
          ProcedureReturn #DISP_E_BADINDEX
        EndIf
        ; Invoke function
        ClassDebug("Method: DispID " + Str(DispId), *This)
        vDispInvoke = \vDispInvoke(DispId)
        result = vDispInvoke(*This, DispId.i, *iid, lcid.i, Flags.i, *DispParams, *vResult, *ExcepInfo, *ArgErr)
        ProcedureReturn result
      Else
        ; Properties
        Repeat
          ForEach \vPropertyID()
            If \vPropertyID()\Index = DispID
              Break 2
            EndIf
          Next
          ProcedureReturn #DISP_E_BADINDEX
        Until #True
        If Flags & #DISPATCH_PROPERTYGET
          If *vResult = 0
            ClassDebug("Error: Pointer vResult invalid", *This)
            ProcedureReturn #DISP_E_PARAMNOTOPTIONAL
          EndIf
          ClassDebug("PropertyGet: DispID " + Str(DispId), *This)
          Select \vPropertyID()\Type
            Case #PB_Integer
              *pInteger = *this + \vPropertyID()\Offset
              SetVariantInteger(*vResult, *pInteger\i)
              ProcedureReturn #S_OK   
            Case #PB_Long
              *pLong = *this + \vPropertyID()\Offset
              SetVariantLong(*vResult, *pLong\l)
              ProcedureReturn #S_OK   
            Case #PB_Quad
              *pQuad = *this + \vPropertyID()\Offset
              SetVariantQuad(*vResult, *pQuad\q)
              ProcedureReturn #S_OK   
            Case #PB_Float
              *pFloat = *this + \vPropertyID()\Offset
              SetVariantFloat(*vResult, *pFloat\f)
              ProcedureReturn #S_OK   
            Case #PB_Double
              *pDouble = *this + \vPropertyID()\Offset
              SetVariantDouble(*vResult, *pDouble\d)
              ProcedureReturn #S_OK   
            Case #PB_String
              *pString = *this + \vPropertyID()\Offset
              SetVariantString(*vResult, *pString\s)
              ProcedureReturn #S_OK   
            Case #PB_Date
              *pInteger = *this + \vPropertyID()\Offset
              SetVariantDate(*vResult, *pInteger\i)
              ProcedureReturn #S_OK  
            Case #PB_Variant
              *Variant = *this + \vPropertyID()\Offset
              If *Variant
                VariantCopy_(*vResult, *Variant)
              EndIf
              ProcedureReturn #S_OK  
            Case #PB_VariantByRef
              *pPointer = *this + \vPropertyID()\Offset
              *Variant = *pPointer\i
              If *Variant
                VariantCopy_(*vResult, *Variant)
              Else
                VariantClear_(*vResult)
              EndIf
              ProcedureReturn #S_OK  
          EndSelect
        ElseIf Flags & #DISPATCH_PROPERTYPUT
          cArgs = *DispParams\cArgs
          If cArgs <> 1
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ClassDebug("PropertyPut: DispID " + Str(DispId), *This)
          *vArgs = *DispParams\rgvarg
          Select \vPropertyID()\Type
            Case #PB_Integer
              *pInteger = *this + \vPropertyID()\Offset
              *pInteger\i = GetVariantInteger(*vArgs\Arg[0])
              ProcedureReturn #S_OK
            Case #PB_Long
              *pLong = *this + \vPropertyID()\Offset
              *pLong\l = GetVariantLong(*vArgs\Arg[0])
              ProcedureReturn #S_OK
            Case #PB_Quad
              *pQuad = *this + \vPropertyID()\Offset
              *pQuad\q = GetVariantQuad(*vArgs\Arg[0])
              ProcedureReturn #S_OK
            Case #PB_Float
              *pFloat = *this + \vPropertyID()\Offset
              *pFloat\f = GetVariantFloat(*vArgs\Arg[0])
              ProcedureReturn #S_OK
            Case #PB_Double
              *pDouble = *this + \vPropertyID()\Offset
              *pDouble\d = GetVariantDouble(*vArgs\Arg[0])
              ProcedureReturn #S_OK
            Case #PB_String
              *pString = *this + \vPropertyID()\Offset
              *pString\s = GetVariantString(*vArgs\Arg[0])
              ProcedureReturn #S_OK
            Case #PB_Date
              *pInteger = *this + \vPropertyID()\Offset
              *pInteger\i = GetVariantDate(*vArgs\Arg[0])
            Case #PB_Variant
              *Variant = *this + \vPropertyID()\Offset
              VariantClear_(*Variant)
              VariantCopy_(*Variant, *vArgs\Arg[0])
            Case #PB_VariantByRef
              *pPointer = *this + \vPropertyID()\Offset
              *Variant = *pPointer\i
              If *Variant
                VariantClear_(*Variant)
                VariantCopy_(*Variant, *vArgs\Arg[0])
              EndIf
          EndSelect
        Else
          ProcedureReturn #DISP_E_BADVARTYPE
        EndIf
      EndIf
    EndWith
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure InitClassDispatch()
    AddMapElement(Class\Entry(), "ClassDispatch")
    With Class\Entry("ClassDispatch")
      \vTable(0) = @QueryInterface()
      \vTable(1) = @AddRef()
      \vTable(2) = @Release()
      \vTable(3) = @GetTypeInfoCount()
      \vTable(4) = @GetTypeInfo()
      \vTable(5) = @GetIDsOfNames()
      \vTable(6) = @Invoke()
      \vMethodeID("QueryInterface")\Index = 0
      \vMethodeID("AddRef")\Index = 1
      \vMethodeID("Release")\Index = 2
      \vMethodeID("GetTypeInfoCount")\Index = 3
      \vMethodeID("GetTypeInfo")\Index = 4
      \vMethodeID("GetIDsOfNames")\Index = 5
      \vMethodeID("Invoke")\Index = 6
    EndWith
  EndProcedure : InitClassDispatch()
  
  ; ---------------------------------------------------------------------------
  
EndModule

;- End Module ClassDispatch

; ***************************************************************************************

;- Begin Declare Module ClassFactory

DeclareModule ClassFactory
  
  Prototype InvokeNewAppObject()
  
  Structure sClassFactory
    *VTable
    cntRef.i
    cntLockServer.i
    NewAppObject.InvokeNewAppObject
  EndStructure
  
  ; ---------------------------------------------------------------------------
  
  Declare NewClassFactory(*NewAppObject)
  
  ; ---------------------------------------------------------------------------
  
EndDeclareModule

; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;- Begin Module Classfactory

Module ClassFactory
  
  EnableExplicit
  
  UseModule ClassCommon
  
  ; ---------------------------------------------------------------------------
  
  Procedure QueryInterface(*This.sClassFactory, *iid.IID, *Object.Integer)
    If CompareMemory(*iid, ?IID_IClassFactory, 16)
      ClassDebug("Interface IClassFactory ok", *This)
      *Object\i = *This : *This\cntRef + 1
      ProcedureReturn #S_OK
    EndIf
    If CompareMemory(*iid, ?IID_IUnknown, 16)
      ClassDebug("Interface IUnknown ok", *This)
      *Object\i = *This : *This\cntRef + 1
      ProcedureReturn #S_OK
    EndIf
    ClassDebug("Error: Interface not exists " + GetGuidString(*iid), *This)
    *Object\i = 0
    ProcedureReturn #E_NOINTERFACE
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure AddRef(*This.sClassFactory)
    *This\cntRef + 1
    ClassDebug("RefCounterer: " + Str(*This\cntRef), *This)
    ProcedureReturn *This\cntRef
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure Release(*This.sClassFactory)
    If *This\cntRef > 1
      *This\cntRef - 1
      ClassDebug("RefCounter: " + Str(*This\cntRef), *This)
      ProcedureReturn *This\cntRef
    EndIf
    ClassDebug("Object released", *This)
    FreeStructure(*This)
    GlobalObjectCounter(#False)
    ProcedureReturn 0
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure CreateInstance(*This.sClassFactory, *pUnkOuter, *riid.IID, *ppvObject.Integer)
    Protected *NewObject.IUnknown
    ; Aggregation is currently not supported
    If *pUnkOuter
      *ppvObject\i = 0
      ClassDebug("New application no aggregation")
      ProcedureReturn #CLASS_E_NOAGGREGATION
    EndIf
    If CompareMemory(*riid, ?IID_IUnknown, 16) Or CompareMemory(*riid, ?IID_IDispatch, 16)
      ; Create a new application object
      If *This\NewAppObject
        *NewObject = *This\NewAppObject()
        If *NewObject
          ClassDebug("New object ok [" + Hex(*NewObject) + "]")
          *ppvObject\i = *NewObject
          ProcedureReturn #S_OK
        Else
          ClassDebug("Error: New object out of memory")
          ProcedureReturn #E_OUTOFMEMORY
        EndIf
      Else
        ClassDebug("Error: New object no pointer")
        ProcedureReturn #E_POINTER
      EndIf
    Else
      ; Not implemented class was requested
      *ppvObject\i = 0
      ClassDebug("Error: Interface not exists " + GetGuidString(*riid))
      ProcedureReturn #E_NOINTERFACE
    EndIf
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure LockServer(*This.sClassFactory, fLock)
    If fLock = #False
      If *This\cntLockServer > 0
        *This\cntLockServer - 1
        ClassDebug("LockCounter: " + Str(*This\cntLockServer))   
      EndIf
    Else
      *This\cntLockServer + 1
      ClassDebug("LockCounter: " + Str(*This\cntLockServer))   
    EndIf
    ProcedureReturn #S_OK
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure NewClassFactory(*NewAppObject)
    Protected *object.sClassFactory
    *object = AllocateStructure(sClassFactory)
    If *object
      GlobalObjectCounter(#True)
      *object\VTable = ?VT_ClassFactory
      *object\NewAppObject = *NewAppObject
      ProcedureReturn *object
    Else
      ProcedureReturn 0
    EndIf
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  DataSection
    VT_ClassFactory:
    Data.i @QueryInterface()
    Data.i @AddRef()
    Data.i @Release()
    Data.i @CreateInstance()
    Data.i @LockServer()
  EndDataSection
  
EndModule

;- End Module ClassFactory

; ***************************************************************************************

;- Begin Macro InitClassFactory

Macro InitClassFactory(CF_ProgramID, CF_ClassID, CF_Description, CF_NewAppObject, CF_IID_Application)
  
  ; -------------------------------------------------------------------------
  
  UseModule ClassCommon
  UseModule ClassFactory
  
  ; -------------------------------------------------------------------------
  
  ProcedureDLL AttachProcess(Instanz)
    ClassCommon::ClassDebugEx("COM","DLL","AttachProzess")
  EndProcedure
  
  ProcedureDLL DetachProcess(Instanz)
    ClassCommon::ClassDebugEx("COM","DLL","DetachProzess")
  EndProcedure
  
  ProcedureDLL AttachThread(Instanz)
    ClassCommon::ClassDebugEx("COM","DLL","AttachThread")
  EndProcedure
  
  ProcedureDLL DetachThread(Instanz)
    ClassCommon::ClassDebugEx("COM","DLL","DetachThread")
  EndProcedure
  
  ; -------------------------------------------------------------------------
  
  ProcedureDLL DllCanUnloadNow()
    If ClassCommon::__ObjectCounter\Count = 0
      ClassCommon::ClassDebugEx("COM","DLL","CanUnloadNow Ok")
      ProcedureReturn #S_OK
    Else
      ClassCommon::ClassDebugEx("COM","DLL","CanUnloadNow False")
      ProcedureReturn #S_FALSE
    EndIf
  EndProcedure
  
  ; -------------------------------------------------------------------------
  
  ProcedureDLL DllGetClassObject(*rclsid.IID, *riid.iid, *ppvObject.Integer)
    Define *Object.IUnknown
    If CompareMemory(*rclsid, CF_IID_Application, SizeOf(iid))
      If CompareMemory(*riid, ?IID_IClassFactory, SizeOf(iid))
        ;Klassenobjekt erstellen
        *Object = NewClassFactory(CF_NewAppObject)
        If *Object
          ClassCommon::ClassDebugEx("COM","DLL","GetClassObject: Object ClassFactory ok [" + Hex(*Object) + "]")
          *Object\AddRef()
          *ppvObject\i = *Object
          ProcedureReturn #S_OK
        Else
          *ppvObject\i = 0
          ClassCommon::ClassDebugEx("COM","DLL","GetClassObject Error: Out of memory")
          ProcedureReturn #E_OUTOFMEMORY
        EndIf
      Else
        *ppvObject\i = 0
        ClassCommon::ClassDebugEx("COM","DLL", "GetClassObject Error: Interface not exists " + GetGuidString(*riid))
        ProcedureReturn #CLASS_E_CLASSNOTAVAILABLE
      EndIf
    Else
      *ppvObject\i = 0
      ClassCommon::ClassDebugEx("COM","DLL","GetClassObject Error: ClassID not available")
      ProcedureReturn #CLASS_E_CLASSNOTAVAILABLE
    EndIf
  EndProcedure
  
  ; -------------------------------------------------------------------------
  
  ProcedureDLL DllRegisterServer()
    Protected DLL_Name.s, hKey.i, r1.i
    
    DLL_Name = ProgramFilename()
    
    r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, CF_ProgramID, 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
    r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_Description, StringByteLength(CF_Description) + 2)
    r1 + RegCloseKey_   (hKey)
    
    r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, CF_ProgramID + "\CLSID", 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
    r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_ClassID, StringByteLength(CF_ClassID) + 2)
    r1 + RegCloseKey_   (hKey)
    
    r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID, 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
    r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_Description, StringByteLength(CF_Description) + 2)
    r1 + RegCloseKey_   (hKey)
    
    r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID + "\InprocServer32", 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
    r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, DLL_Name, StringByteLength(DLL_Name) + 2)
    r1 + RegCloseKey_   (hKey)
    
    r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID + "\ProgId", 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
    r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_ProgramID + ".1", StringByteLength(CF_ProgramID + ".1") + 2)
    r1 + RegCloseKey_   (hKey)
    
    If r1
      ProcedureReturn #SELFREG_E_CLASS
    Else
      ProcedureReturn #S_OK
    EndIf
  EndProcedure
  
  ; -------------------------------------------------------------------------
  
  ProcedureDLL DllUnregisterServer()
    Protected r1.i
    
    r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID + "\ProgId")
    r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID + "\InprocServer32")
    r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID)
    
    r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, CF_ProgramID + "\CLSID")
    r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, CF_ProgramID)
    
    If r1
      ProcedureReturn #SELFREG_E_CLASS
    Else
      ProcedureReturn #S_OK
    EndIf
  EndProcedure
  
  ; -------------------------------------------------------------------------
  
  UnuseModule ClassCommon
  UnuseModule ClassFactory
  
  ; -------------------------------------------------------------------------
  
EndMacro

;- End Macro InitClassFactory

; ***************************************************************************************
Last edited by mk-soft on Mon Jun 05, 2017 2:09 pm, edited 9 times in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5313
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by mk-soft »

New Example As Overview

Code: Select all

;-TOP

IncludeFile "Modul_BaseClassDispatch.pb"

; Create Logfile
ClassCommon::EnableClassDebug()

; *******************************************************************************

DeclareModule ClassExample
  
  UseModule ClassDispatch
  ; Properties
  Structure sClassExample Extends sClassDispatch
    name.s
    value.d
    pbdate.i
  EndStructure
  ; Methodes
  Interface iClassExample Extends iClassDispatch
    SetName(Name.s)
    GetName.s()
    GetValue.d()
    SetValue(Value.d)
  EndInterface
  
  UnuseModule ClassDispatch
  ; Create new Object
  Declare.i New()
  
EndDeclareModule

Module ClassExample
  
  EnableExplicit
  
  UseModule ClassCommon
  UseModule ClassDispatch
  
  ; Create Class
  NewClass(iClassExample)
  
  ; ---------------------------------------------------------------------------
  
  ; Defined Public Properties
  UseProperty(sClassExample)
  DefineProperty(Name)
  DefineProperty(Value)
  ; Defined Public Property with own name
  DefinePropertyDateAs(Date, sClassExample\pbdate)
  
  ; ---------------------------------------------------------------------------
  
  ; ToDo first by new object
  Procedure Init(*this.sClassExample)
    ClassDebug("Init Object ", *this)
    *this\name = "Purebasic Power"
    *this\value = 0.0
    *this\pbdate = Date()
  EndProcedure : AsInitalizeObject(Init)
  
  ; ---------------------------------------------------------------------------
  
  ; ToDo by release object
  Procedure Dispose(*this.sClassExample)
    ClassDebug("Dispose Object ", *this)
  EndProcedure : AsDisposeObject(Dispose)
  
  ; ---------------------------------------------------------------------------
  
  ; Own DispInvoke
  Procedure DispSetName(*this.iClassExample, DispId.l, *iid.IID, lcid.l, Flags.w, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
    Protected cArgs, *vArgs.udtArrayVariant, r1.i
    cArgs = *DispParams\cArgs
    *vArgs = *DispParams\rgvarg
    ; Check count of arguments
    If cArgs <> 1
      ProcedureReturn #DISP_E_BADPARAMCOUNT
    EndIf
    ; Invoke methode
    r1 = *this\SetName(GetVariantString(*vArgs\Arg[0]))
    ; Set result
    If *vResult
      SetVariantInteger(*vResult, r1)
    EndIf
    ProcedureReturn #S_OK
  EndProcedure
  
  Procedure SetName(*this.sClassExample, Name.s)
    With *this
      \name = Name
      ProcedureReturn Len(\name)
    EndWith
  EndProcedure : AsMethode(SetName)
  
  ; ---------------------------------------------------------------------------
  
  ; Create the DispInvoke over Macro
  Procedure.s GetName(*this.sClassExample)
    Protected text.s
    With *this
      text = \name
      ProcedureReturn text
    EndWith
  EndProcedure : AsMethodeDisp(GetName, String)
  
  ; ---------------------------------------------------------------------------
  
  ; Create the DispInvoke over Macro
  Procedure SetValue(*this.sClassExample, Value.d)
    With *this
      \value = Value
    EndWith
  EndProcedure : AsMethodeDisp(SetValue, Void, Double)
  
  ; ---------------------------------------------------------------------------
  
  ; Create the DispInvoke over Macro
  Procedure.d GetValue(*this.sClassExample)
    Protected value.d
    With *this
      value = \value
      ProcedureReturn value
    EndWith
  EndProcedure : AsMethodeDisp(GetValue, Double)
  
  ; ---------------------------------------------------------------------------
  
  Procedure New()
    InitObject(sClassExample) ; Do not more
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  CheckInterface(iClassExample)
  
EndModule

; ***************************************************************************************

;- Create ClassFactory

EnableExplicit

; Always encapsulate in a procedure
Procedure InitDLL()
  Global ProgramId.s   = "PureExample.Application"
  Global ClassId.s     = ClassCommon::GetGuidString(?CLSID_App)
  Global Description.s = "Purebasic Example COM-DLL"
EndProcedure : InitDLL()

; Own CLSID
DataSection
  CLSID_App:
  Data.l $01AAD4B2
  Data.w $FFFF, $4E08
  Data.b $FF, $FF, $FF, $FF, $60, $FF, $3B, $21
EndDataSection

InitClassFactory(ProgramId, ClassId, Description, ClassExample::@New(), ?CLSID_App)
VBS
dim obj, len, text
set obj = createobject("PureExample.Application")

msgbox "Started: " & obj.date

len = obj.SetName("Purebasic COM-Power")
msgbox "Len of name: " & len

msgbox "Methode GetName: " + obj.getname
msgbox "Property Name: " + obj.name

obj.value = inputbox("Value:", Value)

msgbox "Methode GetValue: " + cstr(obj.getvalue)
msgbox "Property Value: " + cstr(obj.value)

set obj = Nothing
:wink:
Last edited by mk-soft on Sun May 14, 2017 2:49 pm, edited 7 times in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
step11
New User
New User
Posts: 7
Joined: Tue May 31, 2016 7:19 am

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by step11 »

Yeah,You are so great! :D
Thanks for sharing
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5342
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by Kwai chang caine »

Works great !!! :D
Thanks a lot for sharing 8)

I have try to use COMATE without success :oops:

Code: Select all

IncludeFile #PB_Compiler_Home + "COMatePLUS\COMatePLUS.pbi"

Define.COMateObject PbObject
PbObject = COMate_CreateObject("PureExample.Application")
 
If PbObject
  
 PbObject\SetProperty("'Purebasic', 'COM-Power'")
 Text$ = PbObject\GetStringProperty("GetName()")
 MessageRequester("Try", Text$)
 PbObject\Release()
   
Else
 
 MessageRequester("Test COMATE", "The COMATE connexion not works.")
  
EndIf
ImageThe happiness is a road...
Not a destination
User avatar
mk-soft
Always Here
Always Here
Posts: 5313
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by mk-soft »

What say the logfile?
At time not home. I can look tomorow ....
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5313
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by mk-soft »

It´s work :wink:

1. Compile Example1 as 32Bit Unicode-DLL
2. Registry DLL "regsvr32.exe example1.dll". Needed Admin
3. Start ComatePlus Test as 32Bit Unicode...

Code: Select all

IncludeFile "COMatePLUS.pbi"

Define.COMateObject PbObject
PbObject = COMate_CreateObject("PureExample.Application")
 
If PbObject
  
 PbObject\SetProperty("SetName('Purebasic', 'COM-Power')")
 Text$ = PbObject\GetStringProperty("GetName()")
 MessageRequester("Try", Text$)
 PbObject\Release()
   
Else
 
 MessageRequester("Test COMATE", "The COMATE connexion not works.")
  
EndIf
You have a bug by SetProperty...

Logfile from example.dll
[.] GetClassObject: Get object ok
[ClassFactory.AddRef] RefCounter: 1
[ClassFactory.AddRef] RefCounter: 2
[ClassFactory.Release] RefCounter: 1
[ClassFactory.QueryInterface] Object ok
[ClassFactory.Release] RefCounter: 1
[ClassFactory.CreateInstance] New application object ok
[ClassFactory.Release] Object released
[ClassDispatch.AddRef] RefCounter: 1
[ClassDispatch.GetIDsOfNames] SetName: 7
[ClassDispatch.Invoke] DispID 7
[ClassDispatch.Release] Refcounter: 0
[ClassDispatch.AddRef] RefCounter: 1
[ClassDispatch.GetIDsOfNames] GetName: 8
[ClassDispatch.Invoke] DispID 8
[ClassDispatch.Release] Refcounter: 0
[ClassDispatch.Release] Object Released
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
QuimV
Enthusiast
Enthusiast
Posts: 337
Joined: Mon May 29, 2006 11:29 am
Location: BARCELONA - SPAIN

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by QuimV »

Hi,

When I execute "regsvr32 -u example1.dll", I get the error: "Error calling DLLUnregisterServer error code: 0x80009e41"
I use PB 5.51 + W7-32

Can someone tell me what this error is?

Thanks in advance
QuimV
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5342
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by Kwai chang caine »

MkSoft wrote:It´s work
Waoooouuhh !!!
You have right MKSOFT, that's works very well with COMATE !!! :shock:
Here i can registred and unregistred the DLL, run the code and obtain :
[.] GetClassObject: Get object ok
[ClassFactory.AddRef] RefCounter: 1
[ClassFactory.AddRef] RefCounter: 2
[ClassFactory.Release] RefCounter: 1
[ClassFactory.QueryInterface] Object ok
[ClassFactory.Release] RefCounter: 1
[ClassFactory.CreateInstance] New application object ok
[ClassFactory.Release] Object released
[ClassDispatch.AddRef] RefCounter: 1
[ClassDispatch.GetIDsOfNames] SetName: 7
[ClassDispatch.Invoke] DispID 7
[ClassDispatch.Release] Refcounter: 0
[ClassDispatch.AddRef] RefCounter: 1
[ClassDispatch.GetIDsOfNames] GetName: 8
[ClassDispatch.Invoke] DispID 8
[ClassDispatch.Release] Refcounter: 0
[ClassDispatch.Release] Object Released
You , SROD, TsSoft and Kiffy are the kings of the COM :D
Thanks you all, we can play in the playground of the monstruous and incomprehensible MICROSOFT OLE :?
Thanks a lot for this great code 8)
ImageThe happiness is a road...
Not a destination
User avatar
mk-soft
Always Here
Always Here
Posts: 5313
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by mk-soft »

Thanks :wink:

It works with wscript 32bit but not with wscript 64bit. I don´t know where is a problem with 'DllGetClassObject(*rclsid.IID, *riid.iid, *ppvObject.Integer)'

WScript32.bat
%windir%\SysWOW64\wscript.exe TestExample.vbs
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
Josh
Addict
Addict
Posts: 1183
Joined: Sat Feb 13, 2010 3:45 pm

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by Josh »

Are you sure, that there is a 64 bit version? WScript is so old, at this time there was probably no 64 bit Windows. ScriptControl for example was never updated to 64 bit.

On the other side, did you use IIDs anywhere? ActiveScripting IIDs for x86 and x64 are partly different.
sorry for my bad english
User avatar
mk-soft
Always Here
Always Here
Posts: 5313
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by mk-soft »

Update v1.06
- Fixed for 64bit DLL

Had taken the wrong regsvr32.exe to register the DLL.
Now it works also with the 64bit DLL with the 64bit version of wscript.
Registry DLL
as 32bit
%systemroot%\SysWow64\regsvr32.exe "FolderToDLL\example1.dll"
as64Bit
%systemroot%\System32\regsvr32.exe "FolderToDLL\example1.dll"

Unregistry DLL
as 32bit
%systemroot%\SysWow64\regsvr32.exe -u "FolderToDLL\example1.dll"
as64Bit
%systemroot%\System32\regsvr32.exe - u "FolderToDLL\example1.dll"
Last edited by mk-soft on Fri Mar 24, 2017 2:12 am, edited 1 time in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5313
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by mk-soft »

QuimV wrote: When I execute "regsvr32 -u example1.dll", I get the error: "Error calling DLLUnregisterServer error code: 0x80009e41"
I use PB 5.51 + W7-32
Maybe you use different regsvr32 for 32 and 64bit. I had the same problem.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
QuimV
Enthusiast
Enthusiast
Posts: 337
Joined: Mon May 29, 2006 11:29 am
Location: BARCELONA - SPAIN

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by QuimV »

:D That was the problem
It already works great.
Thank you very much @mk-soft
QuimV
User avatar
mk-soft
Always Here
Always Here
Posts: 5313
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass ClassDispatch inclusive ClassFactory

Post by mk-soft »

Update v1.07
- Bugfix create dll

Added Example 2 :wink:

P.S.
Update v1.08
- Optimize internal class management
:wink:
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
Post Reply