due to some discussions about VB6 compatibility here in the Forum, I thought about a way to fulfill the VB6 developers dream of functions (procedures) for several gadget and window events. So I created a quick draft for such functionality.
It is neither a finished module nor is it free from errors and bugs. But I was interested in the idea and maybe someone takes it as a start for a better version?
Here are the rules:
* Needs a dialog created with the PB Dialog library (XML dialog).
* Gadgets have to be named. Unnamed gadgets are ignored.
EventHandler.pbi
Code: Select all
; VB6-Style EventHandler Module
; Works with PB 5.46 or newer, cross platform
EnableExplicit
DeclareModule EventHandler
Structure eh_gadget
name.s
id.i
EndStructure
Structure eh_session
dialogId.i
xmlId.i
formName.s
List gadgets.eh_gadget()
EndStructure
Declare.i Init(formName.s, dialogId.i, xmlId.i)
Declare.i Loop(sessionId.i, event.i)
EndDeclareModule
Module EventHandler
Global NewList eh_sessions.eh_session()
Procedure.s _GetEventName(event.i)
If event.i = -1: ProcedureReturn "": EndIf
Protected evName.s = ""
Select event.i
Case #PB_Event_MaximizeWindow :evName.s = "MaximizeWindow"
Case #PB_Event_WindowDrop :evName.s = "WindowDrop"
Case #PB_Event_Menu :evName.s = "Menu"
Case #PB_Event_RightClick :evName.s = "RightClick"
Case #PB_Event_LeftClick :evName.s = "LeftClick"
Case #PB_Event_MoveWindow :evName.s = "MoveWindow"
Case #PB_Event_MinimizeWindow :evName.s = "MinimizeWindow"
Case #PB_Event_GadgetDrop :evName.s = "GadgetDrop"
Case #PB_Event_Gadget :evName.s = "Gadget"
Case #PB_Event_SizeWindow :evName.s = "SizeWindow"
Case #PB_Event_Timer :evName.s = "Timer"
Case #PB_Event_CloseWindow :evName.s = "CloseWindow"
Case #PB_Event_ActivateWindow :evName.s = "ActivateWindow"
Case #PB_Event_DeactivateWindow :evName.s = "DeactivateWindow"
Case #PB_Event_SysTray :evName.s = "SysTray"
Case #PB_Event_FirstCustomValue :evName.s = "FirstCustomValue"
Case #PB_Event_LeftDoubleClick :evName.s = "LeftDoubleClick"
Case #PB_Event_Repaint :evName.s = "Repaint"
Case #PB_Event_None :evName.s = "None"
Case #PB_Event_RestoreWindow :evName.s = "RestoreWindow"
Default
evName.s = "unknown event " + Str(event.i)
EndSelect
ProcedureReturn evName.s
EndProcedure
Procedure.s _GetEventTypeName(eventType.i)
If eventType.i = -1: ProcedureReturn "": EndIf
Protected evName.s = ""
Select eventType.i
Case #PB_EventType_KeyDown :evName.s = "KeyDown"
Case #PB_EventType_MouseWheel :evName.s = "MouseWheel"
Case #PB_EventType_PopupWindow :evName.s = "PopupWindow"
Case #PB_EventType_FirstCustomValue :evName.s = "FirstCustomValue"
Case #PB_EventType_LeftButtonDown :evName.s = "LeftButtonDown"
Case #PB_EventType_DragStart :evName.s = "DragStart"
Case #PB_EventType_StatusChange :evName.s = "StatusChange"
Case #PB_EventType_Input :evName.s = "Input"
Case #PB_EventType_MiddleButtonDown :evName.s = "MiddleButtonDown"
Case #PB_EventType_RightButtonDown :evName.s = "RightButtonDown"
Case #PB_EventType_LeftClick :evName.s = "LeftClick"
Case #PB_EventType_LeftDoubleClick :evName.s = "LeftDoubleClick"
Case #PB_EventType_LeftButtonUp :evName.s = "LeftButtonUp"
Case #PB_EventType_TitleChange :evName.s = "TitleChange"
Case #PB_EventType_MouseMove :evName.s = "MouseMove"
Case #PB_EventType_PopupMenu :evName.s = "PopupMenu"
Case #PB_EventType_LostFocus :evName.s = "LostFocus"
Case #PB_EventType_SizeItem :evName.s = "SizeItem"
Case #PB_EventType_Up :evName.s = "Up"
Case #PB_EventType_Down :evName.s = "Down"
Case #PB_EventType_DownloadProgress :evName.s = "DownloadProgress"
Case #PB_EventType_RightDoubleClick :evName.s = "RightDoubleClick"
Case #PB_EventType_RightClick :evName.s = "RightClick"
Case #PB_EventType_Focus :evName.s = "Focus"
Case #PB_EventType_DownloadStart :evName.s = "DownloadStart"
Case #PB_EventType_MouseLeave :evName.s = "MouseLeave"
Case #PB_EventType_MouseEnter :evName.s = "MouseEnter"
Case #PB_EventType_CloseItem :evName.s = "CloseItem"
Case #PB_EventType_ReturnKey :evName.s = "ReturnKey"
Case #PB_EventType_KeyUp :evName.s = "KeyUp"
Case #PB_EventType_Change :evName.s = "Change"
Case #PB_EventType_RightButtonUp :evName.s = "RightButtonUp"
Case #PB_EventType_DownloadEnd :evName.s = "DownloadEnd"
EndSelect
ProcedureReturn evName.s
EndProcedure
Procedure _ParseXMLJob(*CurrentNode, List gadgets.eh_gadget())
If XMLNodeType(*CurrentNode) = #PB_XML_Normal
If ExamineXMLAttributes(*CurrentNode)
While NextXMLAttribute(*CurrentNode)
If XMLAttributeName(*CurrentNode) = "name"
AddElement(gadgets())
gadgets()\name = XMLAttributeValue(*CurrentNode)
EndIf
Wend
EndIf
*ChildNode = ChildXMLNode(*CurrentNode)
While *ChildNode <> 0
_ParseXMLJob(*ChildNode, gadgets())
*ChildNode = NextXMLNode(*ChildNode)
Wend
EndIf
EndProcedure
Procedure.i _ParseXMLGadgets(xmlId.i, dialogId.i, List gadgets.eh_gadget())
ClearList(gadgets())
Protected *MainNode = MainXMLNode(xmlId.i)
If *MainNode
_ParseXMLJob(*MainNode, gadgets())
EndIf
; get all the assigned ID's
ForEach gadgets()
gadgets()\id = DialogGadget(dialogId.i, gadgets()\name)
Next
EndProcedure
; Init event handler session
Procedure.i Init(formName.s, dialogId.i, xmlId.i)
Protected sessionId.i = AddElement(eh_sessions())
With eh_sessions()
\dialogId = dialogId.i
\xmlId = xmlId.i
\formName = formName.s
_ParseXMLGadgets(xmlId.i, dialogId.i, \gadgets())
EndWith
ProcedureReturn sessionId.i
EndProcedure
Procedure.i _GetGadgetIdByName(List gadgets.eh_gadget(), gadName.s)
ForEach gadgets()
If gadgets()\name = gadName.s
ProcedureReturn gadgets()\id
EndIf
Next
ProcedureReturn -1
EndProcedure
Procedure.s _GetGadgetNameById(List gadgets.eh_gadget(), gadId.i)
ForEach gadgets()
If gadgets()\id = gadId.i
ProcedureReturn gadgets()\name
EndIf
Next
ProcedureReturn ""
EndProcedure
Procedure.s _Gadget(sessionId.i)
Protected eventType.i = EventType()
Protected evName.s = _GetEventTypeName(eventType.i)
ChangeCurrentElement(eh_sessions(), sessionId.i)
Protected formName.s = eh_sessions()\formName
Protected gadName.s = _GetGadgetNameById(eh_sessions()\gadgets(), EventGadget())
If formName.s <> "" And gadName.s <> "" And evName.s <> ""
ProcedureReturn formName.s + "_" + gadName.s + "_" + evName.s
EndIf
EndProcedure
Procedure.s _Menu(sessionId.i)
Debug "Menu"
EndProcedure
Procedure.s _Timer(sessionId.i)
ChangeCurrentElement(eh_sessions(), sessionId.i)
ProcedureReturn eh_sessions()\formName + "_Timer"
EndProcedure
Procedure.s _SysTray(sessionId.i)
ChangeCurrentElement(eh_sessions(), sessionId.i)
ProcedureReturn eh_sessions()\formName + "_SysTray"
EndProcedure
Procedure.s _GadgetDrop(sessionId.i)
ChangeCurrentElement(eh_sessions(), sessionId.i)
Protected gadName.s = _GetGadgetNameById(eh_sessions()\gadgets(), EventGadget())
ProcedureReturn eh_sessions()\formName + "_" + gadName.s + "_GadgetDrop"
EndProcedure
Procedure.s _Window(sessionId.i, event.i)
ChangeCurrentElement(eh_sessions(), sessionId.i)
ProcedureReturn eh_sessions()\formName + "_" + _GetEventName(event.i)
EndProcedure
Procedure.i Loop(sessionId.i, event.i)
Protected *callback = 0
Protected function.s = ""
Select event.i
Case #PB_Event_Gadget
function .s = _Gadget(sessionId.i)
Case #PB_Event_Menu:
function .s = _Menu(sessionId.i)
Case #PB_Event_CloseWindow, #PB_Event_ActivateWindow, #PB_Event_DeactivateWindow,
#PB_Event_FirstCustomValue, #PB_Event_LeftClick, #PB_Event_LeftDoubleClick,
#PB_Event_MaximizeWindow, #PB_Event_MinimizeWindow, #PB_Event_MoveWindow,
#PB_Event_RestoreWindow, #PB_Event_RightClick,
#PB_Event_SizeWindow, #PB_Event_WindowDrop, #PB_Event_Repaint
function .s = _Window(sessionId.i, event.i)
Case #PB_Event_Timer
function .s = _Timer(sessionId.i)
Case #PB_Event_GadgetDrop
function .s = _GadgetDrop(sessionId.i)
Case #PB_Event_SysTray
function .s = _SysTray(sessionId.i)
EndSelect
If function.s <> ""
*callback = GetRuntimeInteger(function.s + "()")
If *callback <> 0
CallFunctionFast(*callback, EventWindow(), EventGadget())
Else
; Debug function.s + " not found!"
EndIf
EndIf
EndProcedure
EndModule
Code: Select all
EnableExplicit
XIncludeFile "EventHandler.pbi"
;{ event procedures. Must be defined using the Runtime keyword!
; The functions get two parameters:
; WindowId = The ID of the window that caused the event to trigger
; GadgetId = The ID if the gadget that caused the event to trigger
; They may be set but they do not have to be! I suggest to verify them
; using IsGadget() and IsWindow() in case you can't be sure that it is
; given.
; --------------------------------------------------------------------
Runtime Procedure frmMain_btnOK_LeftClick(win.i, gadget.i)
Debug "btnOK was clicked!"
EndProcedure
Runtime Procedure frmMain_btnCancel_LeftClick(win.i, gadget.i)
Debug "btnCancel was clicked!"
EndProcedure
Runtime Procedure frmMain_SizeWindow(win.i, gadget.i)
Debug "Window was resized"
EndProcedure
Runtime Procedure frmMain_strContent_Change(win.i, gadget.i)
If IsGadget(gadget.i)
Debug "Someone changed strContent: '" + GetGadgetText(gadget.i) + "'"
EndIf
EndProcedure
Runtime Procedure frmMain_CloseWindow(win.i, gadget.i)
Debug "Window was closed"
End
EndProcedure
;} --------------------------------------------------------------------
Procedure main()
Protected Event.i
Protected a.s = ""
a + "<window id='#PB_Any' name='frmMain' text='test' minwidth='400' minheight='auto' flags='#PB_Window_ScreenCentered | #PB_Window_SystemMenu | #PB_Window_SizeGadget'>" +
" <vbox expand='item:2' align='left'>"+
" <string name='strContent' height='50' flags='' />"+
" <vbox>"+
" <button name='btnOK' text='OK' />"+
" <button name='btnCancel' text='Cancel' />"+
" </vbox>"+
" </vbox>"+
"</window>"
CompilerIf #PB_Compiler_Unicode
Protected xml.i = CatchXML(#PB_Any, @a, StringByteLength(a), #PB_XML_StreamStart, #PB_Unicode)
CompilerElse
Protected xml.i = CatchXML(#PB_Any, @a, StringByteLength(a), #PB_XML_StreamStart, #PB_Ascii)
CompilerEndIf
Protected d.i = CreateDialog(#PB_Any)
Protected w.i = OpenXMLDialog(d.i, xml.i, "")
; init EventHandler
Protected ehSession.i = EventHandler::Init("frmMain", d.i, xml.i)
; The program main loop
Repeat
Event.i = WaitWindowEvent()
EventHandler::Loop(ehSession.i, Event.i); use EventHandler
; do some other stuff here
Until Event.i = #PB_Event_CloseWindow
EndProcedure
main()
Would be happy about any feedback or if someone enhances the module. I doubt I will find the time to continue this. So, if it is helpful for someone, please keep us updated