GFProgramMessageSystem/GFPMSmod.bas
Attribute VB_Name = "GFPMSmod"
Option Explicit
'GFProgramMessageSystem (c)2001‑2004 by Louis.
'
#Const GFPMS_ReceiveEventExEnabledFlag = False
'NOTE (above): save stuff like SE_ReceiveCallBackMessageEx(), etc.
'
'MsgTimer_Timer
Private Declare Function GetTickCount Lib "kernel32" () As Long
'general use
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
'
'THIS FORM IS PLUG‑IN CODE, DO NOT CHANGE!
'
'Note that this stuff is about to be written at the moment (does not work completely).
'
'NOTE: the GFPMS is used for the following purposes:
'‑update parts of a program system
'‑therefore events can be created that occur instantly or with a delay,
' once or permanently or if an other message has been removed
'‑any message can carry an unlimited number of parameters in the
' message param packets
'
'Public Sub GFPMS_ReceiveEvent(ByVal MsgName As String, ByRef MsgParamArray() As String, ByVal MsgParamNumber As Integer)
' 'on error resume next 'sub belonging to the GFPMS system
' '
' 'NOTE: this sub is a copy specially made fit to the target project.
' 'Add all possible MsgNames and related subs/functions below.
' '
'End Sub
'
'NOTE: as there were mysterious errors in Toricxs only when GFPMSfrm.MsgTimer
'is enabled we enable the timer merely when a message is buffered.
'
'Message constants
Public Const MSG_NORMAL_EVENT As Integer = 1
Public Const MSG_PERMANENT_EVENT_UNTIL_EVENT_REMOVE As Integer = 2
Public Const MSG_PERMANENT_EVENT_UNTIL_EVENT_ADD As Integer = 3
Public Const MSG_EVENT_AFTER_EVENT_REMOVE As Integer = 4
Public Const MSG_EVENT_AFTER_EVENT_ADD As Integer = 5
'MsgStruct
Private Type MsgStruct
MsgType As Integer
MsgwParam As String 'meaning depends on MsgType
MsglParam As String 'meaning depends on MsgType
MsgName As String
MsgPacketName As String
MsgIntervalCurrent As Long 'time since event occurred the last time (ms)
End Type
Dim MsgStructNumber As Integer
Dim MsgStructArray() As MsgStruct
'MsgPacketStruct
Private Type MsgPacketStruct
MsgPacketName As String
MsgPacketParamNumber As Integer
MsgPacketParamArray() As String
End Type
Dim MsgPacketStructNumber As Integer
Dim MsgPacketStructArray() As MsgPacketStruct
'GFPMSTimerStruct ‑ information about time that has passed
Private Type GFPMSTimerStruct
TickCountOld As Long
TickCountDelta As Long
End Type
Dim GFPMSTimerStructVar As GFPMSTimerStruct
'other
Dim MsgTimer_TimerCalledFlag As Boolean
Dim MsgTimer_TimerSubCallNumber As Long
Dim GFPMSEventTargetForm As Object
Public Function GFPMS_AllocateMessages() As Boolean
'on error resume next 'the target project can call this sub to allocate messages instantly
If GFPMSfrm.MsgTimer.Enabled = True Then 'verify (important)
Call MsgTimer_Timer
GFPMS_AllocateMessages = True 'ok
Else
GFPMS_AllocateMessages = False 'error
End If
End Function
Public Sub MsgTimer_Timer() 'called by GFPMSfrm
'On Error Resume Next 'main timer that updates the GFPMS system
Dim MsgParamArray() As String 'passed to event target form
Dim MsgParamNumber As Integer
Dim MsgName As String
Dim MsgPacketName As String
Dim MsgLoop As Integer
'
'NOTE: if staying in any DoEvents‑loop, it may be
'necessary to call this sub manually.
'
'verify
' If MsgTimer_TimerCalledFlag = True Then 'recursion required for some functions
' Exit Sub 'avoid recursive calls, lead to mysterious slow‑downs in a target project (MP3 Renamer 2), no recursion is also less dangerous (no stack overflow)
' Else
' MsgTimer_TimerCalledFlag = True
' End If
'reset
' GFPMSfrm.MsgTimer.Enabled = False 'DISABLE TIMER UNTIL NEXT MESSAGE ADD 'no, didn't work correctly. Just avoid endless loop messages
'begin
MsgTimer_TimerSubCallNumber = MsgTimer_TimerSubCallNumber + 1
'Debug.Print "MsgTimer_Timer sub call number: " + CStr(MsgTimer_TimerSubCallNumber)
'update timer values
If GFPMSTimerStructVar.TickCountOld = 0 Then GFPMSTimerStructVar.TickCountOld = GetTickCount 'at start up
GFPMSTimerStructVar.TickCountDelta = GetTickCount ‑ GFPMSTimerStructVar.TickCountOld
If GFPMSTimerStructVar.TickCountDelta < 0 Then GFPMSTimerStructVar.TickCountDelta = 0 'after 49.7 days
GFPMSTimerStructVar.TickCountOld = GetTickCount
'NOTE: we do not add MsgTimer.Interval as this sub could have been called by the target project manually.
For MsgLoop = 1 To MsgStructNumber
MsgStructArray(MsgLoop).MsgIntervalCurrent = MsgStructArray(MsgLoop).MsgIntervalCurrent + GFPMSTimerStructVar.TickCountDelta
Next MsgLoop
'raise special events if necessary
MsgLoop = 0 'reset (important)
Do 'messages could be removed
MsgLoop = MsgLoop + 1
If MsgLoop > MsgStructNumber Then Exit Do
Select Case MsgStructArray(MsgLoop).MsgType
Case MSG_NORMAL_EVENT
If MsgStructArray(MsgLoop).MsgIntervalCurrent > Val(MsgStructArray(MsgLoop).MsglParam) Then
'transfer message parameters
Call CreateMsgParamArray(MsgLoop, MsgParamArray(), MsgParamNumber, True)
'reset
'
'NOTE: the message must be removed before calling GFPMS_RaiseEvent()
'as there Msg_Remove() could be called, and another new message added.
'The new message would be removed by the following code instead of
'the current message that was processed.
'
'NOTE: if the message is removed, the related msg packet is removed,
'too. If the message is not removed automatically, also the msg packet
'must be removed manually.
'
MsgStructArray(MsgLoop).MsgIntervalCurrent = 0 'reset
Select Case Val(MsgStructArray(MsgLoop).MsgwParam)
Case ‑1
'do nothing (endless event repeat)
Case Else
MsgStructArray(MsgLoop).MsgwParam = LTrim$(Str$(Val(MsgStructArray(MsgLoop).MsgwParam) ‑ 1))
MsgName = MsgStructArray(MsgLoop).MsgName
MsgPacketName = MsgStructArray(MsgLoop).MsgPacketName
If Val(MsgStructArray(MsgLoop).MsgwParam) < 1 Then
'message and msg packet are now removed automatically
Call Msg_Remove(MsgName)
Call MsgPacket_Remove(MsgPacketName)
MsgLoop = 0 'reset
End If
End Select
'raise message event
#If GFPMS_ReceiveEventExEnabledFlag = True Then
Call Mfrm.GFPMS_ReceiveEventEx(MsgName, MsgParamArray(), MsgParamNumber)
#Else
Call GFPMSEventTargetForm.GFPMS_ReceiveEvent(MsgName, MsgParamArray(), MsgParamNumber)
#End If
'
'NOTE: call callback sub AFTER having removed message, so that the
'callback sub can add the same message again to create a permanent event.
'
End If
Case MSG_EVENT_AFTER_EVENT_REMOVE
'
'Msg_Remove will convert any MSG_EVENT_AFTER_EVENT_REMOVE message into
'a MSG_NORMAL_EVENT message, so that the original MSG_EVENT_AFTER_EVENT_REMOVE
'will be raised by the code in this sub (see above).
'As the remove function raises the event it is guaranteed that it will not be lost
'when the target project removes the related MSG_NORMAL_EVENT message manually.
'
End Select
Loop
' MsgTimer_TimerCalledFlag = False 'reset
MsgTimer_TimerSubCallNumber = MsgTimer_TimerSubCallNumber ‑ 1
Exit Sub
End Sub
Public Sub GFPMS_DefineSystemEx(ByVal MsgTimerInterval As Integer, ByRef GFPMSEventTargetFormPassed As Object)
'On Error Resume Next
GFPMSfrm.Visible = False 'load form
GFPMSfrm.Enabled = False 'load form
'
Set GFPMSEventTargetForm = GFPMSEventTargetFormPassed 'do before enabling timer
'
GFPMSfrm.MsgTimer.Interval = MsgTimerInterval
GFPMSfrm.MsgTimer.Enabled = True
End Sub
Public Function GFPMS_GetMsgTimerInterval() As Integer
'on error resume next 'returns the amount of milliseconds between each msg loop
GFPMS_GetMsgTimerInterval = GFPMSfrm.MsgTimer.Interval
End Function
Public Sub GFPMS_GetMsgParamHelp(ByVal MsgType As Integer)
'On Error Resume Next 'for debugging
Dim MsgwParamHelpText As String
Dim MsglParamHelpText As String
'begin
Select Case MsgType
Case MSG_NORMAL_EVENT
MsgwParamHelpText = "repeat number (‑1 for endless repeat, [1, 2, ...])"
MsglParamHelpText = "interval in ms or 0"
Case MSG_PERMANENT_EVENT_UNTIL_EVENT_REMOVE
MsgwParamHelpText = "name of event that must be removed to remove current event"
MsglParamHelpText = "interval in ms"
Case MSG_PERMANENT_EVENT_UNTIL_EVENT_ADD
MsgwParamHelpText = "name of event that must be added to remove current event"
MsglParamHelpText = "interval in ms"
Case MSG_EVENT_AFTER_EVENT_REMOVE
MsgwParamHelpText = "name of event that must be removed to raise current event"
MsglParamHelpText = "‑"
Case MSG_EVENT_AFTER_EVENT_ADD
MsgwParamHelpText = "name of event that must be added to raise current event"
MsglParamHelpText = "‑"
End Select
MsgBox "GFProgramMessageSystem debug information:" + Chr$(10) + "MsgwParam: " + MsgwParamHelpText + Chr$(10) + "MsglParam: " + MsglParamHelpText, vbOKOnly + vbInformation
End Sub
Private Sub CreateMsgParamArray(ByVal MsgStructIndex As Integer, ByRef MsgParamArray() As String, ByRef MsgParamNumber As Integer, ByVal RemoveMsgPacketFlag As Boolean)
'On Error Resume Next 'transfers msg packet parameters to passed array; this sub does not remove the packet
Dim MsgPacketStructIndex As Integer
Dim Temp As Long
'begin
If Not ((MsgStructIndex < 1) Or (MsgStructIndex > MsgStructNumber)) Then 'verify
With MsgStructArray(MsgStructIndex)
If .MsgPacketName = "" Then GoTo Error: 'no param packet assigned
MsgPacketStructIndex = GetMsgPacketStructIndex(.MsgPacketName)
If Not (MsgPacketStructIndex = 0) Then 'verify
'create MsgParamArray()
MsgParamNumber = MsgPacketStructArray(MsgPacketStructIndex).MsgPacketParamNumber
If Not (MsgParamNumber = 0) Then 'verify
ReDim MsgParamArray(1 To MsgParamNumber) As String
For Temp = 1 To MsgParamNumber
MsgParamArray(Temp) = MsgPacketStructArray(MsgPacketStructIndex).MsgPacketParamArray(Temp)
Next Temp
Else
ReDim MsgParamArray(1 To 1) As String 'reset
End If
'end of creating MsgParamArray()
Else
MsgBox "internal error in CreateMsgParamArray() (GFPMS): packet '" + .MsgPacketName + "' not found !", vbOKOnly + vbExclamation
GoTo Error:
End If
End With
Else
MsgBox "internal error in CreateMsgParamArray(): passed value invalid !", vbOKOnly + vbExclamation
GoTo Error:
End If
Exit Sub
Error:
MsgParamNumber = 0 'reset (error)
ReDim MsgParamArray(1 To 1) As String 'reset (error)
Exit Sub
End Sub
'******************************************MSG******************************************
'NOTE: the Msgs are the main objects of the GFPMS system.
'At the moment they are used to 'raise an event', that means when special
'conditions are fulfilled (depending on MsgType) the event target sub
'is called and the MsgName is passed.
'The msg event sub will finally call the sub that is assigned to the event (or so).
Public Sub Msg_Add(ByVal MsgName As String)
'On Error Resume Next 'creates a message of the type MSG_NORMAL_EVENT
Call Msg_AddEx(MSG_NORMAL_EVENT, "1", "1", MsgName, "")
'
'NOTE: lParam represents the time in milliseconds until a message is removed.
'Use 1 to avoid that a message having been added in GFPMS_ReceiveEvent() is
'processed instantly, but in the next MsgTimer_Timer event (see MsgTimer_Timer).
'
GFPMSfrm.MsgTimer.Enabled = True
End Sub
Public Sub Msg_AddAndPack(ByVal MsgName As String, ByVal MsgPacketParam As String)
'on error resume next 'adds message, creates a relate msg packet and adds MsgPacketParam
Call MsgPacket_Create(MsgName + " packet") 'no passed MsgName must be named like this
Call MsgPacket_AddItem(MsgName + " packet", MsgPacketParam)
Call Msg_AddEx(MSG_NORMAL_EVENT, "1", "0", MsgName, MsgName + " packet")
End Sub
Public Sub Msg_AddEx(ByVal MsgType As Integer, ByVal MsgwParam As String, ByVal MsglParam As String, ByVal MsgName As String, ByVal MsgPacketName As String)
'On Error Resume Next
'
'NOTE: the MsgType is used to determine when an event occurs,
'the MsgName is passed to the target form to know what sub is to be called.
'
'verify
If Not (MsgStructNumber = 32766) Then 'verify
MsgStructNumber = MsgStructNumber + 1
Else
MsgBox "internal error in Msg_Add() (GFPMS): overflow !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
ReDim Preserve MsgStructArray(1 To MsgStructNumber) As MsgStruct
MsgStructArray(MsgStructNumber).MsgType = MsgType
MsgStructArray(MsgStructNumber).MsgwParam = MsgwParam
MsgStructArray(MsgStructNumber).MsglParam = MsglParam
MsgStructArray(MsgStructNumber).MsgName = MsgName
MsgStructArray(MsgStructNumber).MsgPacketName = MsgPacketName
MsgStructArray(MsgStructNumber).MsgIntervalCurrent = 0
GFPMSfrm.MsgTimer.Enabled = True
End Sub
Public Function Msg_Remove(ByVal MsgName As String) As Boolean
'On Error Resume Next 'returns True if message has been removed, False if not
Dim MsgStructIndex As Integer
Dim Temp As Long
'preset
MsgStructIndex = GetMsgStructIndex(MsgName)
If MsgStructIndex = 0 Then
Msg_Remove = False 'no message removed
Exit Function 'no error (like Close #x)
End If
'begin
For Temp = MsgStructIndex To MsgStructNumber
If Not (Temp = MsgStructNumber) Then
Call CopyMemory(MsgStructArray(Temp), MsgStructArray(Temp + 1), Len(MsgStructArray(Temp + 1)))
Else
MsgStructNumber = MsgStructNumber ‑ 1
Temp = MsgStructNumber 'Temp is not in use anymore
If Temp < 1 Then Temp = 1 'verify
ReDim Preserve MsgStructArray(1 To Temp) As MsgStruct
Exit For 'important
End If
Next Temp
For Temp = 1 To MsgStructNumber
Select Case MsgStructArray(Temp).MsgType
Case MSG_EVENT_AFTER_EVENT_REMOVE
If MsgStructArray(Temp).MsgwParam = MsgName Then 'only convert messages related to the message that has been removed
MsgStructArray(Temp).MsgType = MSG_NORMAL_EVENT 'convert to be risen
MsgStructArray(Temp).MsgwParam = 0 'reset
MsgStructArray(Temp).MsglParam = 0 'reset
End If
End Select
Next Temp
Msg_Remove = True 'message has been removed
Exit Function
End Function
Public Function GetMsgStructIndex(ByVal MsgName As String) As Integer
'On Error Resume Next 'can be used to determine if a special message is existing
Dim MsgNameLength As Long
Dim Temp As Long
'preset
MsgNameLength = Len(MsgName)
'begin
For Temp = 1 To MsgStructNumber
If Len(MsgStructArray(Temp).MsgName) = MsgNameLength Then 'check first to increase speed
If MsgStructArray(Temp).MsgName = MsgName Then
GetMsgStructIndex = Temp 'ok
Exit Function
End If
End If
Next Temp
GetMsgStructIndex = 0 'error
Exit Function
End Function
'**************************************END OF MSG***************************************
'***************************************MSGPACKET***************************************
'NOTE: the MsgPacket (MsgParamPacket) is used to store values that will be passed
'to the subs related to an event.
Public Sub MsgPacket_Create(ByVal MsgPacketName As String)
'On Error Resume Next
Dim MsgPacketStructIndex As Integer
MsgPacketStructIndex = GetMsgPacketStructIndex(MsgPacketName)
If MsgPacketStructIndex = 0 Then
If Not (MsgPacketStructNumber = 32766) Then
MsgPacketStructNumber = MsgPacketStructNumber + 1
Else
MsgBox "internal error in MsgPacket_Create() (GFPMS): overflow !", vbOKOnly + vbExclamation
Exit Sub
End If
ReDim Preserve MsgPacketStructArray(1 To MsgPacketStructNumber) As MsgPacketStruct
MsgPacketStructArray(MsgPacketStructNumber).MsgPacketName = MsgPacketName
MsgPacketStructArray(MsgPacketStructNumber).MsgPacketParamNumber = 0 'reset
ReDim MsgPacketStructArray(MsgPacketStructNumber).MsgPacketParamArray(1 To 1) As String
Else
'do nothing (packet already exists)
End If
End Sub
Public Sub MsgPacket_AddItem(ByVal MsgPacketName As String, ByVal MsgPacketParam As String)
'On Error Resume Next
Dim MsgPacketStructIndex As Integer
MsgPacketStructIndex = GetMsgPacketStructIndex(MsgPacketName)
If Not (MsgPacketStructIndex = 0) Then 'verify
With MsgPacketStructArray(MsgPacketStructIndex)
.MsgPacketParamNumber = .MsgPacketParamNumber + 1
ReDim Preserve .MsgPacketParamArray(1 To .MsgPacketParamNumber) As String
.MsgPacketParamArray(.MsgPacketParamNumber) = MsgPacketParam
End With
Else
MsgBox "internal error in MsgPacket_AddItem() (GFPMS): passed packet name '" + MsgPacketName + "' invalid !", vbOKOnly + vbExclamation
End If
End Sub
Public Function MsgPacket_Remove(ByVal MsgPacketName As String) As Boolean
'On Error Resume Next 'returns True if a msg packet has been removed, False if not
Dim MsgPacketStructIndex As Integer
Dim Temp As Long
MsgPacketStructIndex = GetMsgPacketStructIndex(MsgPacketName)
If Not (MsgPacketStructIndex = 0) Then 'verify
For Temp = MsgPacketStructIndex To MsgPacketStructNumber
If Not (Temp = MsgPacketStructNumber) Then
'NOTE: CopyMemory() cannot be used as then in tests error #10
'('array locked') appeared (?!?).
MsgPacketStructArray(Temp) = MsgPacketStructArray(Temp + 1)
Else
MsgPacketStructNumber = MsgPacketStructNumber ‑ 1
Temp = MsgPacketStructNumber 'Temp not in use anymore
If Temp < 1 Then Temp = 1 'verify
ReDim Preserve MsgPacketStructArray(1 To Temp) As MsgPacketStruct
Exit For 'important
End If
Next Temp
MsgPacket_Remove = True 'one packet removed
Else
'do nothing (no error, like Close #x)
MsgPacket_Remove = False 'no packet removed
End If
End Function
Public Function GetMsgPacketParam(ByVal MsgPacketName As String, ByVal MsgPacketParamIndex As Integer) As String
'On Error Resume Next 'returns previously added parameter or nothing
Dim MsgPacketStructIndex As Integer
'
'NOTE: using this sub is not recommended as param packets are removed
'automatically when the msg target sub is called (parameters are then passed anyway).
'Call this sub to get parameters only when the msg timer event has not occurred yet.
'
MsgPacketStructIndex = GetMsgPacketStructIndex(MsgPacketName)
If Not (MsgPacketStructIndex = 0) Then 'verify
If Not ((MsgPacketParamIndex < 1) Or (MsgPacketParamIndex > MsgPacketStructArray(MsgPacketStructIndex).MsgPacketParamNumber)) Then 'verify
GetMsgPacketParam = MsgPacketStructArray(MsgPacketStructIndex).MsgPacketParamArray(MsgPacketParamIndex)
Else
GetMsgPacketParam = "" 'reset (error)
End If
Else
GetMsgPacketParam = "" 'reset (error)
End If
End Function
Private Function GetMsgPacketStructIndex(ByVal MsgPacketName As String) As Integer
'On Error Resume Next
Dim MsgPacketNameLength As Long
Dim Temp As Long
'preset
MsgPacketNameLength = Len(MsgPacketName)
'begin
For Temp = 1 To MsgPacketStructNumber
If Len(MsgPacketStructArray(Temp).MsgPacketName) = MsgPacketNameLength Then 'check first to increase speed
If MsgPacketStructArray(Temp).MsgPacketName = MsgPacketName Then
GetMsgPacketStructIndex = Temp 'ok
Exit Function
End If
End If
Next Temp
GetMsgPacketStructIndex = 0 'error
Exit Function
End Function
'***********************************END OF MSGPACKET************************************
[END OF FILE]