PureBasic Forums - English

Code: Select all

;-Begin Module BaseClass Small Version
; Comment : Module as Object
; Author : mk-soft
; File : BaseClassSmall.pb
; Version : v1.21.1
; Created : 16.08.2017
; Updated : 07.06.2020
; Link DE : http://www.purebasic.fr/german/viewtopic.php?f=8&t=29343
; Link EN : http://www.purebasic.fr/english/viewtopic.php?f=12&t=64305
; OS : All
; ***************************************************************************************
DeclareModule BaseClass
 
 ; ---------------------------------------------------------------------------
 
 ; Internal class declaration
 
 Prototype ProtoInvoke(*This)
 
 Structure udtInvoke
 *Invoke.ProtoInvoke
 EndStructure
 
 Structure udtClass
 Array *vTable(3)
 Array Initialize.udtInvoke(0)
 Array Dispose.udtInvoke(0)
 *Package.sPackage
 EndStructure
 
 ; ---------------------------------------------------------------------------
 
 ; BaseClass declaration
 
 Structure sBaseSystem
 *vTable
 *Class.udtClass
 RefCount.i
 Mutex.i
 EndStructure
 
 ; Public Structure
 Structure sBaseClass
 System.sBaseSystem
 EndStructure
 
 ; Public Interface 
 Interface iBaseClass
 QueryInterface(*riid, *ppvObject)
 AddRef()
 Release()
 EndInterface
 
 ; ---------------------------------------------------------------------------
 
 Macro _dq_
 "
 EndMacro
 
 ; ---------------------------------------------------------------------------
 
 ; Added New Class
 Declare AddClass(ClassInterface.s, ClassExtends.s, Size) ; Internal
 
 Macro NewClass(ClassInterface, ClassExtends=)
 ; Interface helper
 Interface __Interface Extends ClassInterface
 EndInterface
 ; Internal class pointer
 Global *__Class.udtClass
 ; Add new class
 Procedure __NewClass()
 *__Class = AddClass(_dq_#ClassInterface#_dq_, _dq_#ClassExtends#_dq_, SizeOf(ClassInterface) / SizeOf(integer))
 EndProcedure : __NewClass()
 EndMacro
 
 ; ---------------------------------------------------------------------------
 
 ; Macros for package attributes
 Macro InitPackage(_Attributes_=sPackage)
 Procedure __InitPackage()
 *__Class\Package = AllocateStructure(_Attributes_)
 EndProcedure : __InitPackage()
 EndMacro
 
 Macro GetPackage()
 *__Class\Package
 EndMacro
 
 ; ---------------------------------------------------------------------------
 
 ; Macro for init object (short)
 Macro InitObject(sProperty)
 Protected *Object.sProperty, __cnt, __index
 *Object = AllocateStructure(sProperty)
 If *Object
 *Object\System\vTable = *__Class\vTable()
 *Object\System\Class = *__Class
 *Object\System\RefCount = 0
 *Object\System\Mutex = CreateMutex()
 __cnt = ArraySize(*Object\System\Class\Initialize())
 For __index = 1 To __cnt
 *Object\System\Class\Initialize(__index)\Invoke(*Object)
 Next
 EndIf
 ProcedureReturn *Object
 EndMacro
 
 ; ---------------------------------------------------------------------------
 
 ; Macros for init object (advanced)
 Macro AllocateObject(Object, sProperty)
 Object = AllocateStructure(sProperty)
 If Object
 Object\System\vTable = *__Class\vTable()
 Object\System\Class = *__Class
 Object\System\RefCount = 0
 Object\System\Mutex = CreateMutex()
 EndIf
 EndMacro
 
 Macro InitializeObject(Object)
 If Object
 Protected __cnt, __index
 __cnt = ArraySize(Object\System\Class\Initialize())
 For __index = 1 To __cnt
 Object\System\Class\Initialize(__index)\Invoke(Object)
 Next
 EndIf
 EndMacro
 
 ; ---------------------------------------------------------------------------
 
 ; Macros for clone object
 Macro CloneObject(This, Clone, sProperty)
 Clone = AllocateStructure(sProperty)
 If Clone
 CopyStructure(This, Clone, sProperty)
 Clone\System\RefCount = 0
 Clone\System\Mutex = CreateMutex()
 EndIf
 EndMacro
 
 ; ---------------------------------------------------------------------------
 
 Macro LockObject(This)
 LockMutex(This\System\Mutex)
 EndMacro 
 
 Macro UnlockObject(This)
 UnlockMutex(This\System\Mutex)
 EndMacro 
 
 ; ---------------------------------------------------------------------------
 
 ; Macros to defined Initialize, Dispose, Methods
 
 ; Add Procedure as Initialize Object
 Macro AsInitializeObject(Name)
 Procedure __AddInitializeObject#Name()
 Protected index
 index = ArraySize(*__Class\Initialize()) + 1
 ReDim *__Class\Initialize(index)
 *__Class\Initialize(index)\Invoke = @Name()
 EndProcedure : __AddInitializeObject#Name()
 EndMacro
 
 ; Add Procedure as Dispose Object
 Macro AsDisposeObject(Name)
 Procedure __AddDisposeObject#Name()
 Protected index
 index = ArraySize(*__Class\Dispose()) + 1
 ReDim *__Class\Dispose(index)
 *__Class\Dispose(index)\Invoke = @Name()
 EndProcedure : __AddDisposeObject#Name()
 EndMacro
 
 ; Add Procedure as Methode or Overwrite inheritance methode
 Macro AsMethode(Name)
 Procedure __AddMethode#Name()
 *__Class\vTable(OffsetOf(__Interface\Name()) / SizeOf(integer)) = @Name()
 EndProcedure : __AddMethode#Name()
 EndMacro
 
 Macro AsNewMethode(Name)
 AsMethode(Name)
 EndMacro
 
 ; ---------------------------------------------------------------------------
 
 ; Debugger functions
 
 Macro CheckInterface()
 CompilerIf #PB_Compiler_Debugger
 Procedure __CheckInterface()
 Protected *xml, *node, ErrorCount
 *xml = CreateXML(#PB_Any)
 If *xml
 *node = InsertXMLStructure(RootXMLNode(*xml), *__Class\vTable(), __Interface)
 *node = ChildXMLNode(*node)
 Repeat
 If Not *node
 Break
 EndIf
 If GetXMLNodeText(*node) = "0"
 ErrorCount + 1
 Debug "Module " + #PB_Compiler_Module + ": Error Interface - Missing Methode '" + GetXMLNodeName(*node) + "()'"
 EndIf
 *node = NextXMLNode(*node)
 ForEver
 FreeXML(*xml)
 If ErrorCount
 Debug "Module " + #PB_Compiler_Module + ": Error Count " + ErrorCount
 CallDebugger
 EndIf
 EndIf
 EndProcedure : __CheckInterFace()
 CompilerEndIf
 EndMacro
 
 ; ---------------------------------------------------------------------------
 
EndDeclareModule
Module BaseClass
 
 EnableExplicit
 
 ; ---------------------------------------------------------------------------
 
 Procedure QueryInterface(*This.sBaseClass, *riid, *ppvObject.integer)
 If *ppvObject = 0 Or *riid = 0
 ProcedureReturn 80070057ドル ; #E_INVALIDARG
 EndIf
 If CompareMemory(*riid, ?IID_IUnknown, 16)
 LockMutex(*This\System\Mutex)
 *ppvObject\i = *This
 *This\System\RefCount + 1
 UnlockMutex(*This\System\Mutex)
 ProcedureReturn 0 ; #S_OK
 Else
 *ppvObject\i = 0
 ProcedureReturn 80004002ドル ; #E_NOINTERFACE
 EndIf
 EndProcedure
 
 ; ---------------------------------------------------------------------------
 
 Procedure AddRef(*This.sBaseClass)
 LockMutex(*This\System\Mutex)
 *This\System\RefCount + 1
 UnlockMutex(*This\System\Mutex)
 ProcedureReturn *This\System\RefCount
 EndProcedure
 
 ; ---------------------------------------------------------------------------
 
 Procedure Release(*This.sBaseClass)
 Protected index, cnt
 With *This\System
 LockMutex(*This\System\Mutex)
 If \RefCount = 0
 cnt = ArraySize(\Class\Dispose())
 For index = cnt To 1 Step -1
 \Class\Dispose(index)\Invoke(*This)
 Next
 FreeMutex(\Mutex)
 FreeStructure(*This)
 ProcedureReturn 0
 Else
 \RefCount - 1
 EndIf
 UnlockMutex(*This\System\Mutex)
 ProcedureReturn \RefCount
 EndWith
 EndProcedure
 
 ; ---------------------------------------------------------------------------
 
 Procedure AddClass(ClassInterface.s, ClassExtends.s, Size)
 Static NewMap Classes.udtClass()
 Protected *class.udtClass, *extends.udtClass, sClassInterface.s, sClassExtends.s
 sClassInterface = LCase(ClassInterface)
 sClassExtends = LCase(ClassExtends)
 CompilerIf #PB_Compiler_Debugger
 If FindMapElement(Classes(), sClassInterface)
 Debug "Error: Class '" + ClassInterface + "' already exists!"
 CallDebugger
 End -1
 EndIf
 If Bool(sClassExtends)
 *extends = FindMapElement(Classes(), sClassExtends)
 If Not *extends
 Debug "Error: Extends Class '" + ClassExtends + "' not exists!"
 CallDebugger
 End -1
 EndIf
 EndIf
 CompilerEndIf
 *class = AddMapElement(Classes(), sClassInterface)
 If *class
 If Bool(sClassExtends)
 *extends = FindMapElement(Classes(), sClassExtends)
 CopyStructure(*extends, *class, udtClass)
 ReDim *class\vTable(Size)
 ProcedureReturn *class
 Else
 ReDim *class\vTable(Size)
 *class\vTable(0) = @QueryInterface()
 *class\vTable(1) = @AddRef()
 *class\vTable(2) = @Release()
 ProcedureReturn *class
 EndIf
 Else
 Debug "Error: Class '" + ClassInterface + "' Out Of Memory!"
 CallDebugger
 End -1
 EndIf
 EndProcedure
 
 ; ---------------------------------------------------------------------------
 
 DataSection
 IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
 Data.l 00000000ドル
 Data.w 0000,ドル 0000ドル
 Data.b $C0, 00,ドル 00,ドル 00,ドル 00,ドル 00,ドル 00,ドル 46ドル
 EndDataSection
 
EndModule
;- End Module BaseClass
; ***************************************************************************************

Code: Select all

; Example 3 v1.13
IncludeFile "Modul_BaseClassSmall.pb"
; *******************************************************************************
DeclareModule User
 
 UseModule BaseClass
 
 Structure sUser Extends sBaseClass
 firstname.s
 lastname.s
 EndStructure
 
 Interface iUser Extends iBaseClass
 SetName(FirstName.s, LastName.s)
 GetName.s()
 GetFirstName.s()
 GetLastName.s()
 Clone()
 EndInterface
 
 UnuseModule BaseClass
 
 Declare.i New()
 
EndDeclareModule
Module User
 
 UseModule BaseClass
 
 NewClass(iUser)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Init(*this.sUser)
 *this\firstname = "no name"
 *this\lastname = "no name"
 Debug "Initalize Object Class User " + *this
 EndProcedure : AsInitializeObject(Init)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Dispose(*this.sUser)
 Debug "Dispose Object Class User " + *this
 EndProcedure : AsDisposeObject(Dispose)
 
 ; ---------------------------------------------------------------------------
 
 Procedure SetName(*this.sUser, FirstName.s, LastName.s)
 With *this
 \firstname = FirstName
 \lastname = LastName
 EndWith
 EndProcedure : AsMethode(SetName)
 
 ; ---------------------------------------------------------------------------
 
 Procedure.s GetName(*this.sUser)
 With *this
 ProcedureReturn \lastname + ";" + \firstname
 EndWith
 EndProcedure : AsMethode(GetName)
 
 ; ---------------------------------------------------------------------------
 
 Procedure.s GetFirstName(*this.sUser)
 ProcedureReturn *this\firstname
 EndProcedure : AsMethode(GetFirstName)
 
 ; ---------------------------------------------------------------------------
 
 Procedure.s GetLastName(*this.sUser)
 ProcedureReturn *this\lastname
 EndProcedure : AsMethode(GetLastName)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Clone(*this.sUser)
 Protected *clone.sUser
 CloneObject(*this, *clone, sUser) 
 ProcedureReturn *clone
 EndProcedure : AsMethode(Clone)
 
 ; ---------------------------------------------------------------------------
 
 Procedure New()
 InitObject(sUser)
 EndProcedure
 
 ; ---------------------------------------------------------------------------
 
 CheckInterface()
 
EndModule
; *******************************************************************************
DeclareModule Adress
 
 UseModule User
 
 Structure sAdress Extends sUser
 street.s
 postal.i
 city.s
 country.s
 EndStructure
 
 Interface iAdress Extends iUser
 SetAdress(street.s, postal.i, city.s, country.s)
 GetStreet.s()
 GetPostal.i()
 GetCity.s()
 GetCountry.s()
 GetAll.s()
 EndInterface
 
 UnuseModule User
 
 Declare New()
 
EndDeclareModule
Module Adress
 
 UseModule BaseClass
 
 NewClass(iAdress, iUser)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Init(*this.sAdress)
 Debug "Initalize Object Class Adress " + *this
 EndProcedure : AsInitializeObject(Init)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Dispose(*this.sAdress)
 Debug "Dispose Object Class Adress " + *this
 EndProcedure : AsDisposeObject(Dispose)
 
 ; ---------------------------------------------------------------------------
 
 Procedure SetAdress(*this.sAdress, street.s, postal.i, city.s, country.s)
 With *this
 \street = street
 \postal = postal
 \city = city
 \country = country
 EndWith
 EndProcedure : AsMethode(SetAdress)
 
 ; ---------------------------------------------------------------------------
 
 Procedure.s GetStreet(*this.sAdress)
 With *this
 ProcedureReturn \street
 EndWith
 EndProcedure : AsMethode(GetStreet)
 
 ; ---------------------------------------------------------------------------
 
 Procedure GetPostal(*this.sAdress)
 With *this
 ProcedureReturn \postal
 EndWith
 EndProcedure : AsMethode(GetPostal)
 
 ; ---------------------------------------------------------------------------
 
 Procedure.s GetCity(*this.sAdress)
 With *this
 ProcedureReturn \city
 EndWith
 EndProcedure : AsMethode(GetCity)
 
 ; ---------------------------------------------------------------------------
 
 Procedure.s GetCountry(*this.sAdress)
 With *this
 ProcedureReturn \country
 EndWith
 EndProcedure : AsMethode(GetCountry)
 
 ; ---------------------------------------------------------------------------
 
 Procedure.s GetAll(*this.sAdress)
 Protected r1.s
 With *this
 r1 = \LastName + ";"
 r1 + \FirstName + ";"
 r1 + \street + ";"
 r1 + \city + ";"
 r1 + \postal + ";"
 r1 + \country
 ProcedureReturn r1
 EndWith
 EndProcedure : AsMethode(GetAll)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Clone(*this.sAdress)
 Protected *clone.sAdress
 CloneObject(*this, *clone, sAdress)
 ProcedureReturn *clone
 EndProcedure : AsNewMethode(Clone)
 
 ; ---------------------------------------------------------------------------
 
 Procedure New()
 InitObject(sAdress)
 EndProcedure
 
 ; ---------------------------------------------------------------------------
 
 CheckInterface()
 
EndModule
; *******************************************************************************
;- Test
Define.Adress::iAdress *user, *user2
*user=Adress::New()
Debug *user\GetName()
*user\SetName("Toto", "Buddy")
*user\AddRef()
Debug *user\GetName()
*user2 = *user\Clone()
*user2\SetAdress("My Street", 12345, "My City", "My Country")
Debug *user2\GetAll()
Debug *user\Release()
Debug *user\Release()
Debug *user2\Release()

Code: Select all

;-TOP
; Example 6 v1.13
IncludeFile "Modul_BaseClassSmall.pb"
; *******************************************************************************
DeclareModule DataSet
 
 UseModule BaseClass
 
 ; Properties
 Structure sDataSet Extends sBaseClass
 *pData
 Count.i
 Array *pStr(0)
 EndStructure
 
 ; Methods
 Interface iDataSet Extends iBaseClass
 Get.s(index)
 Count()
 EndInterface
 
 UnuseModule BaseClass
 
 ; New Object
 Declare New(*pData)
 
EndDeclareModule
Module DataSet
 
 UseModule BaseClass
 
 NewClass(iDataSet)
 
 ; ---------------------------------------------------------------------------
 
 Procedure.s Get(*this.sDataSet, index)
 With *this
 If index < \Count
 ProcedureReturn PeekS(\pStr(index))
 Else
 ProcedureReturn ""
 EndIf
 EndWith
 EndProcedure : AsMethode(Get)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Count(*this.sDataSet)
 ProcedureReturn *this\Count
 EndProcedure : AsMethode(Count)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Init(*this.sDataSet)
 Protected *pos, len, index
 With *this
 *pos = \pData
 Repeat
 len = MemoryStringLength(*pos)
 If len
 \Count + 1
 *pos + len * SizeOf(character) + SizeOf(character)
 Else
 Break
 EndIf
 ForEver
 Dim \pStr(\Count)
 *pos = \pData
 Repeat
 len = MemoryStringLength(*pos)
 If len
 \pStr(index) = *pos
 index + 1
 *pos + len * SizeOf(character) + SizeOf(character)
 Else
 Break
 EndIf
 ForEver
 
 EndWith
 
 EndProcedure : AsInitializeObject(Init)
 
 ; ---------------------------------------------------------------------------
 
 Procedure New(*pData)
 
 Protected *obj.sDataSet
 
 AllocateObject(*obj, sDataSet)
 If *obj
 *obj\pData = *pData
 EndIf
 InitializeObject(*obj)
 
 ProcedureReturn *obj
 
 EndProcedure
 
 ; ---------------------------------------------------------------------------
 
 CheckInterface()
 
EndModule
; *******************************************************************************
;- Test
EnableExplicit
Macro Object(ObjectName, ObjectType)
 ObjectName.ObjectType#::i#ObjectType
EndMacro
;BaseClass::ShowClasses()
Define.DataSet::iDataSet *set1, *set2
Define i
Debug "Data 1"
*set1 = DataSet::New(?DataSet1)
For i = 0 To *set1\Count() - 1
 Debug *set1\Get(i)
Next
Debug "----------------"
Debug "Data 2"
*set2 = DataSet::New(?DataSet2)
For i = 0 To *set2\Count() - 1
 Debug *set2\Get(i)
Next
DataSection
 DataSet1:
 Data.s "Sontag"
 Data.s "Montag"
 Data.s "Dienstag"
 Data.s "Mittwoch"
 Data.s "Donnerstag"
 Data.s "Freitag"
 Data.s "Samstag"
 Data.i 0
 
 DataSet2:
 Data.s "Januar"
 Data.s "Februar"
 Data.s "März"
 Data.s "April"
 Data.s "Mai"
 Data.s "Juni"
 Data.s "Juli"
 Data.s "August"
 Data.s "September"
 Data.s "Oktober"
 Data.s "November"
 Data.s "Dezember"
 Data.i 0
EndDataSection

Code: Select all

...
Procedure Clone(*this.sUser)
 Protected *clone.sUser
 CloneObject(*this, *clone, sUser) 
 ProcedureReturn *clone
EndProcedure : AsMethode(Clone)
... 

Code: Select all

;-TOP
; Example 9 v1.13
CompilerIf #PB_Compiler_Thread = 0
 CompilerError "Use compiler option theadsafe"
CompilerEndIf
IncludeFile "Modul_BaseClassSmall.pb"
DeclareModule Work
 UseModule BaseClass
 
 Structure sWork Extends sBaseClass
 Value.i
 EndStructure
 
 Interface iWork Extends iBaseClass
 Add(Value)
 Sub(Value)
 EndInterface
 
 Declare New()
 
EndDeclareModule
Module Work
 
 UseModule BaseClass
 
 NewClass(iWork)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Init(*this.sWork)
 Debug "Initialize Work"
 EndProcedure : AsInitializeObject(Init)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Destroy(*this.sWork)
 Debug "Dispose Work"
 Debug "Result: " + *this\Value
 EndProcedure : AsDisposeObject(Destroy)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Add(*this.sWork, Value)
 Protected result
 LockObject(*this)
 *this\Value + Value
 result = *this\Value
 UnlockObject(*this)
 ProcedureReturn result
 EndProcedure : AsMethode(Add)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Sub(*this.sWork, Value = 0)
 Protected result
 LockObject(*this)
 *this\Value - Value
 result = *this\Value
 UnlockObject(*this)
 ProcedureReturn result
 EndProcedure : AsMethode(Sub)
 
 ; ---------------------------------------------------------------------------
 
 Procedure New()
 InitObject(sWork) ; Mehr kommt hier nicht rein!
 EndProcedure
 
 ; ---------------------------------------------------------------------------
 
 CheckInterface()
 
EndModule
; ***************************************************************************************
;-Test AddRef
Procedure thAdd(*Object.Work::iWork)
 Protected time
 *Object\AddRef()
 Delay(1000)
 ;Debug "Start"
 For i = 1 To 10
 time = Random(200)
 *Object\Add(1)
 Delay(time)
 Next
 ;Debug "Ready."
 *Object\Release()
EndProcedure
Debug "Mainscope Create Object"
Define *Object.Work::iWork
*Object = Work::New()
mutex = CreateMutex()
Debug "Start Threads"
For i = 1 To 1000
 th = CreateThread(@thAdd(), *Object)
 Delay(5)
 If th = 0
 Debug "No Thread " + i
 EndIf
Next
Debug "Mainscope Wait..."
Repeat
 Delay(200)
 ref = *Object\AddRef()
 ref = *Object\Release()
 Debug ref
 If ref = 0
 Break
 EndIf
ForEver
Debug "Mainscope Release Object"
*Object\Release()
Debug "Ready."

Code: Select all

Procedure.s CreateUuid()
 Protected Uuid.iid, result.s, i
 UuidCreate_(Uuid.iid)
 result = " DataSection" + #LF$
 result + " Uuid:" + #LF$
 result + " Data.l $" + RSet(Hex(Uuid\Data1), 8, "0") + #LF$
 result + " Data.w $" + RSet(Hex(Uuid\Data2), 4, "0") + ", $" + RSet(Hex(Uuid\Data3), 4, "0") + #LF$
 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 + #LF$
 result + " EndDataSection" + #LF$
 ProcedureReturn result
EndProcedure
; ***************************************************************************************
Uuid.s = CreateUuid()
SetClipboardText(Uuid)
Debug Uuid
Debug "Copied into clipboard"

Code: Select all

;-TOP
; Example 10 IUnknown
IncludeFile "Modul_BaseClassSmall.pb"
DeclareModule MyObject
 
 EnableExplicit
 
 Interface iMyObject Extends BaseClass::iBaseClass
 Add(Value)
 Sub(Value)
 Result()
 EndInterface
 
 Structure sMyObject Extends BaseClass::sBaseClass
 Value.i
 EndStructure
 
 ; Own Uuid
 DataSection
 IID_IMyObject:
 Data.l 3ドルC4855AF
 Data.w 3ドルAC7, 4ドルA60
 Data.b $FF, $FF, $FF, 2ドルA, 06,ドル 54,ドル 54,ドル $FF
 EndDataSection
 
 Declare New()
 
EndDeclareModule
Module MyObject
 
 EnableExplicit
 
 UseModule BaseClass
 
 NewClass(iMyObject)
 
 ; ---------------------------------------------------------------------------
 
 ; Overwrite Methode QueryInterface
 
 Procedure QueryInterface(*This.sBaseClass, *riid, *ppvObject.integer)
 Protected *new
 If *ppvObject = 0
 ProcedureReturn #E_INVALIDARG
 EndIf
 If CompareMemory(*riid, ?IID_IUnknown, 16)
 LockMutex(*This\System\Mutex)
 *ppvObject\i = *This
 *This\System\RefCount + 1
 UnlockMutex(*This\System\Mutex)
 ProcedureReturn #S_OK
 ElseIf CompareMemory(*riid, ?IID_IMyObject, SizeOf(iid))
 *new = New()
 If *new
 *ppvObject\i = *new
 ProcedureReturn #S_OK
 Else 
 ProcedureReturn #E_OUTOFMEMORY
 EndIf
 Else ; No Interface
 ProcedureReturn #E_NOINTERFACE
 EndIf
 EndProcedure : AsNewMethode(QueryInterface)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Initialize(*this.sMyObject)
 Debug "Initialize Object " + Hex(*this)
 EndProcedure : AsInitializeObject(Initialize)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Dispose(*this.sMyObject)
 Debug "Dispose Object " + Hex(*this)
 EndProcedure : AsDisposeObject(Dispose)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Add(*this.sMyObject, Value)
 *this\Value + Value
 EndProcedure : AsMethode(Add)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Sub(*this.sMyObject, Value)
 *this\Value - Value
 EndProcedure : AsMethode(Sub)
 
 ; ---------------------------------------------------------------------------
 
 Procedure Result(*this.sMyObject)
 ProcedureReturn *this\Value
 EndProcedure : AsMethode(Result)
 
 ; ---------------------------------------------------------------------------
 
 Procedure New()
 InitObject(sMyObject)
 EndProcedure
 
 ; ---------------------------------------------------------------------------
 
 DataSection
 IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}'
 Data.l 00000000ドル
 Data.w 0000,ドル 0000ドル 
 Data.b $C0, 00,ドル 00ドル , 00ドル , 00,ドル 00ドル , 00ドル , 46ドル
 EndDataSection
 
 ; ---------------------------------------------------------------------------
 
 CheckInterface()
 
EndModule
; ***************************************************************************************
;-Test
Debug "Create Object"
Define *obj.IUnknown
*obj = MyObject::New()
Debug "--------------------------------"
r1 = *obj\QueryInterface(?IID_IUnknown, @*obj_temp)
If r1 = #S_OK
 Debug "QueryInterface IUnknown Ok: Object " + Hex(*obj)
 Debug "AddRef: " + *obj\AddRef()
 Debug "Release IUnknown: " + *obj\Release()
 Debug "Release IUnknown: " + *obj\Release()
EndIf
Debug "--------------------------------"
Define *obj2.MyObject::iMyObject
If *obj\QueryInterface(MyObject::?IID_IMyObject, @*obj2) = #S_OK
 Debug "QueryInterface IID_MyObject Ok: Object " + Hex(*obj2)
 Debug "Add 1000"
 *obj2\Add(1000)
 Debug "Sub 100"
 *obj2\Sub(100)
 Debug "Result: " + *obj2\Result()
 Debug "Relaease MyObject: " + *obj2\Release()
EndIf
Debug "--------------------------------"
If *obj\QueryInterface(?IID_IDispatch, 0) = #S_OK
 Debug "IDispatch Ok"
 Debug "Release IDispatch: " + *obj\Release()
Else
 Debug "No Interface IDispatch"
EndIf
Debug "--------------------------------"
Debug "Release Object"
Debug "Release: " + *obj\Release()
DataSection
 IID_NULL: ; {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:
 Data.l 00020400ドル
 Data.w 0000,ドル 0000ドル
 Data.b $C0,00,ドル00,ドル00,ドル00,ドル00,ドル00,ドル46ドル
 IID_IClassFactory:
 Data.l 00000001ドル
 Data.w 0000,ドル 0000ドル
 Data.b $C0, 0,ドル 0,ドル 0,ドル 0,ドル 0,ドル 0,ドル 46ドル
EndDataSection