PureBoard

Das deutsche PureBasic-Forum
https://www.purebasic.fr/german/

[Windows] Module : AddEvents

https://www.purebasic.fr/german/viewtopic.php?t=27701

Seite 1 von 2

[Windows] Module : AddEvents

Verfasst: 02.02.2014 12:49
von Bisonte
Hallo.

Als ich im engl. Forum dieses Posting las, dachte ich... das krieg ich hin...

Pustekuchen. Ich hab da das MAC OS überlesen. Mist... ;)

Vom Canvas her kennt man ja die netten Eventtypes wie MouseEnter, MouseLeave usw...
Wie wäre es denn auch bei anderen Gadgets mit diesen Types ?
Besonders das ImageGadget ist interessant, weil ein Canvas keinen AlphaKanal hat.

Wenn ein Gadget mit AE_AddEvents() registriert wurde,
sendet der interne Callback per PostEvent die Eventtypes an die EventSchleife des Fensters, die das Gadget normalerweise nicht unterstützt.

Viel Rede, kurzer Code. Sollte jemand wissen wie man dieses für Linux und Mac umsetzt... Melden ! :mrgreen:

Edit :
  • 09.06.2024
    Fast 10 Jahre später ;)
    Eine SubClass Variante ohne FreeGadget Event... weil ich es gerade brauchte.
  • 07.02.2014
    EventType Variable einstellbar (Danke TS-Soft)
    AE_SetEventType_FreeGadget(EventTypeValue) & AE_GetEventType_FreeGadget() hinzugefügt und Beispielcode angepasst.
  • 04.02.2014
    #PB_EventType_FreeGadget hinzugefügt.

Code: Alles auswählen

DeclareModule AddEvents
  
  Declare AE_AddEvents(Window, Gadget) ; Add #PB_EventTypes to a gadget
  Declare AE_GadgetMouseX(Gadget)      ; Get MouseX in a gadget (like WindowMouseX()) if AE_AddEvents() registered this gadget
  Declare AE_GadgetMouseY(Gadget)      ; Get MouseY in a gadget (like WindowMouseY()) if AE_AddEvents() registered this gadget
  Declare AE_SetEventType_FreeGadget(EventTypeValue) ; Set the EventType Value to your Custom Value
  Declare AE_GetEventType_FreeGadget()               ; Get the actual EventType Value for #EventType_FreeGadget
  
