Module System (PB-Internals)

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

Module System (PB-Internals)

Post by mk-soft »

Here is a cleaned module with system functions which is needed from time to time

Update v1.02
- Added ImagePB

Update v1.03
- Added MouseOver

Update v1.04
- Optimize MouseOver (Windows)

Update v1.05
- Optimize force compiler use fonts
- CleanUp code

Update v1.06
- Optimize code

Update v1.07
- Added FontPB. Get PB Font ID from font handle

Update v1.08
- Support C-BackEnd (Windows PB v6.0 Alpha)

Update v1.09
- Fix Support C-BackEnd (Windows PB v6.0 Alpha 2)

Update v1.09.2
- Remove Fix Support C-BackEnd (Windows PB v6.0 Alpha 2)

Code: Select all

;-TOP

; ***************************************************************************************
;
; Comment : Module System
; Author  : mk-soft
; Version : v1.09.2
; Create  : 30.03.2019
; Update  : 10.12.2021
;
; Link DE : https://www.purebasic.fr/german/viewtopic.php?f=8&t=31380
; Link EN : https://www.purebasic.fr/english/viewtopic.php?f=12&t=72980
;
; OS      : All
;
; ***************************************************************************************

DeclareModule System
  ;- Begin of Declare Module
  
  Declare WindowPB(WindowID)
  Declare GadgetPB(GadgetID)
  Declare ImagePB(ImageID)
  Declare FontPB(FontID)
  
  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 MouseOver()
  
  ;- End of Declare Module
EndDeclareModule

; ---------------------------------------------------------------------------------------

Module System
  ;- Begin of Module
  
  EnableExplicit
  
  ;-- Import internal function
  
  ; Force Import Font Objects
  If 0 : LoadFont(0, "", 9) : EndIf
  
  ; ---------------------------------------------------------------------------------------
  
  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
      PB_Gadget_Objects
      PB_Image_Objects
      PB_Font_Objects
    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 Internal Structure Gadget MacOS
    Structure sdkGadget
      *gadget
      *container
      *vt
      UserData.i
      Window.i
      Type.i
      Flags.i
    EndStructure
  CompilerEndIf
  
  ; ---------------------------------------------------------------------------------------
  
  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
  
  ; ---------------------------------------------------------------------------------------
  
  Procedure ImagePB(ImageID) ; Find pb-id over handle
    Protected result, image
    result = -1
    PB_Object_EnumerateStart(PB_Image_Objects)
    While PB_Object_EnumerateNext(PB_Image_Objects, @image)
      If ImageID = ImageID(image)
        result = image
        Break
      EndIf
    Wend
    PB_Object_EnumerateAbort(PB_Image_Objects)
    ProcedureReturn result
  EndProcedure
  
  ; ---------------------------------------------------------------------------------------
  
  Procedure FontPB(FontID) ; Find pb-id over handle
    Protected result, font
    result = -1
    PB_Object_EnumerateStart(PB_Font_Objects)
    While PB_Object_EnumerateNext(PB_Font_Objects, @font)
      If FontID = FontID(font)
        result = font
        Break
      EndIf
    Wend
    PB_Object_EnumerateAbort(PB_Font_Objects)
    ProcedureReturn result
  EndProcedure
  
  ; ---------------------------------------------------------------------------------------
  
  Procedure GetParentWindowID(Gadget) ; Retval handle
    Protected WindowID
    
    If IsGadget(Gadget)
      CompilerSelect #PB_Compiler_OS
        CompilerCase #PB_OS_MacOS
          Protected *Gadget.sdkGadget = IsGadget(Gadget)
          WindowID = WindowID(*Gadget\Window)
        CompilerCase #PB_OS_Linux
          WindowID = gtk_widget_get_toplevel_(GadgetID(Gadget))
        CompilerCase #PB_OS_Windows           
          WindowID = GetAncestor_(GadgetID(Gadget), #GA_ROOT)
      CompilerEndSelect
    EndIf
    ProcedureReturn WindowID
  EndProcedure
  
  ; ---------------------------------------------------------------------------------------
  
  Procedure GetPreviousGadget(Gadget, WindowID) ; Retval pb-id
    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) ; Retval pb-id
    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()) ; Retval count of 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) ; Retval count of gadgets
    Protected object
    ClearList(Gadgets())
    PB_Object_EnumerateStart(PB_Gadget_Objects)
    
    If WindowID = 0
      While PB_Object_EnumerateNext(PB_Gadget_Objects, @object)
        AddElement(Gadgets())
        Gadgets() = object
      Wend
    Else 
      While PB_Object_EnumerateNext(PB_Gadget_Objects, @object)
        If GetParentWindowID(object) = WindowID
          AddElement(Gadgets())
          Gadgets() = object
        EndIf
      Wend
    EndIf
    ProcedureReturn ListSize(Gadgets())
  EndProcedure
  
  ; ---------------------------------------------------------------------------------------
  
  Procedure GetImageList(List Images()) ; Retval count of 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()) ; Retval count of 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 MouseOver() ; Retval handle
    Protected handle, window
    window = GetActiveWindow()
    If window < 0
      ProcedureReturn 0
    EndIf
    ; Get handle under mouse
    CompilerSelect #PB_Compiler_OS
      CompilerCase #PB_OS_Windows
        Protected pt.q
        GetCursorPos_(@pt)
        handle = WindowFromPoint_(pt)
      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
  
  ; ---------------------------------------------------------------------------
  
  ;- End Of Module
  
EndModule

;- Example
CompilerIf #PB_Compiler_IsMainFile
  
  UseModule System
  
  ; ----
  
  Procedure CheckMouseOver()
    Static last_handle = 0
    Static last_gadget = -1
    
    Protected handle, gadget
    
    handle = MouseOver()
    If handle <> last_handle
      last_handle = handle
      If last_gadget >= 0
        If GadgetType(last_gadget) <> #PB_GadgetType_Canvas
          PostEvent(#PB_Event_Gadget, GetActiveWindow(), last_gadget, #PB_EventType_MouseLeave)
        EndIf
        last_gadget = -1
      EndIf
      If handle
        gadget = GadgetPB(handle)
        If gadget >= 0
          If GadgetType(gadget) <> #PB_GadgetType_Canvas
            PostEvent(#PB_Event_Gadget, GetActiveWindow(), gadget, #PB_EventType_MouseEnter)
          EndIf
          last_gadget = gadget
        EndIf
      EndIf
    EndIf
    
    ProcedureReturn last_gadget
    
  EndProcedure
  
  ; ----
  
  Procedure DoEventGadget()
    Select EventType()
      Case #PB_EventType_MouseEnter
        Debug "Mouse enter: Window = " + EventWindow() + " / Gadget = " + EventGadget()
      Case #PB_EventType_MouseLeave
        Debug "Mouse leave: Window = " + EventWindow() + " / Gadget = " + EventGadget()
    EndSelect
  EndProcedure
  
  ; ----
  
  LoadFont(1, "Arial", 12)
  
  OpenWindow(#PB_Any, 0, 0, 0, 0, "Events", #PB_Window_Invisible)
  
  
  If OpenWindow(1, 0, 0, 222, 280, "ButtonGadgets", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
    ButtonGadget(0, 10, 10, 200, 25, "Standard Button")
    ButtonGadget(1, 10, 40, 200, 25, "Left Button", #PB_Button_Left)
    ButtonGadget(2, 10, 70, 200, 25, "Right Button", #PB_Button_Right)
    ButtonGadget(3, 10,100, 200, 60, "Multiline Button  (längerer Text wird automatisch umgebrochen)", #PB_Button_MultiLine)
    ButtonGadget(4, 10,170, 200, 25, "Toggle Button", #PB_Button_Toggle)
    ButtonImageGadget(5, 10, 200, 200, 60, LoadImage(2, #PB_Compiler_Home + "examples/sources/Data/PureBasic.bmp"))
    
    SetGadgetFont(4, FontID(1))
    
    handle = WindowID(1)
    Debug "Window = " + WindowPB(handle)
    Debug "Gadget = " + GadgetPB(GadgetID(4))
    
    NewList Gadgets()
    Debug "Count of Gadgegts = " + GetGadgetList(Gadgets())
    ForEach Gadgets()
      Debug "Text of Gadget " + Gadgets() + " = " + GetGadgetText(Gadgets())
    Next
    
    handle = GetParentWindowID(3)
    Debug "Parent window handle from gadget 3 = " + GetParentWindowID(3)
    Debug "PB WindowID from handle " + handle + " = " + WindowPB(handle)
    
    handle = GetGadgetAttribute(5, #PB_Button_Image)
    Debug "Image handle from gadget 5 = " + handle
    Debug "PB ImageID from handle " + handle + " = " + ImagePB(handle)
    
    Debug "PB FontID from Gadget 4 = " + FontPB(GetGadgetFont(4))
    
    BindEvent(#PB_Event_Gadget, @DoEventGadget())
    
    Repeat
      Select WaitWindowEvent()
        Case #PB_Event_CloseWindow
          CloseWindow(1)
          Break
        Case #PB_Event_Gadget
          Select EventGadget()
            Case 0
              Select EventType()
                Case #PB_EventType_LeftClick
                  Debug "Standard Button - LeftClick"
                Case #PB_EventType_MouseEnter
                  Debug "Standard Button - MouseEnter"
                Case #PB_EventType_MouseLeave
                  Debug "Standard Button - MouseLeave"
              EndSelect
          EndSelect
          
        Default
          CheckMouseOver()
          
      EndSelect
    ForEver
    
    
    
  EndIf
CompilerEndIf
Last edited by mk-soft on Tue May 10, 2022 5:09 pm, edited 15 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
Olliv
Enthusiast
Enthusiast
Posts: 542
Joined: Tue Sep 22, 2009 10:41 pm

Re: Module System (PB-Internals)

Post by Olliv »

Thank you mk-soft.

Is not DesktopMouse{X|Y}() cross platform ?
User avatar
mk-soft
Always Here
Always Here
Posts: 5333
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module System (PB-Internals)

Post by mk-soft »

Olliv wrote:Thank you mk-soft.

Is not DesktopMouse{X|Y}() cross platform ?
Needs only for windows. For macOS its better use CocoaMessages and Linux don't need it.

Update v1.04
- Optimize MouseOver (Windows)
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: 5333
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module System (PB-Internals)

Post by mk-soft »

Update v1.04.1
- Update Example

The example function CheckMouseOver send over PostEvent the EventType MouseEnter and MouseLeave :wink:
Don't forget now check event type LeftClick for Buttons
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
Kwai chang caine
Always Here
Always Here
Posts: 5342
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: Module System (PB-Internals)

Post by Kwai chang caine »

Works here, thanks for sharing 8)
ImageThe happiness is a road...
Not a destination
User avatar
chi
Addict
Addict
Posts: 1028
Joined: Sat May 05, 2007 5:31 pm
Location: Linz, Austria

Re: Module System (PB-Internals)

Post by chi »

Some additional imports...

Code: Select all

Import ""
  PB_Window_GetID(hWnd)         ; same as WindowPB(WindowID)
  PB_Window_CenterWindow(hWnd)  ; center window
  PB_Gadget_GetRootWindow(hWnd) ; same as GetParentWindowID(Gadget)
EndImport
Et cetera is my worst enemy
User avatar
mk-soft
Always Here
Always Here
Posts: 5333
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module System (PB-Internals)

Post by mk-soft »

chi wrote:Some additional imports...

Code: Select all

Import ""
  PB_Window_GetID(hWnd)         ; same as WindowPB(WindowID)
  PB_Window_CenterWindow(hWnd)  ; center window
  PB_Gadget_GetRootWindow(hWnd) ; same as GetParentWindowID(Gadget)
EndImport
Just tested.
Unfortunately not available on all OS :(

PB_Window_GetID not exists on Linux
PB_Gadget_GetRootWindow not exists on macOS
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
chi
Addict
Addict
Posts: 1028
Joined: Sat May 05, 2007 5:31 pm
Location: Linz, Austria

Re: Module System (PB-Internals)

Post by chi »

mk-soft wrote:Just tested.
Unfortunately not available on all OS :(

PB_Window_GetID not exists on Linux
PB_Gadget_GetRootWindow not exists on macOS
Yup, I'm only on Windows :shock:
Et cetera is my worst enemy
User avatar
Andre
PureBasic Team
PureBasic Team
Posts: 2056
Joined: Fri Apr 25, 2003 6:14 pm
Location: Germany (Saxony, Deutscheinsiedel)
Contact:

Re: Module System (PB-Internals)

Post by Andre »

Can become useful, thank you for sharing! :D
Bye,
...André
(PureBasicTeam::Docs & Support - PureArea.net | Order:: PureBasic | PureVisionXP)
User avatar
mk-soft
Always Here
Always Here
Posts: 5333
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module System (PB-Internals)

Post by mk-soft »

Update v1.05
- Optimize force compiler use fonts
- CleanUp code

: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
User avatar
Martt
User
User
Posts: 15
Joined: Sat Dec 23, 2017 4:03 pm
Location: The Netherlands

Re: Module System (PB-Internals)

Post by Martt »

mk-soft wrote:Here is a cleaned module with system functions which is needed from time to time

Code: Select all

  ; Force Import Fonts
  If 0 : LoadFont(0, "", 9) : EndIf
If 0 doesn't get executed. What is this supposed todo ?
User avatar
mk-soft
Always Here
Always Here
Posts: 5333
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module System (PB-Internals)

Post by mk-soft »

Martt wrote:
mk-soft wrote:Here is a cleaned module with system functions which is needed from time to time

Code: Select all

  ; Force Import Fonts
  If 0 : LoadFont(0, "", 9) : EndIf
If 0 doesn't get executed. What is this supposed todo ?
Even if LoadFont is not called, force the compiler to load the PB Object #PB_Font_Objects
If you don't do this, it will lead to a compiler error (Linux, macOS)
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: 5333
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module System (PB-Internals)

Post by mk-soft »

Update v1.06
- Optimize code
: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
User avatar
mk-soft
Always Here
Always Here
Posts: 5333
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module System (PB-Internals)

Post by mk-soft »

Update v1.07
- Added FontPB. Get PB Font ID from font handle
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: 5333
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module System (PB-Internals)

Post by mk-soft »

Update v1.08
- Support C-BackEnd (Windows PB v6.0 Alpha)

: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