In der Basis gibt es zwei Module.
1. OwnGadgetFunctions als Public-Modul zum Lesen und schreiben der Properties von den eigenen Gadgets.
2. OwnGadgetCommon als Private-Modul als Basic innerhalb der eigenen Gadgets.
Folgende Prozeduren werden den eigenen Gadget zugewiesen.
- ProgEventGadget zur Verarbeitung der Events (BindGadgetEvent)
- ProgEventTimer zur Verarbeitung von Trigger (Bei bedarf. Add- and RemoveGadgetTimer)
- ProgReDraw zum zeichnen des Gadgets
- ProgProcess zum lesen oder schreiben von Properties
- ProgRelease zur Verarbeitung vor dem freigeben des Gadgets (Bei bedarf)
Jedes Gadget besteht aus einer Basis-Struktur GadgetObject. Diese kann man aber mit eignen Daten erweitern. Siehe Beispiel TextBoxGadget.
Kann man bestimmt noch optimieren. Vielleicht mal ein paar Anregungen schreiben
Update v1.09
- GadgetList auf Maps umgestellt
- Im Property kann der VarType zugewiesen werden
- Macros zum Common hinzufügt
. * _PropertyX : Legt den VarType vom Property fest
. * PropertyX : Zum vereinfachten lesen
Update v1.11
- Hinzugefügt: Set- GetAllProperty(...) als String
Update v1.12
- NewProperty zu AddProperty umbenannt
OwnGadgetBase.pb
Code: Alles auswählen
;-TOP
; Comment: Modul OwnGadgetBase
; Author : mk-soft
; Version: v1.13
; Created: 02.09.2016
; Updated: 06.10.2018
; Link :
; ***************************************************************************************
;- Declare Module Private Common
DeclareModule OwnGadgetsCommon
; -----------------------------------------------------------------------------------
;-- Common Enumerations
Enumeration ProcessState
#Nothing
#SetProperty
#GetProperty
#SetAllProperty
#GetAllProperty
#AddProperty
#RemoveProperty
EndEnumeration
; -----------------------------------------------------------------------------------
;-- Common Prototypes
Prototype ProtoEventGadget()
Prototype ProtoEventTimer(*GadgetObject)
Prototype ProtoReDraw(*GadgetObject, State)
Prototype ProtoProcess(*GadgetObject, State, PropertyName.s, Type, *Value, Index)
Prototype ProtoRelease(*GadgetObject)
; -----------------------------------------------------------------------------------
;-- Common Structures
Structure udtValue
StructureUnion
iVal.i
fltVal.f
dblVal.d
EndStructureUnion
sVal.s
EndStructure
Structure udtProperty
Type.w
Res.w
StructureUnion
iVal.i
fltVal.f
dblVal.d
EndStructureUnion
sVal.s
EndStructure
Structure udtGadgetObject
*EventGadget.ProtoEventGadget
*EventTimer.ProtoEventTimer
*ReDraw.ProtoReDraw
*Process.ProtoProcess
*Release.ProtoRelease
Window.i
Gadget.i
Type.i
Time.i
Map Property.udtProperty()
EndStructure
Global NewMap *GadgetList.udtGadgetObject()
; -----------------------------------------------------------------------------------
;-- Common Object Functions
Declare NewGadgetObject(Gadget, *GadgetObject)
Declare GetGadgetObject(Gadget)
;-- Common Timer Functions
Declare AddGadgetTimer(*GadgetObject, Timeout)
Declare RemoveGadgetTimer(*GadgetObject)
;-- Common Help Macros / SetProperty with Type
Macro _PropertyI(Name, Object=*GadgetObject)
Object\Property(Name)\Type = #PB_Integer : Object\Property()\iVal
EndMacro
Macro _PropertyS(Name, Object=*GadgetObject)
Object\Property(Name)\Type = #PB_String : Object\Property()\sVal
EndMacro
Macro _PropertyF(Name, Object=*GadgetObject)
Object\Property(Name)\Type = #PB_Float : Object\Property()\fltVal
EndMacro
Macro _PropertyD(Name, Object=*GadgetObject)
Object\Property(Name)\Type = #PB_Double : Object\Property()\dlbBal
EndMacro
;-- Common Help Macros / GetProperty
Macro PropertyI(Name, Object=*GadgetObject)
Object\Property(Name)\iVal
EndMacro
Macro PropertyS(Name, Object=*GadgetObject)
Object\Property(Name)\sVal
EndMacro
Macro PropertyF(Name, Object=*GadgetObject)
Object\Property(Name)\fltVal
EndMacro
Macro PropertyD(Name, Object=*GadgetObject)
Object\Property(Name)\dlbBal
EndMacro
; -----------------------------------------------------------------------------------
EndDeclareModule
;- Module Private Common
Module OwnGadgetsCommon
Global DoEventWindow = OpenWindow(#PB_Any, 0, 0, 0, 0, "DoGadgetEvents", #PB_Window_Invisible | #PB_Window_NoGadgets)
; -----------------------------------------------------------------------------------
Procedure NewGadgetObject(Gadget, *GadgetObject)
If FindMapElement(*GadgetList(), Hex(Gadget))
If *GadgetList()\EventGadget
UnbindGadgetEvent(*GadgetList()\Gadget, *GadgetList()\EventGadget)
EndIf
If *GadgetList()\Time
RemoveGadgetTimer(*GadgetList())
EndIf
If *GadgetList()\Release
*GadgetList()\Release(*GadgetList())
EndIf
If IsGadget(*GadgetList()\Gadget)
FreeGadget(*GadgetList()\Gadget)
EndIf
FreeStructure(*GadgetList())
DeleteMapElement(*GadgetList())
EndIf
AddMapElement(*GadgetList(), Hex(Gadget))
*GadgetList() = *GadgetObject
*GadgetList()\Window = UseGadgetList(0)
*GadgetList()\Gadget = Gadget
*GadgetList()\Type = GadgetType(Gadget)
EndProcedure
; -----------------------------------------------------------------------------------
Procedure GetGadgetObject(Gadget)
If FindMapElement(*GadgetList(), Hex(Gadget))
ProcedureReturn *GadgetList()
Else
ProcedureReturn 0
EndIf
EndProcedure
; -----------------------------------------------------------------------------------
Procedure AddGadgetTimer(*GadgetObject.udtGadgetObject, Timeout)
If Timeout
AddWindowTimer(DoEventWindow, *GadgetObject, Timeout)
*GadgetObject\Time = Timeout
Else
If *GadgetObject\Time
RemoveWindowTimer(DoEventWindow, *GadgetObject)
*GadgetObject\Time = 0
EndIf
EndIf
EndProcedure
; ---
Procedure RemoveGadgetTimer(*GadgetObject.udtGadgetObject)
If *GadgetObject\Time
RemoveWindowTimer(DoEventWindow, *GadgetObject)
*GadgetObject\Time = 0
EndIf
EndProcedure
; ---
Procedure EventGadgetTimerCB()
Protected *GadgetObject.udtGadgetObject = EventTimer()
If *GadgetObject\EventTimer
*GadgetObject\EventTimer(*GadgetObject)
EndIf
EndProcedure
BindEvent(#PB_Event_Timer, @EventGadgetTimerCB(), DoEventWindow)
; -------------------------------------------------------------------------------------
EndModule
;- End Module Private Common
; ***************************************************************************************
;- Declare Module Public Functions
DeclareModule OwnGadgetFunctions
;-- Public Global Functions
Declare DestroyWindow(Window)
Declare DestroyGadget(Gadget, WindowID = 0)
;-- Public Property Functions
Declare SetProperty(Gadget, PropertyName.s, Value.i, Index.i = 0)
Declare.i GetProperty(Gadget, PropertyName.s, Index.i = 0)
Declare SetPropertyString(Gadget, PropertyName.s, Text.s, Index.i = 0)
Declare.s GetPropertyString(Gadget, PropertyName.s, Index.i = 0)
Declare SetPropertyFloat(Gadget, PropertyName.s, Value.f, Index.i = 0)
Declare.f GetPropertyFloat(Gadget, PropertyName.s, Index.i = 0)
Declare SetPropertyDouble(Gadget, PropertyName.s, Value.d, Index.i = 0)
Declare.d GetPropertyDouble(Gadget, PropertyName.s, Index.i = 0)
Declare SetAllProperty(Gadget, Text.s, Flags = 0)
Declare.s GetAllProperty(Gadget, Flags = 0)
Declare AddProperty(Gadget, PropertyName.s, Value.i, Index.i = 0)
Declare AddPropertyString(Gadget, PropertyName.s, Text.s, Index.i = 0)
Declare AddPropertyFloat(Gadget, PropertyName.s, Value.f, Index.i = 0)
Declare AddPropertyDouble(Gadget, PropertyName.s, Value.d, Index.i = 0)
Declare.i RemoveProperty(Gadget, PropertyName.s, Index.i = 0)
EndDeclareModule
;- Module Public Functions
Module OwnGadgetFunctions
UseModule OwnGadgetsCommon
EnableExplicit
; -----------------------------------------------------------------------------------
; Bugfix for PB-Version v5.42
CompilerIf #PB_Compiler_OS = #PB_OS_MacOS And #PB_Compiler_Version <= 542
Procedure MyUseGadgetList(ID)
Protected WinID
WinID = UseGadgetList(ID) : UseGadgetList(WinID)
ProcedureReturn WinID
EndProcedure
Macro UseGadgetList(ID)
MyUseGadgetList(ID)
EndMacro
CompilerEndIf
; -----------------------------------------------------------------------------------
;-- Public Global Functions
Procedure DestroyWindow(Window)
Protected *GadgetObject.udtGadgetObject, WindowID
If IsWindow(Window)
WindowID = WindowID(Window)
ForEach *GadgetList()
If *GadgetList()\Window = WindowID
If *GadgetList()\EventGadget
UnbindGadgetEvent(*GadgetList()\Gadget, *GadgetList()\EventGadget)
EndIf
If *GadgetList()\Time
RemoveGadgetTimer(*GadgetList())
EndIf
If *GadgetList()\Release
*GadgetList()\Release(*GadgetList())
EndIf
If IsGadget(*GadgetList()\Gadget)
FreeGadget(*GadgetList()\Gadget)
EndIf
FreeStructure(*GadgetList())
DeleteMapElement(*GadgetList())
EndIf
Next
CloseWindow(Window)
EndIf
EndProcedure
; -----------------------------------------------------------------------------------
Procedure DestroyGadget(Gadget, WindowID = 0)
Protected *GadgetObject.udtGadgetObject
If Gadget = #PB_All
ForEach *GadgetList()
If WindowID = 0 Or *GadgetList()\Window = WindowID
If *GadgetList()\EventGadget
UnbindGadgetEvent(*GadgetList()\Gadget, *GadgetList()\EventGadget)
EndIf
If *GadgetList()\Time
RemoveGadgetTimer(*GadgetList())
EndIf
If *GadgetList()\Release
*GadgetList()\Release(*GadgetList())
EndIf
If IsGadget(*GadgetList()\Gadget)
FreeGadget(*GadgetList()\Gadget)
EndIf
FreeStructure(*GadgetList())
DeleteMapElement(*GadgetList())
EndIf
Next
If WindowID = 0
FreeGadget(#PB_All)
EndIf
Else
If FindMapElement(*GadgetList(), Hex(Gadget))
If *GadgetList()\EventGadget
UnbindGadgetEvent(*GadgetList()\Gadget, *GadgetList()\EventGadget)
EndIf
If *GadgetList()\Time
RemoveGadgetTimer(*GadgetList())
EndIf
If *GadgetList()\Release
*GadgetList()\Release(*GadgetList())
EndIf
FreeStructure(*GadgetList())
DeleteMapElement(*GadgetList())
EndIf
If IsGadget(Gadget)
FreeGadget(Gadget)
EndIf
EndIf
EndProcedure
; -----------------------------------------------------------------------------------
;-- Public Property Functions
Procedure SetProperty(Gadget, PropertyName.s, Value.i, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, result
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
result = \Process(*GadgetObject, #SetProperty, property, #PB_Integer, @Value, Index)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure.i GetProperty(Gadget, PropertyName.s, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, value.udtValue
Protected result.i
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
\Process(*GadgetObject, #GetProperty, property, #PB_Integer, @Value, Index)
result = value\iVal
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure SetPropertyString(Gadget, PropertyName.s, Text.s, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, result, Value.udtValue
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
Value\sVal = Text
result = \Process(*GadgetObject, #SetProperty, property, #PB_String, @Value, Index)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure.s GetPropertyString(Gadget, PropertyName.s, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, value.udtValue
Protected result.s
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
\Process(*GadgetObject, #GetProperty, property, #PB_String, @Value, Index)
result = value\sVal
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure SetPropertyFloat(Gadget, PropertyName.s, Value.f, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, result
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
result = \Process(*GadgetObject, #SetProperty, property, #PB_Float, @Value, Index)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure.f GetPropertyFloat(Gadget, PropertyName.s, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, value.udtValue
Protected result.f
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
\Process(*GadgetObject, #GetProperty, property, #PB_Float, @Value, Index)
result = value\fltVal
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure SetPropertyDouble(Gadget, PropertyName.s, Value.d, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, result
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
result = \Process(*GadgetObject, #SetProperty, property, #PB_Double, @Value, Index)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure.d GetPropertyDouble(Gadget, PropertyName.s, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, value.udtValue
Protected result.d
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
\Process(*GadgetObject, #GetProperty, property, #PB_Double, @Value, Index)
result = value\dblVal
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure SetAllProperty(Gadget, Text.s, Flags = 0)
Protected *GadgetObject.udtGadgetObject, property.s, result, Value.udtValue
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
If \Process
Value\sVal = Text
result = \Process(*GadgetObject, #SetAllProperty, property, Flags, @Value, 0)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure.s GetAllProperty(Gadget, Flags = 0)
Protected *GadgetObject.udtGadgetObject, property.s, value.udtValue
Protected result.s
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
If \Process
\Process(*GadgetObject, #GetAllProperty, property, Flags, @Value, 0)
result = value\sVal
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure AddProperty(Gadget, PropertyName.s, Value.i, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, result
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
result = \Process(*GadgetObject, #AddProperty, property, #PB_Integer, @Value, Index)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure AddPropertyString(Gadget, PropertyName.s, Text.s, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, result
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
result = \Process(*GadgetObject, #AddProperty, property, #PB_String, @Text, Index)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure AddPropertyFloat(Gadget, PropertyName.s, Value.f, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, result
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
result = \Process(*GadgetObject, #AddProperty, property, #PB_Float, @Value, Index)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure AddPropertyDouble(Gadget, PropertyName.s, Value.d, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s, result
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
result = \Process(*GadgetObject, #AddProperty, property, #PB_Double, @Value, Index)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
Procedure.i RemoveProperty(Gadget, PropertyName.s, Index.i = 0)
Protected *GadgetObject.udtGadgetObject, property.s
Protected result.i
If IsGadget(Gadget)
*GadgetObject = GetGadgetObject(Gadget)
If *GadgetObject
With *GadgetObject
property = LCase(PropertyName)
If \Process
result = \Process(*GadgetObject, #RemoveProperty, property, #Null, #Null, Index)
EndIf
EndWith
EndIf
EndIf
ProcedureReturn result
EndProcedure
; -----------------------------------------------------------------------------------
EndModule
;- End Module Public Funtions
; ***************************************************************************************