DP Tool Club 31/CDASC_31_1996_juillet_aout.iso/vrac/mcvbehtp.zip/VBEHTP30.BAS

BASIC Source File | 1996-05-16 | 15KB | 442 lines

Option Explicit

Global Const VB_LNG_FRENCH = 1
Global Const VB_LNG_DUTCH = 2
Global Const VB_LNG_GERMAN = 3
Global Const VB_LNG_ENGLISH = 4
Global Const VB_LNG_ITALIAN = 5
Global Const VB_LNG_SPANISH = 6
Global Const VB_LNG_CATALAN = 7
Global Const VB_LNG_POLISH = 8

Const MB_MESSAGE_LEFT = 0

Declare Sub cPushID Lib "mcvb3016.dll" (IDArray As Integer, ByVal nID As Integer)
Declare Sub cPopID Lib "mcvb3016.dll" (IDArray As Integer, ByVal nID As Integer)
Declare Sub cPopLastID Lib "mcvb3016.dll" (IDArray As Integer)
Declare Function cGetID Lib "mcvb3016.dll" (IDArray As Integer, ByVal nPosition As Integer) As Integer
Declare Sub cClearID Lib "mcvb3016.dll" (IDArray As Integer)
Declare Sub cChangeChars Lib "mcvb3016.dll" (Txt As String, charSet As String, newCharSet As String)
Declare Function cGetIni Lib "mcvb3016.dll" (ByVal AppName As String, ByVal szItem As String, ByVal szDefault As String, ByVal InitFile As String) As String
Declare Function cInsertBlocks Lib "mcvb3016.dll" (Txt As String, Insert As String) As String
Declare Function cLngMsgBox Lib "mcvb3016.dll" (ByVal nLanguage As Integer, ByVal Message As String, ByVal Button As Long, ByVal Title As String) As Integer
Declare Function cKillFileAll Lib "mcvb3016.dll" (ByVal lpFilename As String) As Integer
Declare Function cTimerClose Lib "mcvb3016.dll" (ByVal TimerHandle As Integer) As Integer
Declare Function cTimerOpen Lib "mcvb3016.dll" () As Integer
Declare Function cTimerRead Lib "mcvb3016.dll" (ByVal TimerHandle As Integer) As Long
Declare Function cTimerStart Lib "mcvb3016.dll" (ByVal TimerHandle As Integer) As Integer

'Don't change any variables and their value below

Const ID_ITEMS = 16

Type tagERRORHANDLERtype
   ModuleName                       As String * 256
   RoutineHandle                    As String * 4
   RoutineName                      As String * 76
   CrLf                             As String * 2
End Type

Type tagTRACERtype
   StartStop                        As String * 1
   RoutineHandle                    As Integer
End Type

Type tagPROFILERtype
   ModuleName                       As String * 256
   RoutineHandle                    As String * 4
   RoutineName                      As String * 76
   TimeCounter                      As Long
   TotalCall                        As Long
   TotalTime                        As Long
   MinimumTime                      As Long
   MaximumTime                      As Long
   Dummy                            As String * 10
   CrLf                             As String * 2
End Type

Dim TotalRoutines                   As Integer
Dim ActualTrace                     As Long
Dim OldStartRoutine                 As Integer
Dim OldStopRoutine                  As Integer

Dim FileTR                          As String
Dim FilePF                          As String

Dim chanFileTR                      As Integer
Dim chanFilePF                      As Integer

Dim FileLNG                         As String

Dim FileHND                         As String

Dim FileLOG                         As String

Dim IDArray(0 To ID_ITEMS)          As Integer

Dim Language                        As Integer
Dim AutoLog                         As Integer
Dim WaitingTimeForReaction          As Integer
Dim DefaultButton                   As Integer
Dim DisplayOnline                   As Integer
Dim TraceProfile                    As Integer

Dim TotalSameHandle                 As Long
Dim LastHandle                      As Integer
Dim ChanHandle                      As Integer
Dim OldChanHandle                   As Integer

Dim tagERRORHANDLER                 As tagERRORHANDLERtype
Dim tagTRACER                       As tagTRACERtype
Dim tagPROFILER                     As tagPROFILERtype

Sub mcClearID ()
   Call cClearID(IDArray(0))
End Sub

Function mcGetID (nPos As Integer)
   mcGetID = cGetID(IDArray(0), nPos)
End Function

Function mcGetLanguageID (LanguageID As Integer) As String

   Dim RetLanguage      As String

   Select Case LanguageID
      Case VB_LNG_FRENCH
         RetLanguage = "VFR"
      Case VB_LNG_DUTCH
         RetLanguage = "VNL"
      Case VB_LNG_GERMAN
         RetLanguage = "VDE"
      Case VB_LNG_ENGLISH
         RetLanguage = "VUK"
      Case VB_LNG_ITALIAN
         RetLanguage = "VIT"
      Case VB_LNG_SPANISH
         RetLanguage = "VSP"
      Case VB_LNG_CATALAN
         RetLanguage = "VCA"
      Case VB_LNG_POLISH
         RetLanguage = "VPO"
      Case Else
         RetLanguage = "VUK"
   End Select

   If (LanguageID > 0) Then
      Language = LanguageID
   Else
      Language = VB_LNG_ENGLISH
   End If

   mcGetLanguageID = RetLanguage

End Function

Function mcIDErrorHandler (nErr As Integer) As Integer

   ' check if this a correct Error passed
   If (nErr = 0) Then
      'if no, resume next
      mcIDErrorHandler = True
      Exit Function
   End If

   Dim RoutineCount     As Integer
   Dim RoutineNumber    As Integer
   Dim RoutineStack     As String
   Dim TotalRoutines    As Integer
   Dim BlankLines       As Integer
   Dim Chan             As Integer
   Dim StopExit         As Integer
   Dim TimeOut          As Long
   Dim ButtonsConfig    As Integer
   Dim ErrorTitle       As String

   '  some initializations
   RoutineStack = ""
   TotalRoutines = 0
   BlankLines = 0
   StopExit = False
   ButtonsConfig = 0
   ErrorTitle = ""
   RoutineStack = RoutineStack + mcReadText("0", "")

   ' find the next valid unused file number.
   Chan = FreeFile

   ' open the file with the definition of each routines (file must be in the WINDOWS directory)
   Close #Chan
   Open FileHND For Random Shared As #Chan Len = Len(tagERRORHANDLER)

   ' get the stack of the routines
   For RoutineCount = 0 To ID_ITEMS
      ' get the number of the routine
      RoutineNumber = mcGetID(RoutineCount)
      ' if there a valid routine number
      If (RoutineNumber > 0) Then
         ' yes, read the definition of the routine
         Get #Chan, RoutineNumber, tagERRORHANDLER
         ' form the stack of the routines founden to display
         RoutineStack = RoutineStack + Left$(tagERRORHANDLER.ModuleName + Space$(12), 14) + Chr$(9) + tagERRORHANDLER.RoutineHandle + Chr$(9) + Trim$(tagERRORHANDLER.RoutineName) + Chr$(13)
         ' count the routines to display
         TotalRoutines = TotalRoutines + 1
      Else
         ' no, exit from reading the stack
         Exit For
      End If
   Next RoutineCount

   ' close the open file
   Close #Chan

   ' check if the default button must be activated
   If (DefaultButton = True) Then
      ' yes, RETRY and CANCEL with RETRY is the default
      ButtonsConfig = 5 Or 0
   Else
      ' no, RETRY and CANCEL with CANCEL is the default
      ButtonsConfig = 5 Or 256
      ' yes, add text for RETRY after timeout or action
      RoutineStack = RoutineStack & Chr$(13) & Chr$(13) & "program will be stopped"
   End If

   ' set the error title
   ErrorTitle = mcReadText("1", nErr & "~" & Error$(nErr))

   ' check if one routine has been founded
   If (Len(RoutineStack) > 0) Then
      ' check the time out
      TimeOut = WaitingTimeForReaction * (163840 Or 524288)
      ' display remaining blank lines
      BlankLines = (8 - TotalRoutines) - (TimeOut = 0)
      For RoutineCount = 0 To BlankLines
         RoutineStack = RoutineStack + Chr$(13)
      Next RoutineCount
      ' add some text for management
      RoutineStack = RoutineStack & mcReadText("2", "")
      ' check if a timeout must be used
      If (TimeOut <> 0) Then
         ' yes, add text depending of the default button
         RoutineStack = RoutineStack & mcReadText("3", "") & " "
         ' if default is RETRY then display 'continue' else 'stop'
         If (DefaultButton = True) Then
            RoutineStack = RoutineStack & mcReadText("4", "")
         Else
            RoutineStack = RoutineStack & mcReadText("5", "")
         End If
      End If
      ' display the error message box
      StopExit = (cLngMsgBox(Language, RoutineStack, MB_MESSAGE_LEFT Or TimeOut Or ButtonsConfig Or 16, ErrorTitle) = 2)
      ' yield process
      DoEvents
   End If

   ' check if an auto logging must be performed
   If (AutoLog = True) Then

      ' open the logging file in append mode
      Close #Chan
      Open FileLOG For Append Shared As #Chan

      ' save the error and his description
      Print #Chan, ErrorTitle; " "; mcReadText("6", Date$ & "~" & Time$)
      Print #Chan, ""
      ' save the full stack name of each routines founden
      Print #Chan, RoutineStack
      Print #Chan, ""
      ' check if the CANCEL button pushed or TimeOut
      If (StopExit = True) Then
         ' yes stop by operator, save text for CANCEL
         Print #Chan, mcReadText("7", "")
      Else
         ' no, retry by operator, save text for RETRY
         Print #Chan, mcReadText("8", "")
      End If
      ' save separator
      Print #Chan, String$(78, "-")

      ' close the file
      Close #Chan

   End If

   ' if stop the program the END the application
   If (StopExit = True) Then End

   ' no stop, resumes to next line in the main application
   mcIDErrorHandler = True

End Function

Sub mcOnlineDisplay (ID As Integer)

   Dim ActualLine    As String

   If (ChanHandle = -1) Then

      ' close the old chan if more than 1 mcInitID is called
      If (OldChanHandle <> -1) Then Close #OldChanHandle

      ' find the next valid unused file number.
      ChanHandle = FreeFile

      ' open the file with the definition of each routines (file must be in the WINDOWS directory)
      Close #ChanHandle
      Open FileHND For Random Shared As #ChanHandle Len = Len(tagERRORHANDLER)

      ' save the handle
      OldChanHandle = ChanHandle

   End If

   ' read the handle
   Get #ChanHandle, ID, tagERRORHANDLER

   If (LastHandle = ID) Then
      TotalSameHandle = TotalSameHandle + 1
   Else
      If (frmDisplayOnline.lstOnline.ListIndex > -1) Then
         ActualLine = frmDisplayOnline.lstOnline.List(frmDisplayOnline.lstOnline.ListIndex)
         frmDisplayOnline.lstOnline.List(frmDisplayOnline.lstOnline.ListIndex) = TotalSameHandle & Mid$(ActualLine, InStr(ActualLine, Chr$(9)))
      End If
      TotalSameHandle = 1
   End If

   frmDisplayOnline.lblCounter = TotalSameHandle
   frmDisplayOnline.lblHandle = ID

   If (LastHandle <> ID) Then
      frmDisplayOnline.lstOnline.AddItem TotalSameHandle & Chr$(9) & Trim$(tagERRORHANDLER.RoutineHandle) & Chr$(9) & Trim$(tagERRORHANDLER.ModuleName) & Chr$(9) & Trim$(tagERRORHANDLER.RoutineName)
      If (frmDisplayOnline.lstOnline.ListCount > 25) Then frmDisplayOnline.lstOnline.RemoveItem 0
      frmDisplayOnline.lstOnline.ListIndex = frmDisplayOnline.lstOnline.NewIndex
   End If

   LastHandle = ID

   DoEvents

End Sub

Sub mcPopID (ID As Integer)
   Call cPopID(IDArray(0), ID)
End Sub

Sub mcPopLastID (WhichManagement As Integer, RoutineNumber As Integer)
   If ((WhichManagement = 2) Or (WhichManagement = 3)) Then Call mcStopTracer(RoutineNumber)
   Call cPopLastID(IDArray(0))
End Sub

Sub mcPushID (ID As Integer)

   Call cPushID(IDArray(0), ID)

   If (DisplayOnline = True) Then Call mcOnlineDisplay(ID)

End Sub

Function mcReadText (TextOrder As String, InsertText As String) As String

   Dim Tmp              As String
   Dim BasisText        As String

   ' read the text in the language file
   BasisText = cGetIni("mcvbehtp", TextOrder, "?", FileLNG)

   ' insert some text if any
   Tmp = cInsertBlocks(BasisText, InsertText)

   ' change all º by a CR and all ú by TAB
   Call cChangeChars(Tmp, "ºú", Chr$(13) + Chr$(9))

   mcReadText = Tmp

End Function

Sub mcStartTracer (RoutineNumber As Integer)

   Dim TimerCounter  As Integer
   Dim Status        As Integer

   ' check if the routine number is not outside the limits
   If ((RoutineNumber < 1) Or (RoutineNumber > TotalRoutines)) Then Exit Sub

   ' check if this is the same routine
   If (OldStartRoutine <> RoutineNumber) Then
      ' increment the trace number
      ActualTrace = ActualTrace + 1
      ' prepare the trace information
      tagTRACER.StartStop = ">"
      tagTRACER.RoutineHandle = RoutineNumber
      ' save the trace information
      Put #chanFileTR, ActualTrace, tagTRACER
   End If

   ' save the old routine
   OldStartRoutine = RoutineNumber

   ' read the record associated with the routine number
   Get #chanFilePF, RoutineNumber, tagPROFILER

   ' open a timer
   TimerCounter = cTimerOpen()
   ' save the handle of the new timer
   tagPROFILER.TimeCounter = TimerCounter
   ' increment the number of calls
   tagPROFILER.TotalCall = tagPROFILER.TotalCall + 1

   ' save the record associated with the routine number
   Put #chanFilePF, RoutineNumber, tagPROFILER

   ' start the timer
   Status = cTimerStart(TimerCounter)

End Sub

Sub mcStopTracer (RoutineNumber As Integer)

   Dim TimerCounter  As Integer
   Dim TimeElapsed   As Long
   Dim Status        As Integer

   ' check if the routine number is not outside the limits
   If ((RoutineNumber < 1) Or (RoutineNumber > TotalRoutines)) Then Exit Sub

   ' check if this is the same routine
   If (OldStopRoutine <> RoutineNumber) Then
      ' increment the trace number
      ActualTrace = ActualTrace + 1
      ' prepare the trace information
      tagTRACER.StartStop = "<"
      tagTRACER.RoutineHandle = RoutineNumber
      ' save the trace information
      Put #chanFileTR, ActualTrace, tagTRACER
   End If

   ' save the old routine
   OldStopRoutine = RoutineNumber

   ' read the record associated with the routine number
   Get #chanFilePF, RoutineNumber, tagPROFILER

   ' check if the timer is valid
   If (tagPROFILER.TimeCounter > 0) Then
      ' computes the elapsed time
      TimeElapsed = cTimerRead(tagPROFILER.TimeCounter)
      ' add the elapsed time
      tagPROFILER.TotalTime = tagPROFILER.TotalTime + TimeElapsed
      ' check for the minimum time
      If (TimeElapsed < tagPROFILER.MinimumTime) Then tagPROFILER.MinimumTime = TimeElapsed
      ' check for the minimum time
      If (TimeElapsed > tagPROFILER.MaximumTime) Then tagPROFILER.MaximumTime = TimeElapsed
   End If

   ' save the record associated with the routine number
   Put #chanFilePF, RoutineNumber, tagPROFILER

   ' close the associated timer
   Status = cTimerClose(tagPROFILER.TimeCounter)

End Sub