The module solves the problem with Tab and Shift+Tab in linux and mac.
- GetPreviousGadget and GetNextGadget
Further functionalities have been added.
- Functions for Window and Gadget IDs
- MouseOver Gadget
- BindGadgetEvent and BindWindowEvent with EventData
- Named GadgetData
Update v1.08
- Bugfix Window
Update v1.09
- Added: SetAllGadgetFont(...)
Update v1.10
- Added: GetWindowList(...), GetGadgetList(...), GetImageList(...), GetFontList(...)
Update v1.11
- Added: WindowPB(...) and GadgetPB(...). Get PB-ID over handle
Update v1.12
- Added: MouseOver()
Update v1.13
- Added: BindEvent with EventData
- Added: Named GadgetData
Update v1.14
- Bugfix MouseOver
Update v1.15
- Added InitMouseOver() for Events MouseEnter and MouseLeave
- Added CheckCanvasMouse() for Events MouseClicks and MouseWheel
Update v1.17
- Added EnableGadgetDataEvent(State)
- Added Event #My_EventType_NewGadgetData and #My_EventType_ChangeGadgetData
Update v1.19
- Bugfix DebugGadgetData
Update v1.20
- Bugfix Memoryleak EventFreeMemoryPool()
Code: Select all
;-TOP
; Comment: Module Advanced Gadget Functions (AGF)
; Author : mk-soft
; Version: v1.22
; Created: 30.10.2016
; Updated: 29.09.2018
; Link : http://www.purebasic.fr/english/viewtopic.php?f=12&t=66856
;
; *************************************************************************************************
DeclareModule AGF
;- Begin of Declare Module
;TODO Check Enumeration
Enumeration $7FFFFFFF Step -1 ; #PB_Event_FirstCustomValue
#My_Event_FreeMemoryPool ; Free Memory Pool of EventData
EndEnumeration
Enumeration $7FFFFFFF Step -1 ; #PB_EventType_FirstCustomValue
; GadgetData
#My_EventType_NewGadgetData
#My_EventType_ChangeGadgetData
; CanvasGadget
#My_EventType_LeftButtonClick
#My_EventType_LeftButtonDoubleClick
#My_EventType_MiddleButtonClick
#My_EventType_MiddleButtonDoubleClick
#My_EventType_RightButtonClick
#My_EventType_RightButtonDoubleClick
#My_EventType_MouseWheelUp
#My_EventType_MouseWheelDown
EndEnumeration
; StringHelper
Declare AllocateString(String.s)
Declare.s FreeString(*mem)
; Window and Gadget Ident Functions
Declare GetParentWindowID(Gadget)
Declare GetPreviousGadget(Gadget, WindowID)
Declare GetNextGadget(Gadget, WindowID)
Declare GetWindowList(List Windows())
Declare GetGadgetList(List Gadgets(), WindowID=0)
Declare GetImageList(List Images())
Declare GetFontList(List Fonts())
Declare SetAllGadgetFont(FontID, WindowID=0)
Declare SetAllGadgetColor(ColorType, Color, WindowID=0)
Declare WindowPB(WindowID)
Declare GadgetPB(GadgetID)
; MouseOver and Event MouseEnter, MouseLeave
Declare MouseOver()
Declare InitMouseOver()
; BindEvent with EventData
Declare BindGadgetEventEx(Gadget, *Callback, EventType = #PB_All, EventData = 0)
Declare UnbindGadgetEventEx(Gadget, *Callback, EventType = #PB_All)
Declare SetGadgetEventDataEx(Gadget, *Callback, EventType = #PB_All, EventData = 0)
Declare BindWindowEventEx(Window, *Callback, Event = #PB_All, EventData = 0)
Declare UnbindWindowEventEx(Window, *Callback, Event = #PB_All)
Declare SetWindowEventDataEx(Window, *Callback, Event = #PB_All, EventData = 0)
; Named GadgetData
Declare EnableGadgetDataEvent(State)
Declare SetGadgetDataInteger(gadget, value, property.s = "Default")
Declare GetGadgetDataInteger(gadget, property.s = "Default")
Declare SetGadgetDataFloat(gadget, value.f, property.s = "Default")
Declare.f GetGadgetDataFloat(gadget, property.s = "Default")
Declare SetGadgetDataDouble(gadget, value.d, property.s = "Default")
Declare.d GetGadgetDataDouble(gadget, property.s = "Default")
Declare SetGadgetDataString(gadget, text.s, property.s = "Default")
Declare.s GetGadgetDataString(gadget, property.s = "Default")
Declare GetGadgetDataType(gadget, property.s = "Default")
Declare GetGadgetDataList(gadget, List Properties.s())
Declare FreeGadgetData(gadget)
Declare ClearGadgetData()
Declare.s DebugGadgetData(gadget, property.s = "")
; Canvas Mouse EventType
Declare CheckCanvasMouse()
;- End of Declare Module
EndDeclareModule
; ---------------------------------------------------------------------------------------
Module AGF
;- Begin of Module
EnableExplicit
;-- Import internal function
; Force Import Fonts
Global __Dummy = LoadFont(#PB_Any, "", 9) : FreeFont(__Dummy)
CompilerIf #PB_Compiler_OS = #PB_OS_Windows
Import ""
PB_Object_EnumerateStart( PB_Objects )
PB_Object_EnumerateNext( PB_Objects, *ID.Integer )
PB_Object_EnumerateAbort( PB_Objects )
PB_Object_GetObject( PB_Object , DynamicOrArrayID)
PB_Window_Objects.i
PB_Gadget_Objects.i
PB_Image_Objects.i
PB_Font_Objects.i
EndImport
CompilerElse
ImportC ""
PB_Object_EnumerateStart( PB_Objects )
PB_Object_EnumerateNext( PB_Objects, *ID.Integer )
PB_Object_EnumerateAbort( PB_Objects )
PB_Object_GetObject( PB_Object , DynamicOrArrayID)
PB_Window_Objects.i
PB_Gadget_Objects.i
PB_Image_Objects.i
PB_Font_Objects.i
EndImport
CompilerEndIf
CompilerIf #PB_Compiler_OS = #PB_OS_MacOS
; PB Interne Struktur Gadget MacOS
Structure sdkGadget
*gadget
*container
*vt
UserData.i
Window.i
Type.i
Flags.i
EndStructure
CompilerEndIf
; ---------------------------------------------------------------------------------------
;-- Stringhelper (Threaded)
Procedure AllocateString(String.s)
Protected *mem
*mem = AllocateMemory(StringByteLength(string) + SizeOf(character))
PokeS(*mem, String)
EndProcedure
Procedure.s FreeString(*mem)
Protected result.s
result = PeekS(*mem)
FreeMemory(*mem)
ProcedureReturn result
EndProcedure
; ---------------------------------------------------------------------------------------
;-- GadgetID and WindowID functions
Procedure GetParentWindowID(Gadget)
Protected GadgetID, GadgetWindowID
If IsGadget(Gadget)
CompilerSelect #PB_Compiler_OS
CompilerCase #PB_OS_MacOS
Protected *Gadget.sdkGadget = IsGadget(Gadget)
GadgetWindowID = WindowID(*Gadget\Window)
CompilerCase #PB_OS_Linux
GadgetID = GadgetID(Gadget)
GadgetWindowID = gtk_widget_get_toplevel_ (GadgetID)
CompilerCase #PB_OS_Windows
GadgetID = GadgetID(Gadget)
GadgetWindowID = GetAncestor_(GadgetID, #GA_ROOT)
CompilerEndSelect
EndIf
ProcedureReturn GadgetWindowID
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GetPreviousGadget(Gadget, WindowID)
Protected object, prev_id, type
prev_id = -1
PB_Object_EnumerateStart(PB_Gadget_Objects)
While PB_Object_EnumerateNext(PB_Gadget_Objects, @object)
type = GadgetType(object)
If type <> #PB_GadgetType_Text And type <> #PB_GadgetType_Frame
If GetParentWindowID(object) = WindowID
If gadget = object
If prev_id >= 0
PB_Object_EnumerateAbort(PB_Gadget_Objects)
Break
EndIf
Else
prev_id = object
EndIf
EndIf
EndIf
Wend
ProcedureReturn prev_id
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GetNextGadget(Gadget, WindowID)
Protected object, next_id, type
next_id = -1
PB_Object_EnumerateStart(PB_Gadget_Objects)
While PB_Object_EnumerateNext(PB_Gadget_Objects, @object)
type = GadgetType(object)
If type <> #PB_GadgetType_Text And type <> #PB_GadgetType_Frame
If GetParentWindowID(object) = WindowID
If next_id < 0
next_id = object
EndIf
If gadget = object
If PB_Object_EnumerateNext(PB_Gadget_Objects, @object)
If GetParentWindowID(object) = WindowID
next_id = object
PB_Object_EnumerateAbort(PB_Gadget_Objects)
Break
EndIf
EndIf
EndIf
EndIf
EndIf
Wend
ProcedureReturn next_id
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GetWindowList(List Windows())
Protected object
ClearList(Windows())
PB_Object_EnumerateStart(PB_Window_Objects)
While PB_Object_EnumerateNext(PB_Window_Objects, @object)
AddElement(Windows())
Windows() = object
Wend
ProcedureReturn ListSize(Windows())
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GetGadgetList(List Gadgets(), WindowID=0)
Protected object
ClearList(Gadgets())
PB_Object_EnumerateStart(PB_Gadget_Objects)
While PB_Object_EnumerateNext(PB_Gadget_Objects, @object)
If WindowID = 0 Or GetParentWindowID(object) = WindowID
AddElement(Gadgets())
Gadgets() = object
EndIf
Wend
ProcedureReturn ListSize(Gadgets())
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GetImageList(List Images())
Protected object
ClearList(Images())
PB_Object_EnumerateStart(PB_Image_Objects)
While PB_Object_EnumerateNext(PB_Image_Objects, @object)
AddElement(Images())
Images() = object
Wend
ProcedureReturn ListSize(Images())
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GetFontList(List Fonts())
Protected object
ClearList(Fonts())
PB_Object_EnumerateStart(PB_Font_Objects)
While PB_Object_EnumerateNext(PB_Font_Objects, @object)
AddElement(Fonts())
Fonts() = object
Wend
ProcedureReturn ListSize(Fonts())
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure SetAllGadgetFont(FontID, WindowID=0)
Protected gadget
PB_Object_EnumerateStart(PB_Gadget_Objects)
While PB_Object_EnumerateNext(PB_Gadget_Objects, @gadget)
If WindowID = 0 Or GetParentWindowID(gadget) = WindowID
SetGadgetFont(gadget, FontID)
EndIf
Wend
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure SetAllGadgetColor(ColorType, Color, WindowID=0)
Protected gadget
PB_Object_EnumerateStart(PB_Gadget_Objects)
While PB_Object_EnumerateNext(PB_Gadget_Objects, @gadget)
If WindowID = 0 Or GetParentWindowID(gadget) = WindowID
SetGadgetColor(gadget, ColorType, Color)
EndIf
Wend
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure WindowPB(WindowID) ; Find pb-id over handle
Protected result, window
result = -1
PB_Object_EnumerateStart(PB_Window_Objects)
While PB_Object_EnumerateNext(PB_Window_Objects, @window)
If WindowID = WindowID(window)
result = window
Break
EndIf
Wend
PB_Object_EnumerateAbort(PB_Window_Objects)
ProcedureReturn result
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GadgetPB(GadgetID) ; Find pb-id over handle
Protected result, gadget
result = -1
PB_Object_EnumerateStart(PB_Gadget_Objects)
While PB_Object_EnumerateNext(PB_Gadget_Objects, @gadget)
If GadgetID = GadgetID(gadget)
result = gadget
Break
EndIf
Wend
PB_Object_EnumerateAbort(PB_Gadget_Objects)
ProcedureReturn result
EndProcedure
; ---------------------------------------------------------------------------------------
; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;-- MouseOver and Event MouseEnter, MouseLeave
Procedure MouseOver()
Protected handle, window
window = GetActiveWindow()
If window < 0
ProcedureReturn
EndIf
; Get handle under mouse
CompilerSelect #PB_Compiler_OS
CompilerCase #PB_OS_Windows
handle = WindowFromPoint_(DesktopMouseY() << 32 | DesktopMouseX())
CompilerCase #PB_OS_MacOS
Protected win_id, win_cv, pt.NSPoint
win_id = WindowID(window)
win_cv = CocoaMessage(0, win_id, "contentView")
CocoaMessage(@pt, win_id, "mouseLocationOutsideOfEventStream")
handle = CocoaMessage(0, win_cv, "hitTest:@", @pt)
CompilerCase #PB_OS_Linux
Protected desktop_x, desktop_y, *GdkWindow.GdkWindowObject
*GdkWindow.GdkWindowObject = gdk_window_at_pointer_(@desktop_x,@desktop_y)
If *GdkWindow
gdk_window_get_user_data_(*GdkWindow, @handle)
Else
handle = 0
EndIf
CompilerEndSelect
ProcedureReturn handle
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure MouseOverTimerCB()
Static handle, lasthandle, window, lastwindow, gadget, lastgadget = -1
handle = MouseOver()
If handle <> lasthandle
; Do only is handle change
window = GetActiveWindow()
;--- PB-ID from handle
gadget = GadgetPB(handle)
If gadget <> lastgadget
If lastgadget >= 0
If GadgetType(lastgadget) <> #PB_GadgetType_Canvas
PostEvent(#PB_Event_Gadget, lastwindow, lastgadget, #PB_EventType_MouseLeave)
EndIf
EndIf
If gadget >= 0
If GadgetType(gadget) <> #PB_GadgetType_Canvas
PostEvent(#PB_Event_Gadget, window, gadget, #PB_EventType_MouseEnter)
EndIf
EndIf
lastwindow = window
lastgadget = gadget
EndIf
lasthandle = handle
EndIf
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure InitMouseOver()
Static MyEventWindow, IsInit
If Not IsInit
IsInit = #True
MyEventWindow = OpenWindow(#PB_Any, 0, 0, 0, 0, "MyEvents", #PB_Window_NoActivate | #PB_Window_NoGadgets | #PB_Window_Invisible)
BindEvent(#PB_Event_Timer, @MouseOverTimerCB(), MyEventWindow, $EEEE)
AddWindowTimer(MyEventWindow, $EEEE, 100)
EndIf
EndProcedure
; ---------------------------------------------------------------------------------------
; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;-- BindEvent with EventData
Prototype protoBindGadgetCB(EventData)
Prototype protoBindWindowCB(EventData)
Structure udtGadgetEvent
Gadget.i
EventType.i
EventData.i
*Callback.protoBindGadgetCB
EndStructure
Structure udtWindowEvent
Window.i
Event.i
EventData.i
*Callback.protoBindWindowCB
EndStructure
Global NewList GadgetEventList.udtGadgetEvent()
Global NewList WindowEventList.udtWindowEvent()
Global ActiveGadgetEvent
Global ActiveWindowEvent
Declare BindAllWindowEvent(*Callback)
Declare UnbindAllWindowEvent(*Callback)
; ---------------------------------------------------------------------------------------
Procedure EventHandlerGadgetCB()
Protected Gadget = EventGadget()
Protected EventType = EventType()
ForEach GadgetEventList()
With GadgetEventList()
If \Gadget = Gadget
If \EventType = EventType Or \EventType = #PB_All
\Callback(\EventData)
EndIf
EndIf
EndWith
Next
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure BindGadgetEventEx(Gadget, *Callback, EventType = #PB_All, EventData = 0)
LastElement(GadgetEventList())
AddElement(GadgetEventList())
With GadgetEventList()
\Gadget = Gadget
\EventType = EventType
\EventData = EventData
\Callback = *Callback
EndWith
If Not ActiveGadgetEvent
ActiveGadgetEvent = #True
BindEvent(#PB_Event_Gadget, @EventHandlerGadgetCB())
EndIf
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure UnbindGadgetEventEx(Gadget, *Callback, EventType = #PB_All)
ForEach GadgetEventList()
With GadgetEventList()
If \Gadget = Gadget
If \Callback = *Callback
If \EventType = EventType
DeleteElement(GadgetEventList())
EndIf
EndIf
EndIf
EndWith
Next
If ListSize(GadgetEventList()) = 0
ActiveGadgetEvent = #False
UnbindEvent(#PB_Event_Gadget, @EventHandlerGadgetCB())
EndIf
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure SetGadgetEventDataEx(Gadget, *Callback, EventType = #PB_All, EventData = 0)
Protected old_eventdata
ForEach GadgetEventList()
With GadgetEventList()
If \Gadget = Gadget
If \Callback = *Callback
If \EventType = EventType
old_eventdata = \EventData
\EventData = EventData
Break
EndIf
EndIf
EndIf
EndWith
Next
ProcedureReturn old_eventdata
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure EventHandlerWindowCB()
Protected Window = EventWindow()
Protected Event = Event()
ForEach WindowEventList()
With WindowEventList()
If \Window = Window
If \Event = Event Or \Event = #PB_All
\Callback(\EventData)
EndIf
EndIf
EndWith
Next
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure BindWindowEventEx(Window, *Callback, Event = #PB_All, EventData = 0)
LastElement(WindowEventList())
AddElement(WindowEventList())
With WindowEventList()
\Window = Window
\Event = Event
\EventData = EventData
\Callback = *Callback
EndWith
If Not ActiveWindowEvent
ActiveWindowEvent = #True
BindAllWindowEvent(@EventHandlerWindowCB())
EndIf
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure UnbindWindowEventEx(Window, *Callback, Event = #PB_All)
ForEach WindowEventList()
With WindowEventList()
If \Window = Window
If \Callback = *Callback
If \Event = Event
DeleteElement(WindowEventList())
EndIf
EndIf
EndIf
EndWith
Next
If ListSize(WindowEventList()) = 0
ActiveWindowEvent = #False
UnbindAllWindowEvent(@EventHandlerWindowCB())
EndIf
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure SetWindowEventDataEx(Window, *Callback, Event = #PB_All, EventData = 0)
Protected old_eventdata
ForEach WindowEventList()
With WindowEventList()
If \Window = Window
If \Callback = *Callback
If \Event = Event
old_eventdata = \EventData
\EventData = EventData
Break
EndIf
EndIf
EndIf
EndWith
Next
ProcedureReturn old_eventdata
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure BindAllWindowEvent(*Callback)
BindEvent(#PB_Event_Menu, *Callback)
BindEvent(#PB_Event_Gadget, *Callback)
BindEvent(#PB_Event_SysTray, *Callback)
BindEvent(#PB_Event_Timer, *Callback)
BindEvent(#PB_Event_CloseWindow, *Callback)
BindEvent(#PB_Event_Repaint, *Callback)
BindEvent(#PB_Event_SizeWindow, *Callback)
BindEvent(#PB_Event_MoveWindow, *Callback)
BindEvent(#PB_Event_MinimizeWindow, *Callback)
BindEvent(#PB_Event_MaximizeWindow, *Callback)
BindEvent(#PB_Event_RestoreWindow, *Callback)
BindEvent(#PB_Event_ActivateWindow, *Callback)
BindEvent(#PB_Event_DeactivateWindow, *Callback)
BindEvent(#PB_Event_GadgetDrop, *Callback)
BindEvent(#PB_Event_WindowDrop, *Callback)
BindEvent(#PB_Event_LeftClick, *Callback)
BindEvent(#PB_Event_LeftDoubleClick, *Callback)
BindEvent(#PB_Event_RightClick, *Callback)
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure UnbindAllWindowEvent(*Callback)
UnbindEvent(#PB_Event_Menu, *Callback)
UnbindEvent(#PB_Event_Gadget, *Callback)
UnbindEvent(#PB_Event_SysTray, *Callback)
UnbindEvent(#PB_Event_Timer, *Callback)
UnbindEvent(#PB_Event_CloseWindow, *Callback)
UnbindEvent(#PB_Event_Repaint, *Callback)
UnbindEvent(#PB_Event_SizeWindow, *Callback)
UnbindEvent(#PB_Event_MoveWindow, *Callback)
UnbindEvent(#PB_Event_MinimizeWindow, *Callback)
UnbindEvent(#PB_Event_MaximizeWindow, *Callback)
UnbindEvent(#PB_Event_RestoreWindow, *Callback)
UnbindEvent(#PB_Event_ActivateWindow, *Callback)
UnbindEvent(#PB_Event_DeactivateWindow, *Callback)
UnbindEvent(#PB_Event_GadgetDrop, *Callback)
UnbindEvent(#PB_Event_WindowDrop, *Callback)
UnbindEvent(#PB_Event_LeftClick, *Callback)
UnbindEvent(#PB_Event_LeftDoubleClick, *Callback)
UnbindEvent(#PB_Event_RightClick, *Callback)
EndProcedure
; ---------------------------------------------------------------------------------------
; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;-- Named gadget data
Structure udtGadgetData
type.i
StructureUnion
iVal.i
fltVal.f
dblVal.d
EndStructureUnion
text.s
EndStructure
Structure udtGadgetDataSet
gadget.i
Map ds.udtGadgetData()
EndStructure
Global NewMap GadgetData.udtGadgetDataSet()
Global MutexGadgetData = CreateMutex()
Global IsEventGadgetData
; ---------------------------------------------------------------------------------------
Procedure EventFreeMemoryPool()
Protected *property.string = EventData()
FreeStructure(*property)
EndProcedure
BindEvent(#My_Event_FreeMemoryPool, @EventFreeMemoryPool())
; ---------------------------------------------------------------------------------------
Procedure EnableGadgetDataEvent(State)
If Bool(State)
IsEventGadgetData = #True
Else
IsEventGadgetData = #False
EndIf
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure SetGadgetDataInteger(gadget, value.i, property.s = "Default")
Protected key.s, IsProperty, *Map.udtGadgetDataSet, *property.String
LockMutex(MutexGadgetData)
key = Hex(gadget)
*map = FindMapElement(GadgetData(), key)
If *map = 0
*map = AddMapElement(GadgetData(), key)
EndIf
If *map
IsProperty = FindMapElement(*map\ds(), property)
*map\gadget = gadget
*map\ds(property)\type = #PB_Integer
*map\ds(property)\iVal = value
If IsEventGadgetData
*property = AllocateStructure(String)
*property\s = property
If IsProperty
PostEvent(#PB_Event_Gadget, 0, Gadget, #My_EventType_ChangeGadgetData, *property)
Else
PostEvent(#PB_Event_Gadget, 0, Gadget, #My_EventType_NewGadgetData, *property)
EndIf
PostEvent(#My_Event_FreeMemoryPool, 0, Gadget, 0, *property)
EndIf
EndIf
UnlockMutex(MutexGadgetData)
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GetGadgetDataInteger(gadget, property.s = "Default")
Protected r1.i, *Map.udtGadgetDataSet
LockMutex(MutexGadgetData)
*map = FindMapElement(GadgetData(), Hex(gadget))
If *map
r1 = *Map\ds(property)\iVal
Else
r1 = 0
EndIf
UnlockMutex(MutexGadgetData)
ProcedureReturn r1
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure SetGadgetDataFloat(gadget, value.f, property.s = "Default")
Protected key.s, IsProperty, *Map.udtGadgetDataSet, *property.string
LockMutex(MutexGadgetData)
key = Hex(gadget)
*map = FindMapElement(GadgetData(), key)
If *map = 0
*map = AddMapElement(GadgetData(), key)
EndIf
If *map
IsProperty = FindMapElement(*map\ds(), property)
*map\gadget = gadget
*map\ds(property)\type = #PB_Float
*map\ds(property)\fltVal = value
If IsEventGadgetData
*property = AllocateStructure(String)
*property\s = property
If IsProperty
PostEvent(#PB_Event_Gadget, 0, Gadget, #My_EventType_ChangeGadgetData, *property)
Else
PostEvent(#PB_Event_Gadget, 0, Gadget, #My_EventType_NewGadgetData, *property)
EndIf
PostEvent(#My_Event_FreeMemoryPool, 0, Gadget, 0, *property)
EndIf
EndIf
UnlockMutex(MutexGadgetData)
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure.f GetGadgetDataFloat(gadget, property.s = "Default")
Protected r1.f, *Map.udtGadgetDataSet
LockMutex(MutexGadgetData)
*map = FindMapElement(GadgetData(), Hex(gadget))
If *map
r1 = *Map\ds(property)\fltVal
Else
r1 = 0.0
EndIf
UnlockMutex(MutexGadgetData)
ProcedureReturn r1
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure SetGadgetDataDouble(gadget, value.d, property.s = "Default")
Protected key.s, IsProperty, *Map.udtGadgetDataSet, *property.string
LockMutex(MutexGadgetData)
key = Hex(gadget)
*map = FindMapElement(GadgetData(), key)
If *map = 0
*map = AddMapElement(GadgetData(), key)
EndIf
If *map
IsProperty = FindMapElement(*map\ds(), property)
*map\gadget = gadget
*map\ds(property)\type = #PB_Double
*map\ds(property)\dblVal = value
If IsEventGadgetData
*property = AllocateStructure(String)
*property\s = property
If IsProperty
PostEvent(#PB_Event_Gadget, 0, Gadget, #My_EventType_ChangeGadgetData, *property)
Else
PostEvent(#PB_Event_Gadget, 0, Gadget, #My_EventType_NewGadgetData, *property)
EndIf
PostEvent(#My_Event_FreeMemoryPool, 0, Gadget, 0,*property)
EndIf
EndIf
UnlockMutex(MutexGadgetData)
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure.d GetGadgetDataDouble(gadget, property.s = "Default")
Protected r1.d, *Map.udtGadgetDataSet
LockMutex(MutexGadgetData)
*map = FindMapElement(GadgetData(), Hex(gadget))
If *map
r1 = *Map\ds(property)\dblVal
Else
r1 = 0.0
EndIf
UnlockMutex(MutexGadgetData)
ProcedureReturn r1
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure SetGadgetDataString(gadget, text.s, property.s = "Default")
Protected key.s, IsProperty, *Map.udtGadgetDataSet, *property.String
LockMutex(MutexGadgetData)
key = Hex(gadget)
*map = FindMapElement(GadgetData(), key)
If *map = 0
*map = AddMapElement(GadgetData(), key)
EndIf
If *map
IsProperty = FindMapElement(*map\ds(), property)
*map\gadget = gadget
*map\ds(property)\type = #PB_String
*map\ds(property)\text = text
If IsEventGadgetData
*property = AllocateStructure(String)
*property\s = property
If IsProperty
PostEvent(#PB_Event_Gadget, 0, Gadget, #My_EventType_ChangeGadgetData, *property)
Else
PostEvent(#PB_Event_Gadget, 0, Gadget, #My_EventType_NewGadgetData, *property)
EndIf
PostEvent(#My_Event_FreeMemoryPool, 0, Gadget, 0, *property)
EndIf
EndIf
UnlockMutex(MutexGadgetData)
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure.s GetGadgetDataString(gadget, property.s = "Default")
Protected r1.s, *Map.udtGadgetDataSet
LockMutex(MutexGadgetData)
*map = FindMapElement(GadgetData(), Hex(gadget))
If *map
r1 = *Map\ds(property)\text
Else
r1 = ""
EndIf
UnlockMutex(MutexGadgetData)
ProcedureReturn r1
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GetGadgetDataType(gadget, property.s = "Default")
Protected r1, *Map.udtGadgetDataSet
LockMutex(MutexGadgetData)
*Map = FindMapElement(GadgetData(), Hex(gadget))
If *map
r1 = *Map\ds(property)\type
Else
r1 = 0
EndIf
UnlockMutex(MutexGadgetData)
ProcedureReturn r1
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure GetGadgetDataList(gadget, List Properties.s())
Protected r1, *Map.udtGadgetDataSet
LockMutex(MutexGadgetData)
*map = FindMapElement(GadgetData(), Hex(gadget))
If *map
ClearList(Properties())
ForEach GadgetData()
AddElement(Properties())
Properties() = MapKey(GadgetData())
Next
r1 = ListSize(Properties())
Else
r1 = 0
EndIf
UnlockMutex(MutexGadgetData)
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure FreeGadgetData(gadget)
LockMutex(MutexGadgetData)
If FindMapElement(GadgetData(), Hex(gadget))
DeleteMapElement(GadgetData())
EndIf
UnlockMutex(MutexGadgetData)
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure ClearGadgetData()
LockMutex(MutexGadgetData)
ForEach GadgetData()
If Not IsGadget(GadgetData()\gadget)
DeleteMapElement(GadgetData())
EndIf
Next
UnlockMutex(MutexGadgetData)
EndProcedure
; ---------------------------------------------------------------------------------------
Procedure.s DebugGadgetData(gadget, property.s = "")
CompilerIf #PB_Compiler_Debugger
Protected r1.s, *Map.udtGadgetDataSet, lf
LockMutex(MutexGadgetData)
*map = FindMapElement(GadgetData(), Hex(gadget))
If *map
If property = ""
r1 = ""
ForEach *map\ds()
If lf : r1 + #LF$ : EndIf
r1 + "GadgetData(" + gadget + ").Property('" + MapKey(*map\ds()) + "')."
Select *Map\ds()\type
Case #PB_Integer
r1 + "Integer = " + *map\ds()\iVal
Case #PB_Float
r1 + "Float = " + *map\ds()\fltVal
Case #PB_Double
r1 + "Double = " + *map\ds()\dblVal
Case #PB_String
r1 + "String = " + *map\ds()\text
EndSelect
lf = #True
Next
Else
If FindMapElement(*map\ds(), property)
r1 = "GadgetData(" + gadget + ").Property('" + property + "')."
Select *Map\ds()\type
Case #PB_Integer
r1 + "Integer = " + *map\ds()\iVal
Case #PB_Float
r1 + "Float = " + *map\ds()\fltVal
Case #PB_Double
r1 + "Double = " + *map\ds()\dblVal
Case #PB_String
r1 + "String = " + *map\ds()\text
EndSelect
Else
r1 = "GadgetData(" + gadget + ") Property('" + property + "') = Nothing"
EndIf
EndIf
EndIf
UnlockMutex(MutexGadgetData)
ProcedureReturn r1
CompilerEndIf
EndProcedure
; ---------------------------------------------------------------------------------------
; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;-- Canvas Mouse Events
CompilerIf #PB_Compiler_OS = #PB_OS_Windows
Procedure WinCB(hWnd, uMsg, wParam, lParam)
Protected r1 = #PB_ProcessPureBasicEvents
Protected gadget, wheel
If uMsg = #WM_MOUSEWHEEL
gadget = GadgetPB(MouseOver())
If gadget >= 0 And GadgetType(gadget) = #PB_GadgetType_Canvas
wheel = wParam >> 16 / 120
If wheel > 0
PostEvent(#PB_Event_Gadget, 0, gadget, #My_EventType_MouseWheelUp, Wheel)
Else
PostEvent(#PB_Event_Gadget, 0, gadget, #My_EventType_MouseWheelDown, Wheel)
EndIf
EndIf
EndIf
ProcedureReturn r1
EndProcedure
SetWindowCallback(@WinCB())
CompilerEndIf
; ---------------------------------------------------------------------------------------
Global DoubleClickTime = DoubleClickTime() ; ms
Global ClickTime = 200 ; ms
Procedure CheckCanvasMouse()
Static left_time1, left_time2, left_diff, left_lock
Static middle_time1, middle_time2, middle_diff, middle_lock
Static right_time1, right_time2, right_diff, right_lock
Static wheel
Select EventType()
; Left Button
Case #PB_EventType_LeftButtonDown
left_time1 = ElapsedMilliseconds()
left_diff = ElapsedMilliseconds() - left_time2
If left_time2 And left_diff > 1 And left_diff < DoubleClickTime
PostEvent(#PB_Event_Gadget, 0, EventGadget(), #My_EventType_leftButtonDoubleClick)
left_time2 = ElapsedMilliseconds() + DoubleClickTime * 3
left_lock = 1
Else
left_time2 = ElapsedMilliseconds()
EndIf
Case #PB_EventType_LeftButtonUp
If Not left_lock And (ElapsedMilliseconds() - left_time1) < ClickTime
PostEvent(#PB_Event_Gadget, 0, EventGadget(), #My_EventType_leftButtonClick)
EndIf
left_lock = 0
; Middle Button
Case #PB_EventType_MiddleButtonDown
middle_time1 = ElapsedMilliseconds()
middle_diff = ElapsedMilliseconds() - middle_time2
If middle_time2 And middle_diff > 1 And middle_diff < DoubleClickTime
PostEvent(#PB_Event_Gadget, 0, EventGadget(), #My_EventType_MiddleButtonDoubleClick)
middle_time2 = ElapsedMilliseconds() + DoubleClickTime * 3
middle_lock = 1
Else
middle_time2 = ElapsedMilliseconds()
EndIf
Case #PB_EventType_MiddleButtonUp
If Not middle_lock And (ElapsedMilliseconds() - middle_time1) < ClickTime
PostEvent(#PB_Event_Gadget, 0, EventGadget(), #My_EventType_MiddleButtonClick)
EndIf
middle_lock = 0
; Right Button
Case #PB_EventType_RightButtonDown
right_time1 = ElapsedMilliseconds()
right_diff = ElapsedMilliseconds() - right_time2
If Right_time2 And right_diff > 1 And right_diff < DoubleClickTime
PostEvent(#PB_Event_Gadget, 0, EventGadget(), #My_EventType_RightButtonDoubleClick)
right_time2 = ElapsedMilliseconds() + DoubleClickTime * 3
right_lock = 1
Else
right_time2 = ElapsedMilliseconds()
EndIf
Case #PB_EventType_RightButtonUp
If Not right_lock And (ElapsedMilliseconds() - right_time1) < ClickTime
PostEvent(#PB_Event_Gadget, 0, EventGadget(), #My_EventType_RightButtonClick)
EndIf
right_lock = 0
Case #PB_EventType_MouseWheel
wheel = GetGadgetAttribute(EventGadget(), #PB_Canvas_WheelDelta)
If wheel > 0
PostEvent(#PB_Event_Gadget, 0, EventGadget(), #My_EventType_MouseWheelUp, wheel)
Else
PostEvent(#PB_Event_Gadget, 0, EventGadget(), #My_EventType_MouseWheelDown, wheel)
EndIf
EndSelect
EndProcedure
; ---------------------------------------------------------------------------------------
;- End of Module
EndModule
; *************************************************************************************************