EndDeclareModule
Module        AddEvents
  
  ;:---
  ;:-
  ;:- Module : AddEvents
  ;:- OS     : Windows Only (min. XP/2000)
  ;:- Author : George Bisonte
  ;:- Date   : 01, Feb. 2014
  ;:-
  ;:- Add #PB_EventTypes to other gadgets as canvas.
  ;:-
  ;:---
  
  EnableExplicit
  
  Structure struct_addeventdata
    Window.i
    Gadget.i
    mTrack.i
    mx.i
    my.i
    OldProc.i
  EndStructure
  
  Global NewMap AE_Data.struct_addeventdata()
  Global EventType_FreeGadget = #PB_EventType_FirstCustomValue
  
  Procedure AE_SetEventType_FreeGadget(EventTypeValue)
    EventType_FreeGadget = EventTypeValue
  EndProcedure
  Procedure AE_GetEventType_FreeGadget()
    ProcedureReturn EventType_FreeGadget
  EndProcedure
  Procedure AE_SendEvent(hWnd, EType)               ; All OS
    
    Protected mPosX, mPosY, gPosLeft, gPosTop, gPosRight, gPosBottom
    
    With AE_Data(Str(hWnd))
      
      gPosLeft    = GadgetX(\Gadget, #PB_Gadget_ScreenCoordinate)
      gPosTop     = GadgetY(\Gadget, #PB_Gadget_ScreenCoordinate)
      gPosRight   = gPosLeft + GadgetWidth(\Gadget)
      gPosBottom  = gPosTop  + GadgetHeight(\Gadget)
      
      mPosX = DesktopMouseX()
      mPosY = DesktopMouseY()
      
      \mx = mPosX - gPosLeft : \my = mPosY - gPosTop
      
      PostEvent(#PB_Event_Gadget, \Window, \Gadget, EType)
      
    EndWith
    
  EndProcedure
  Procedure AE_CallBack(hWnd, uMsg, wParam, lParam) ; TRACKMOUSEEVENT, #WM_ Messages, CallWindowProc_(OldProc, hWnd, uMsg, wParam, lParam)
    
    Protected OldProc, tm.TRACKMOUSEEVENT
    
    If Not FindMapElement(AE_Data(), Str(hWnd))
      ProcedureReturn #Null
    EndIf
    
    With AE_Data(Str(hWnd))
      
      OldProc = \OldProc
      
      Select uMsg
        Case #WM_DESTROY
          AE_SendEvent(hWnd, EventType_FreeGadget)
          DeleteMapElement(AE_Data(), Str(hWnd))
          
        Case #WM_LBUTTONDOWN
          AE_SendEvent(hWnd, #PB_EventType_LeftButtonDown)
          
        Case #WM_RBUTTONDOWN
          AE_SendEvent(hWnd, #PB_EventType_RightButtonDown)
          
        Case #WM_MBUTTONDOWN
          AE_SendEvent(hWnd, #PB_EventType_MiddleButtonDown)
          
        Case #WM_LBUTTONUP
          AE_SendEvent(hWnd, #PB_EventType_LeftButtonUp)
          
        Case #WM_RBUTTONUP
          AE_SendEvent(hWnd, #PB_EventType_RightButtonUp)
          
        Case #WM_MBUTTONUP
          AE_SendEvent(hWnd, #PB_EventType_MiddleButtonUp)
          
        Case #WM_MOUSEMOVE
          If Not \mTrack
            \mTrack = #True
            tm\cbSize     = SizeOf(TRACKMOUSEEVENT)
            tm\dwFlags    = #TME_LEAVE
            tm\hwndTrack  = hWnd
            TrackMouseEvent_(@tm)
            AE_SendEvent(hWnd, #PB_EventType_MouseEnter)
            If OldProc : CallWindowProc_(OldProc, hWnd, uMsg, wParam, lParam) : EndIf
            ProcedureReturn #Null
          Else ; MouseMove
            AE_SendEvent(hWnd, #PB_EventType_MouseMove)
          EndIf
          
        Case #WM_MOUSELEAVE
          AE_SendEvent(hWnd, #PB_EventType_MouseLeave)
          \mTrack = #False : \mx = -1 : \my = -1
          ProcedureReturn #Null
          
      EndSelect
      
    EndWith
    
    If OldProc
      ProcedureReturn CallWindowProc_(OldProc, hWnd, uMsg, wParam, lParam)
    Else
      ProcedureReturn #False
    EndIf
    
  EndProcedure
  Procedure AE_AddEvents(Window, Gadget)            ; SetWindowLongPtr_(GadgetID(Gadget), #GWLP_WNDPROC, @AE_CallBack())
    
    If IsGadget(Gadget) And IsWindow(Window)
      AE_Data(Str(GadgetID(Gadget)))\Gadget  = Gadget
      AE_Data(Str(GadgetID(Gadget)))\Window  = Window
      AE_Data(Str(GadgetID(Gadget)))\mTrack  = #False
      AE_Data(Str(GadgetID(Gadget)))\mx      = -1
      AE_Data(Str(GadgetID(Gadget)))\my      = -1
      AE_Data(Str(GadgetID(Gadget)))\OldProc = SetWindowLongPtr_(GadgetID(Gadget), #GWLP_WNDPROC, @AE_CallBack())
    EndIf
    
  EndProcedure
  Procedure AE_GadgetMouseX(Gadget)                 ; All OS
    Protected Result = -1
    If IsGadget(Gadget)
      If FindMapElement(AE_Data(), Str(GadgetID(Gadget)))
        Result = AE_Data(Str(GadgetID(Gadget)))\mx
      EndIf
    EndIf
    ProcedureReturn Result
  EndProcedure
  Procedure AE_GadgetMouseY(Gadget)                 ; All OS
    Protected Result = -1
    If IsGadget(Gadget)
      If FindMapElement(AE_Data(), Str(GadgetID(Gadget)))
        Result = AE_Data(Str(GadgetID(Gadget)))\my
      EndIf
    EndIf
    ProcedureReturn Result
  EndProcedure
  
EndModule

CompilerIf #PB_Compiler_IsMainFile ; Test
  
  EnableExplicit
  
  UseModule AddEvents
  
  Enumeration #PB_EventType_FirstCustomValue; customevents
    #custom1
    #custom2
  EndEnumeration
  
  AE_SetEventType_FreeGadget(#PB_Compiler_EnumerationValue) ; <- thx ts soft
  
  Define Event, Quit
  
  Procedure MouseEnterProc()
    Debug "Enter"
  EndProcedure
  
  LoadImage(1, #PB_Compiler_Home + "Examples\Sources\Data\GeeBee2.bmp") ; Change to your Image
  
  OpenWindow(0, 0, 0, 248, 148, "Test", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
  ImageGadget(1, 10, 10, 0, 0, ImageID(1))
  
  ; Add Extra Eventtypes
  AE_AddEvents(0, 1)
  
  ; This works also now with BindGadgetEvent...
  BindGadgetEvent(1, @MouseEnterProc(), #PB_EventType_MouseEnter)
  
  Repeat
    Event = WaitWindowEvent()
    
    Select Event
      Case #WM_LBUTTONDOWN
        If AE_GadgetMouseX(1) = -1
          Debug "Not in Gadget"
        EndIf
      Case #PB_Event_CloseWindow
        Quit = 1
      Case #PB_Event_Gadget
        If EventGadget() = 1
          Select EventType()
            Case #PB_EventType_LeftButtonDown
              Debug "LeftButtonDown on x : " + Str(AE_GadgetMouseX(EventGadget())) + " y : " + Str(AE_GadgetMouseY(EventGadget()))
            Case #PB_EventType_RightButtonDown
              Debug "RightButtonDown on x : " + Str(AE_GadgetMouseX(EventGadget())) + " y : " + Str(AE_GadgetMouseY(EventGadget()))
              FreeGadget(1)
            Case #PB_EventType_MiddleButtonDown
              Debug "MiddleButtonDown on x : " + Str(AE_GadgetMouseX(EventGadget())) + " y : " + Str(AE_GadgetMouseY(EventGadget()))
            Case #PB_EventType_MouseLeave
              Debug "Leave"   
            Case AE_GetEventType_FreeGadget() ; <- thx ts soft
              Debug "FreeGadget : " + Str(EventGadget())
          EndSelect
        EndIf
    EndSelect
    
  Until Quit > 0
  
CompilerEndIf
Neue Version als SubClassing Variante (Ohne FreeGadget) :

Code: Alles auswählen

;-@TOP=========================================================================
; 
; Name ......... : AddEvents (SubClass Variant)
; File ......... : module_addevents.pbi
; Type ......... : Module
; Author ....... : George Bisonte
; CreateDate ... : 9, June 2024
; Compiler ..... : PureBasic V6.11 LTS x86/x64
; Flags ........ : Unicode/XP-Skin/UserMode/ThreadSafe
; Subsystem .... : none
; TargetOS ..... : Windows only
; License ...... : MIT License
; Link ......... : https://www.purebasic.fr/german/viewtopic.php?p=319963
; Description .. : Add extra Eventypes to an ImageGadget like the CanvasGadget
;
;==============================================================================

DeclareModule AddEvents
  
  ; Inspirated from forumposts by edel, TS-Soft, Axolotl, mk-soft in german/english forum
  
  EnableExplicit
  
  Declare.i AddImageGadgetEventTypes(Window, Gadget)  ; Register the ImageGadget
  Declare.i GetImageGadgetMouseX()                    ; Get the mouse coord from EventData()
  Declare.i GetImageGadgetMouseY()                    ; Get the mouse coord from EventData()
  
EndDeclareModule
Module        AddEvents
  
  Import "Comctl32.lib" 
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      SetWindowSubclass_(hWnd, *fnSubclass, uIdSubclass, dwRefData)  As "SetWindowSubclass" 
      GetWindowSubclass_(hWnd, *fnSubclass, uIdSubclass, *dwRefData) As "GetWindowSubclass"
      RemoveWindowSubclass_(hWnd, *fnSubclass, uIdSubclass)          As "RemoveWindowSubclass"
      DefSubclassProc_(hWnd, uMsg, wParam, lParam)                   As "DefSubclassProc"
    CompilerElse
      SetWindowSubclass_(hWnd, *fnSubclass, uIdSubclass, dwRefData)  As "_SetWindowSubclass@16" 
      GetWindowSubclass_(hWnd, *fnSubclass, uIdSubclass, *dwRefData) As "_GetWindowSubclass@16"
      RemoveWindowSubclass_(hWnd, *fnSubclass, uIdSubclass)          As "_RemoveWindowSubclass@12"
      DefSubclassProc_(hWnd, uMsg, wParam, lParam)                   As "_DefSubclassProc@16" 
    CompilerEndIf
  EndImport
  
  Enumeration 1
    #SubClass_ImageGadget
  EndEnumeration
  
  Structure s_subclassdata
    Window.i
    Gadget.i
    mTrack.i
    mx.w
    my.w
  EndStructure
  
  Procedure.w LOWORD(Value.l) 
    ProcedureReturn Value & $FFFF  
  EndProcedure 
  
  Procedure.w HIWORD(Value.l) 
    ProcedureReturn (Value >> 16) & $FFFF 
  EndProcedure 
  
  Procedure.l MAKELONG(low.w, high.w) 
    ProcedureReturn (high * $10000) | (low & $FFFF)
  EndProcedure 
  
  Procedure.i GetImageGadgetMouseX()
    Protected x.w = LOWORD(EventData())
    ProcedureReturn x
  EndProcedure
  Procedure.i GetImageGadgetMouseY()
    Protected y.w = HIWORD(EventData())
    ProcedureReturn y
  EndProcedure
  
  Procedure.i SubclassGadgetProc(hWnd, uMsg, wParam, lParam, uIdSubclass, *dwRefData.s_subclassdata)
    
    Protected tm.TRACKMOUSEEVENT, GadgetRect.RECT, eData.l
    
    If *dwRefData
      
      GetWindowRect_(hWnd, @GadgetRect)
      
      *dwRefData\mx = DesktopMouseX() - GadgetRect\left
      *dwRefData\my = DesktopMouseY() - GadgetRect\top
      
      If *dwRefData\mx < 0
        *dwRefData\mx = -1
        *dwRefData\my = -1
      EndIf
      
      eData = MAKELONG(*dwRefData\mx, *dwRefData\my)
            
      Select uMsg
          
        Case #WM_NCDESTROY ; FreeGadget
          Debug "If you want, you can add a FreeGadget Event at this point ;)"
          RemoveWindowSubclass_(hWnd, @SubclassGadgetProc(), uIdSubclass)
          FreeStructure(*dwRefData)
          
        Case #WM_LBUTTONDOWN
          PostEvent(#PB_Event_Gadget, *dwRefData\Window, *dwRefData\Gadget, #PB_EventType_LeftButtonDown, eData)
          
        Case #WM_LBUTTONUP
          PostEvent(#PB_Event_Gadget, *dwRefData\Window, *dwRefData\Gadget, #PB_EventType_LeftButtonUp, eData)
          
        Case #WM_MBUTTONDOWN
          PostEvent(#PB_Event_Gadget, *dwRefData\Window, *dwRefData\Gadget, #PB_EventType_MiddleButtonDown, eData)
          
        Case #WM_MBUTTONUP
          PostEvent(#PB_Event_Gadget, *dwRefData\Window, *dwRefData\Gadget, #PB_EventType_MiddleButtonUp, eData)
            
        Case #WM_RBUTTONDOWN
          PostEvent(#PB_Event_Gadget, *dwRefData\Window, *dwRefData\Gadget, #PB_EventType_RightButtonDown, eData)
          
        Case #WM_RBUTTONUP
          PostEvent(#PB_Event_Gadget, *dwRefData\Window, *dwRefData\Gadget, #PB_EventType_RightButtonUp, eData)
          
        Case #WM_MOUSELEAVE
          *dwRefData\mTrack = #False
          eData = MAKELONG(-1, -1)
          PostEvent(#PB_Event_Gadget, *dwRefData\Window, *dwRefData\Gadget, #PB_EventType_MouseLeave, eData)
          
        Case #WM_MOUSEMOVE
          If Not *dwRefData\mTrack
            *dwRefData\mTrack = #True
            tm\cbSize         = SizeOf(TRACKMOUSEEVENT)
            tm\dwFlags        = #TME_LEAVE
            tm\hwndTrack      = hWnd
            TrackMouseEvent_(@tm)
            PostEvent(#PB_Event_Gadget, *dwRefData\Window, *dwRefData\Gadget, #PB_EventType_MouseEnter, eData)
          Else
            PostEvent(#PB_Event_Gadget, *dwRefData\Window, *dwRefData\Gadget, #PB_EventType_MouseMove, eData)
          EndIf
          
      EndSelect
      
    EndIf
    
    ProcedureReturn DefSubclassProc_(hWnd, uMsg, wParam, lParam)
    
  EndProcedure
  
  Procedure.i AddImageGadgetEventTypes(Window, Gadget)
    
    Protected *SubClassData.s_subclassdata
    Protected Result = #False
    
    If IsWindow(Window) And IsGadget(Gadget)
      
      If GadgetType(Gadget) = #PB_GadgetType_Image
        
        *SubClassData.s_subclassdata = AllocateStructure(s_subclassdata)
        
        If *SubClassData
          
          With *SubClassData
            \Gadget = Gadget
            \Window = Window
            \mTrack = #False
            \mx     = -1
            \my     = -1
          EndWith
          
          SetWindowSubclass_(GadgetID(Gadget), @SubclassGadgetProc(), #SubClass_ImageGadget, *SubClassData)
          Result = #True 
          
        EndIf
        
      EndIf
      
    EndIf
    
    ProcedureReturn Result
    
  EndProcedure
  
EndModule

CompilerIf #PB_Compiler_IsMainFile
  
  UseModule     AddEvents
  
  LoadImage(1, #PB_Compiler_Home + "Examples\Sources\Data\GeeBee2.bmp") ; Change to your Image
  
  OpenWindow(10, 0, 0, 248, 148, "Test", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
  
  ImageGadget(7, 10, 10, 0, 0, ImageID(1))
  
  AddImageGadgetEventTypes(10, 7)
  
  Repeat
    
    Event = WaitWindowEvent()
    
    Select Event
        
      Case #PB_Event_CloseWindow
        End
        
      Case #PB_Event_Gadget
        
        If EventGadget() = 7
          
          Select EventType()
              
            Case #PB_EventType_LeftButtonUp
              Debug "LMB - Up x = " + Str(GetImageGadgetMouseX()) + " - y = " + Str(GetImageGadgetMouseY())
              
            Case #PB_EventType_LeftButtonDown
              Debug "LMB - Down x = " + Str(GetImageGadgetMouseX()) + " - y = " + Str(GetImageGadgetMouseY())
              
            Case #PB_EventType_RightButtonUp
              Debug "RMB - Up x = " + Str(GetImageGadgetMouseX()) + " - y = " + Str(GetImageGadgetMouseY())
              
            Case #PB_EventType_RightButtonDown
              Debug "RMB - Down x = " + Str(GetImageGadgetMouseX()) + " - y = " + Str(GetImageGadgetMouseY())
              
            Case #PB_EventType_MouseEnter
              Debug "Mouse Enter x = " + Str(GetImageGadgetMouseX()) + " - y = " + Str(GetImageGadgetMouseY())
              
            Case #PB_EventType_MouseLeave
              Debug "Mouse Leave x = " + Str(GetImageGadgetMouseX()) + " - y = " + Str(GetImageGadgetMouseY())
              
            Case #PB_EventType_MouseMove
              Debug "Mouse Move x = " + Str(GetImageGadgetMouseX()) + " - y = " + Str(GetImageGadgetMouseY())
              
            Case #PB_EventType_LeftClick ; The original EventTypes are also here ;)
              Debug "LeftClick"
              
          EndSelect
          
        EndIf
        
    EndSelect
    
  ForEver 
  
CompilerEndIf

Re: [Windows] Module : AddEvents

Verfasst: 02.02.2014 16:03
von walbus
:)

Re: [Windows] Module : AddEvents

Verfasst: 02.02.2014 16:15
von ts-soft
walbus hat geschrieben:"Nur" für Windows ist untertrieben
Warum? Mit dem Callback funktioniert das nur unter Windows :wink:

:allright:
sieht ganz brauchbar aus, kanns aber im moment nicht testen, falsches OS.

Gruß
Thomas

Re: [Windows] Module : AddEvents

Verfasst: 02.02.2014 17:40
von walbus
:)

Re: [Windows] Module : AddEvents

Verfasst: 04.02.2014 15:45
von Bisonte
walbus hat geschrieben:Eben drum, besser geht´s doch nimmer :allright:
Gruss Werner
Ahh... vielleicht hab ich da noch was ....

Ich habe : #PB_EventType_FreeGadget hinzugefügt.

Dieser wird... oh Wunder ;) ... gesendet, wenn ein Gadget zerstört wird (es also das #WM_Destroy Signal erhält.)
Was allerdings keinen Effekt hat, wenn das Window, auf dem das Gadget liegt, geschlossen wird...

So kann man in der EventLoop abfragen ob ein Gadget freigegeben wurde um Speicher, Fonts, Images usw. freizugeben.

Beispiel :

Code: Alles auswählen

Select WaitWindowEvent()
  Case #PB_Event_Gadget
    Select EventGadget()
      Case ImageGadgetNr
        If EventType() = #PB_EventType_FreeGadget
          Debug "Gadget : " + Str(EventGadget()) + " wurde 'entsorgt'"
          ; z.B.
          FreeImage(BildDesGadgets)
        EndIf
    EndSelect
EndSelect

Re: [Windows] Module : AddEvents

Verfasst: 04.02.2014 17:27
von ts-soft
Leider hast Du nicht beachtet, Dein Modul ist nicht der einzige Code im Programm, der benutzerdefinierte Events nutzt!

Code: Alles auswählen

  Enumeration #PB_EventType_FirstCustomValue
    #PB_EventType_FreeGadget ; This Event fired to the window if a gadget is destroyed.
  EndEnumeration
Hier Beispielcode, damit Du das Problem siehst:

Code: Alles auswählen

DeclareModule test1
  Enumeration #PB_Event_FirstCustomValue
    #test1
  EndEnumeration
  Declare btnEvent()
EndDeclareModule
Module test1
  Procedure btnEvent()
    PostEvent(#test1)
  EndProcedure
EndModule

DeclareModule test2
  Enumeration #PB_Event_FirstCustomValue
    #test2
  EndEnumeration
  Declare btnEvent()
EndDeclareModule
Module test2
  Procedure btnEvent()
    PostEvent(#test2)
  EndProcedure
EndModule

OpenWindow(0, #PB_Ignore, #PB_Ignore, 140, 100, "")
ButtonGadget(0, 10, 10, 100, 25, "test1")

ButtonGadget(1, 10, 40, 100, 25, "test2")

Repeat
  Select WaitWindowEvent()
    Case #PB_Event_CloseWindow
      Break
    Case test1::#test1
      Debug "test1"
    Case test2::#test2
      Debug "test2"
     
    Case #PB_Event_Gadget
      Select EventGadget()
        Case 0
          test1::btnEvent()
        Case 1
          test2::btnEvent()
      EndSelect
  EndSelect
ForEver
Du wirst Dir also schon einen Wert für das CustomEvent übergeben lassen müssen!
Ich persönlich erstelle im Module Main immer eine benannte Enumeration für CustomEvents und kann die dann
auch in anderen Modulen nutzen, das nutzt aber nur mir was und nur solange ich nur eigene Module nutze.

Gruß
Thomas

Re: [Windows] Module : AddEvents

Verfasst: 04.02.2014 18:42
von Bisonte
Ah ok, das Problem seh ich jetzt, allerdings fällt mir jetzt auf Anhieb nicht ein wie ich das lösen könnte....
(ausser im Source selbst zu editieren...)

Während der Laufzeit ist das schlecht mit Konstanten und Werteübergabe...

Re: [Windows] Module : AddEvents

Verfasst: 04.02.2014 18:57
von ts-soft
Eigentlich liegt die Lösung bereits in meinem erstem Posting, aber hier nochmals als Code:

Code: Alles auswählen

EnableExplicit

DeclareModule test1
  Declare SetUserEvent(nr.l)
  Declare btnEvent()
EndDeclareModule
Module test1
  EnableExplicit
  
  Global UserEvent.l
  Procedure btnEvent()
    PostEvent(UserEvent)
  EndProcedure
  
  Procedure SetUserEvent(nr.l)
    UserEvent = nr
  EndProcedure
EndModule

DeclareModule test2
  Declare SetUserEvent(nr.l)
  Declare btnEvent()
EndDeclareModule
Module test2
  EnableExplicit
  
  Global UserEvent.l
  Procedure btnEvent()
    PostEvent(UserEvent)
  EndProcedure
  
  Procedure SetUserEvent(nr.l)
    UserEvent = nr
  EndProcedure
EndModule


OpenWindow(0, #PB_Ignore, #PB_Ignore, 140, 100, "")
ButtonGadget(0, 10, 10, 100, 25, "test1")
ButtonGadget(1, 10, 40, 100, 25, "test2")

Define.l UserEvent1 = #PB_Event_FirstCustomValue
test1::SetUserEvent(UserEvent1)

Define.l UserEvent2 = UserEvent1 + 1
test2::SetUserEvent(UserEvent2)

Repeat
  Select WaitWindowEvent()
    Case #PB_Event_CloseWindow
      Break
    Case UserEvent1
      Debug "test1"
    Case UserEvent2
      Debug "test2"
     
    Case #PB_Event_Gadget
      Select EventGadget()
        Case 0
          test1::btnEvent()
        Case 1
          test2::btnEvent()
      EndSelect
  EndSelect
ForEver
Zur Sicherheit vielleicht noch den Wert des Events mit einer negativen Zahl initialisieren und Prüfen, ob dieser Positiv ist,
ansonsten wurde sie noch nicht gesetzt.

Re: [Windows] Module : AddEvents

Verfasst: 06.02.2014 12:46
von ts-soft
Nachdem meine Einwände bisher nicht umgesetzt wurden, vielleicht fehlte der genauere Bezug zu Deinem Modul, habe ich es mal
eingebaut:

Code: Alles auswählen

 DeclareModule AddEvents
 
;   Enumeration #PB_EventType_FirstCustomValue
;     #PB_EventType_FreeGadget ; This Event fired to the window if a gadget is destroyed.
;   EndEnumeration
  Global EventType_FreeGadget.l = #PB_EventType_FirstCustomValue
  
  Declare AE_AddEvents(Window, Gadget) ; Add #PB_EventTypes to a gadget
  Declare AE_GadgetMouseX(Gadget)      ; Get MouseX in a gadget (like WindowMouseX()) if AE_AddEvents() registered this gadget
  Declare AE_GadgetMouseY(Gadget)      ; Get MouseY in a gadget (like WindowMouseY()) if AE_AddEvents() registered this gadget
 
EndDeclareModule
Module        AddEvents
 
  ;:---
  ;:-
  ;:- Module : AddEvents
  ;:- OS     : Windows Only (min. XP/2000)
  ;:- Author : George Bisonte
  ;:- Date   : 01, Feb. 2014
  ;:-
  ;:- Add #PB_EventTypes to other gadgets as canvas.
  ;:-
  ;:---
 
  EnableExplicit
 
  Structure struct_addeventdata
    Window.i
    Gadget.i
    mTrack.i
    mx.i
    my.i
    OldProc.i
  EndStructure
 
  Global NewMap AE_Data.struct_addeventdata()
 
  Procedure AE_SendEvent(hWnd, EType)               ; All OS
   
    Protected mPosX, mPosY, gPosLeft, gPosTop, gPosRight, gPosBottom
   
    With AE_Data(Str(hWnd))
     
      gPosLeft    = GadgetX(\Gadget, #PB_Gadget_ScreenCoordinate)
      gPosTop     = GadgetY(\Gadget, #PB_Gadget_ScreenCoordinate)
      gPosRight   = gPosLeft + GadgetWidth(\Gadget)
      gPosBottom  = gPosTop  + GadgetHeight(\Gadget)
     
      mPosX = DesktopMouseX()
      mPosY = DesktopMouseY()
     
      \mx = mPosX - gPosLeft : \my = mPosY - gPosTop
     
      PostEvent(#PB_Event_Gadget, \Window, \Gadget, EType)
     
    EndWith
   
  EndProcedure
  Procedure AE_CallBack(hWnd, uMsg, wParam, lParam) ; TRACKMOUSEEVENT, #WM_ Messages, CallWindowProc_(OldProc, hWnd, uMsg, wParam, lParam)
   
    Protected OldProc, tm.TRACKMOUSEEVENT
   
    If Not FindMapElement(AE_Data(), Str(hWnd))
      ProcedureReturn #Null
    EndIf
   
    With AE_Data(Str(hWnd))
     
      OldProc = \OldProc
     
      Select uMsg
        Case #WM_DESTROY
          AE_SendEvent(hWnd, EventType_FreeGadget)
          DeleteMapElement(AE_Data(), Str(hWnd))
         
        Case #WM_LBUTTONDOWN
          AE_SendEvent(hWnd, #PB_EventType_LeftButtonDown)
         
        Case #WM_RBUTTONDOWN
          AE_SendEvent(hWnd, #PB_EventType_RightButtonDown)
         
        Case #WM_MBUTTONDOWN
          AE_SendEvent(hWnd, #PB_EventType_MiddleButtonDown)
         
        Case #WM_LBUTTONUP
          AE_SendEvent(hWnd, #PB_EventType_LeftButtonUp)
         
        Case #WM_RBUTTONUP
          AE_SendEvent(hWnd, #PB_EventType_RightButtonUp)
         
        Case #WM_MBUTTONUP
          AE_SendEvent(hWnd, #PB_EventType_MiddleButtonUp)
         
        Case #WM_MOUSEMOVE
          If Not \mTrack
            \mTrack = #True
            tm\cbSize     = SizeOf(TRACKMOUSEEVENT)
            tm\dwFlags    = #TME_LEAVE
            tm\hwndTrack  = hWnd
            TrackMouseEvent_(@tm)
            AE_SendEvent(hWnd, #PB_EventType_MouseEnter)
            If OldProc : CallWindowProc_(OldProc, hWnd, uMsg, wParam, lParam) : EndIf 
            ProcedureReturn #Null
          Else ; MouseMove
            AE_SendEvent(hWnd, #PB_EventType_MouseMove)
          EndIf
         
        Case #WM_MOUSELEAVE
          AE_SendEvent(hWnd, #PB_EventType_MouseLeave)
          \mTrack = #False : \mx = -1 : \my = -1
          ProcedureReturn #Null
         
      EndSelect
     
    EndWith
   
    If OldProc
      ProcedureReturn CallWindowProc_(OldProc, hWnd, uMsg, wParam, lParam)
    Else
      ProcedureReturn #False
    EndIf
   
  EndProcedure
  Procedure AE_AddEvents(Window, Gadget)            ; SetWindowLongPtr_(GadgetID(Gadget), #GWLP_WNDPROC, @AE_CallBack())
   
    If IsGadget(Gadget) And IsWindow(Window)
      AE_Data(Str(GadgetID(Gadget)))\Gadget  = Gadget
      AE_Data(Str(GadgetID(Gadget)))\Window  = Window
      AE_Data(Str(GadgetID(Gadget)))\mTrack  = #False
      AE_Data(Str(GadgetID(Gadget)))\mx      = -1
      AE_Data(Str(GadgetID(Gadget)))\my      = -1
      AE_Data(Str(GadgetID(Gadget)))\OldProc = SetWindowLongPtr_(GadgetID(Gadget), #GWLP_WNDPROC, @AE_CallBack())
    EndIf
   
  EndProcedure
  Procedure AE_GadgetMouseX(Gadget)                 ; All OS
    Protected Result = -1
    If IsGadget(Gadget)
      If FindMapElement(AE_Data(), Str(GadgetID(Gadget)))
        Result = AE_Data(Str(GadgetID(Gadget)))\mx
      EndIf
    EndIf
    ProcedureReturn Result
  EndProcedure
  Procedure AE_GadgetMouseY(Gadget)                 ; All OS
    Protected Result = -1
    If IsGadget(Gadget)
      If FindMapElement(AE_Data(), Str(GadgetID(Gadget)))
        Result = AE_Data(Str(GadgetID(Gadget)))\my
      EndIf
    EndIf
    ProcedureReturn Result
  EndProcedure
 
EndModule

CompilerIf #PB_Compiler_IsMainFile ; Test
 
  EnableExplicit

  UseModule AddEvents 
  
  Enumeration #PB_EventType_FirstCustomValue; customevents
    #custom1
    #custom2
  EndEnumeration
  EventType_FreeGadget = #PB_Compiler_EnumerationValue

  Define Event, Quit
 

 
  Procedure MouseEnterProc()
    Debug "Enter"
  EndProcedure
 
  LoadImage(1, #PB_Compiler_Home + "Examples\Sources\Data\GeeBee2.bmp") ; Change to your Image
 
  OpenWindow(0, 0, 0, 248, 148, "Test", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
  ImageGadget(1, 10, 10, 0, 0, ImageID(1))
 
  ; Add Extra Eventtypes
  AE_AddEvents(0, 1)
 
  ; This works also now with BindGadgetEvent...
  BindGadgetEvent(1, @MouseEnterProc(), #PB_EventType_MouseEnter)
 
  Repeat
    Event = WaitWindowEvent()
   
    Select Event
      Case #WM_LBUTTONDOWN
        If AE_GadgetMouseX(1) = -1
          Debug "Not in Gadget"
        EndIf
      Case #PB_Event_CloseWindow
        Quit = 1 
      Case #PB_Event_Gadget
        If EventGadget() = 1
          Select EventType()
            Case #PB_EventType_LeftButtonDown
              Debug "LeftButtonDown on x : " + Str(AE_GadgetMouseX(EventGadget())) + " y : " + Str(AE_GadgetMouseY(EventGadget()))
            Case #PB_EventType_RightButtonDown
              Debug "RightButtonDown on x : " + Str(AE_GadgetMouseX(EventGadget())) + " y : " + Str(AE_GadgetMouseY(EventGadget()))
              FreeGadget(1)
            Case #PB_EventType_MiddleButtonDown
              Debug "MiddleButtonDown on x : " + Str(AE_GadgetMouseX(EventGadget())) + " y : " + Str(AE_GadgetMouseY(EventGadget()))
            Case #PB_EventType_MouseLeave
              Debug "Leave"   
            Case EventType_FreeGadget
              Debug "FreeGadget : " + Str(EventGadget())
          EndSelect
        EndIf
    EndSelect
   
  Until Quit > 0
 
CompilerEndIf
Gruß
Thomas

Re: [Windows] Module : AddEvents

Verfasst: 07.02.2014 00:18
von Bisonte
Ah so hast du das gemeint... Ich hab da gegrübelt wie ich die Enumeration fortsetze... was natürlich nicht geht...

Ich danke Sie ;)

Edit : Ich habe bemerkt, dass der CodeCommander in letzter Zeit vermehrt wieder bei Definitionen zum .l greift, obwohl es unwichtig
ist ob Integer oder Long (Api z.B.)... Dabei hat er doch immer gepredigt... Integer ;)
Alle Zeiten sind UTC+02:00
Seite 1 von 2

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de