It is currently Sun Jul 05, 2020 8:55 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 9 posts ] 
Author Message
 Post subject: Module System (PB-Internals)
PostPosted: Sat Jun 08, 2019 10:50 am 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2535
Location: Germany
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)

Code:
;-TOP

; Comment : Module System
; Author  : mk-soft
; Version : v1.04.1
; Create  : 30.03.2019
; Update  : 26.01.2020

; 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 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 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
 
  ; ---------------------------------------------------------------------------------------
 
  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 GetParentWindowID(Gadget)
    Protected GadgetID, 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
          GadgetID = GadgetID(Gadget)
          WindowID = gtk_widget_get_toplevel_ (GadgetID)
        CompilerCase #PB_OS_Windows
          GadgetID = GadgetID(Gadget)
          WindowID = GetAncestor_(GadgetID, #GA_ROOT)
      CompilerEndSelect
    EndIf
    ProcedureReturn WindowID
  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 MouseOver() ; Result 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)
        ; 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
 
  ; ---------------------------------------------------------------------------
 
EndModule

;- Example
CompilerIf #PB_Compiler_IsMainFile
 
  UseModule System
 
  Macro GetWindow(Gadget)
    WindowPB(GetParentWindowID(Gadget))
  EndMacro
 
  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
 
 
  If OpenWindow(1, 0, 0, 222, 280, "ButtonGadgets", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
    ButtonGadget(0, 10, 10, 200, 20, "Standard Button")
    ButtonGadget(1, 10, 40, 200, 20, "Left Button", #PB_Button_Left)
    ButtonGadget(2, 10, 70, 200, 20, "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, 20, "Toggle Button", #PB_Button_Toggle)
    ButtonImageGadget(5, 10, 200, 200, 60, LoadImage(2, #PB_Compiler_Home + "examples/sources/Data/PureBasic.bmp"))
   
    handle = WindowID(1)
    Debug "Window = " + WindowPB(handle)
   
    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)
   
    BindEvent(#PB_Event_Gadget, @DoEventGadget())
   
    Repeat
      Select WaitWindowEvent()
        Case #PB_Event_CloseWindow
          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

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Sun Jan 26, 2020 3:01 pm, edited 3 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module System (PB-Internals)
PostPosted: Sun Jun 09, 2019 4:49 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Tue Sep 22, 2009 10:41 pm
Posts: 543
Thank you mk-soft.

Is not DesktopMouse{X|Y}() cross platform ?


Top
 Profile  
Reply with quote  
 Post subject: Re: Module System (PB-Internals)
PostPosted: Sun Jun 09, 2019 8:49 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2535
Location: Germany
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 / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module System (PB-Internals)
PostPosted: Sun Jan 26, 2020 3:04 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2535
Location: Germany
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 / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module System (PB-Internals)
PostPosted: Mon Jan 27, 2020 3:31 pm 
Offline
Addict
Addict
User avatar

Joined: Sun Nov 05, 2006 11:42 pm
Posts: 4692
Location: Lyon - France
Works here, thanks for sharing 8)

_________________
ImageThe happiness is a road...
Not a destination


Top
 Profile  
Reply with quote  
 Post subject: Re: Module System (PB-Internals)
PostPosted: Mon Jan 27, 2020 6:55 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Sat May 05, 2007 5:31 pm
Posts: 737
Location: Linz, Austria
Some additional imports...
Code:
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


Top
 Profile  
Reply with quote  
 Post subject: Re: Module System (PB-Internals)
PostPosted: Mon Jan 27, 2020 9:17 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2535
Location: Germany
chi wrote:
Some additional imports...
Code:
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 / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module System (PB-Internals)
PostPosted: Mon Jan 27, 2020 10:21 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Sat May 05, 2007 5:31 pm
Posts: 737
Location: Linz, Austria
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


Top
 Profile  
Reply with quote  
 Post subject: Re: Module System (PB-Internals)
PostPosted: Tue Jan 28, 2020 10:03 pm 
Offline
PureBasic Team
PureBasic Team
User avatar

Joined: Fri Apr 25, 2003 6:14 pm
Posts: 1841
Location: Germany (Saxony, Deutscheinsiedel)
Can become useful, thank you for sharing! :D

_________________
Bye,
...André
(PureBasicTeam::Docs & Support - PureArea.net | Order:: PureBasic | PureVisionXP)


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 9 posts ] 

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 15 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye