home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 24 / CD_ASCQ_24_0995.iso / dos / prg / vberrhnd / vberrhnd.bas < prev    next >
BASIC Source File  |  1995-07-21  |  10KB  |  305 lines

  1. Option Explicit
  2.  
  3. Global Const VB_LNG_FRENCH = 1
  4. Global Const VB_LNG_DUTCH = 2
  5. Global Const VB_LNG_GERMAN = 3
  6. Global Const VB_LNG_ENGLISH = 4
  7. Global Const VB_LNG_ITALIAN = 5
  8. Global Const VB_LNG_SPANISH = 6
  9.  
  10. Const MB_MESSAGE_LEFT = 0
  11.  
  12. Declare Sub cPushID Lib "vbhnderr.dll" (IDArray As Integer, ByVal nID As Integer)
  13. Declare Sub cPopID Lib "vbhnderr.dll" (IDArray As Integer, ByVal nID As Integer)
  14. Declare Sub cPopLastID Lib "vbhnderr.dll" (IDArray As Integer)
  15. Declare Function cGetID Lib "vbhnderr.dll" (IDArray As Integer, ByVal nPosition As Integer) As Integer
  16. Declare Sub cClearID Lib "vbhnderr.dll" (IDArray As Integer)
  17. Declare Sub cChangeChars Lib "vbhnderr.dll" (Txt As String, charSet As String, newCharSet As String)
  18. Declare Function cGetIni Lib "vbhnderr.dll" (ByVal AppName As String, ByVal szItem As String, ByVal szDefault As String, ByVal InitFile As String) As String
  19. Declare Function cGetWindowsDirectory Lib "vbhnderr.dll" () As String
  20. Declare Function cInsertBlocks Lib "vbhnderr.dll" (Txt As String, Insert As String) As String
  21. Declare Function cLngMsgBox Lib "vbhnderr.dll" (ByVal nLanguage As Integer, ByVal Message As String, ByVal Button As Long, ByVal Title As String) As Integer
  22.  
  23. 'Don't change any variables and their value below
  24.  
  25. Const ID_ITEMS = 16
  26.  
  27. Type HNDERRtype
  28.    ModuleName                       As String * 12
  29.    RoutineHandle                    As String * 4
  30.    RoutineName                      As String * 82
  31.    CrLf                             As String * 2
  32. End Type
  33.  
  34. Dim FileLNG                         As String
  35.  
  36. Dim FileHND                         As String
  37.  
  38. Dim FileLOG                         As String
  39.  
  40. Dim IDArray(0 To ID_ITEMS)          As Integer
  41.  
  42. Dim Language                        As Integer
  43. Dim AutoLog                         As Integer
  44. Dim WaitingTimeForReaction          As Integer
  45. Dim DefaultButton                   As Integer
  46. Dim DisplayOnline                   As Integer
  47.  
  48. Dim TotalSameHandle                 As Long
  49. Dim LastHandle                      As Integer
  50.  
  51. Dim HNDERR                          As HNDERRtype
  52.  
  53. Sub mcClearID ()
  54.    Call cClearID(IDArray(0))
  55. End Sub
  56.  
  57. Function mcGetID (nPos As Integer)
  58.    mcGetID = cGetID(IDArray(0), nPos)
  59. End Function
  60.  
  61. Function mcGetLanguageID (LanguageID As Integer) As String
  62.  
  63.    Dim RetLanguage      As String
  64.  
  65.    Select Case LanguageID
  66.       Case VB_LNG_FRENCH
  67.          RetLanguage = "VFR"
  68.       Case VB_LNG_DUTCH
  69.          RetLanguage = "VNL"
  70.       Case VB_LNG_GERMAN
  71.          RetLanguage = "VDE"
  72.       Case VB_LNG_ENGLISH
  73.          RetLanguage = "VUK"
  74.       Case VB_LNG_ITALIAN
  75.          RetLanguage = "VIT"
  76.       Case VB_LNG_SPANISH
  77.          RetLanguage = "VSP"
  78.       Case Else
  79.          RetLanguage = "VUK"
  80.    End Select
  81.    
  82.    If (LanguageID > 0) Then
  83.       Language = LanguageID
  84.    Else
  85.       Language = VB_LNG_ENGLISH
  86.    End If
  87.  
  88.    mcGetLanguageID = RetLanguage
  89.  
  90. End Function
  91.  
  92. Function mcIDErrorHandler (nErr As Integer) As Integer
  93.  
  94.    ' check if this a correct Error passed
  95.    If (nErr = 0) Then
  96.       'if no, resume next
  97.       mcIDErrorHandler = True
  98.       Exit Function
  99.    End If
  100.  
  101.    Dim RoutineCount     As Integer
  102.    Dim RoutineNumber    As Integer
  103.    Dim RoutineStack     As String
  104.    Dim TotalRoutines    As Integer
  105.    Dim BlankLines       As Integer
  106.    Dim Chan             As Integer
  107.    Dim StopExit         As Integer
  108.    Dim TimeOut          As Long
  109.    Dim ButtonsConfig    As Integer
  110.    Dim ErrorTitle       As String
  111.  
  112.    '  some initializations
  113.    RoutineStack = ""
  114.    TotalRoutines = 0
  115.    BlankLines = 0
  116.    StopExit = False
  117.    ButtonsConfig = 0
  118.    ErrorTitle = ""
  119.    RoutineStack = RoutineStack + mcReadText("0", "")
  120.    
  121.    ' find the next valid unused file number.
  122.    Chan = FreeFile
  123.  
  124.    ' open the file with the definition of each routines (file must be in the WINDOWS directory)
  125.    Close #Chan
  126.    Open FileHND For Random Shared As #Chan Len = Len(HNDERR)
  127.  
  128.    ' get the stack of the routines
  129.    For RoutineCount = 0 To ID_ITEMS
  130.       ' get the number of the routine
  131.       RoutineNumber = mcGetID(RoutineCount)
  132.       ' if there a valid routine number
  133.       If (RoutineNumber > 0) Then
  134.          ' yes, read the definition of the routine
  135.          Get #Chan, RoutineNumber, HNDERR
  136.          ' form the stack of the routines founden to display
  137.          RoutineStack = RoutineStack + Left$(HNDERR.ModuleName + Space$(12), 14) + Chr$(9) + HNDERR.RoutineHandle + Chr$(9) + Trim$(HNDERR.RoutineName) + Chr$(13)
  138.          ' count the routines to display
  139.          TotalRoutines = TotalRoutines + 1
  140.       Else
  141.          ' no, exit from reading the stack
  142.          Exit For
  143.       End If
  144.    Next RoutineCount
  145.  
  146.    ' close the open file
  147.    Close #Chan
  148.  
  149.    ' check if the default button must be activated
  150.    If (DefaultButton = True) Then
  151.       ' yes, RETRY and CANCEL with RETRY is the default
  152.       ButtonsConfig = 5 Or 0
  153.    Else
  154.       ' no, RETRY and CANCEL with CANCEL is the default
  155.       ButtonsConfig = 5 Or 256
  156.       ' yes, add text for RETRY after timeout or action
  157.       RoutineStack = RoutineStack & Chr$(13) & Chr$(13) & "program will be stopped"
  158.    End If
  159.  
  160.    ' set the error title
  161.    ErrorTitle = mcReadText("1", nErr & "~" & Error$(nErr))
  162.  
  163.    ' check if one routine has been founded
  164.    If (Len(RoutineStack) > 0) Then
  165.       ' check the time out
  166.       TimeOut = WaitingTimeForReaction * (163840 Or 524288)
  167.       ' display remaining blank lines
  168.       BlankLines = (8 - TotalRoutines) - (TimeOut = 0)
  169.       For RoutineCount = 0 To BlankLines
  170.          RoutineStack = RoutineStack + Chr$(13)
  171.       Next RoutineCount
  172.       ' add some text for management
  173.       RoutineStack = RoutineStack & mcReadText("2", "")
  174.       ' check if a timeout must be used
  175.       If (TimeOut <> 0) Then
  176.          ' yes, add text depending of the default button
  177.          RoutineStack = RoutineStack & mcReadText("3", "") & " "
  178.          ' if default is RETRY then display 'continue' else 'stop'
  179.          If (DefaultButton = True) Then
  180.             RoutineStack = RoutineStack & mcReadText("4", "")
  181.          Else
  182.             RoutineStack = RoutineStack & mcReadText("5", "")
  183.          End If
  184.       End If
  185.       ' display the error message box
  186.       StopExit = (cLngMsgBox(Language, RoutineStack, MB_MESSAGE_LEFT Or TimeOut Or ButtonsConfig Or 16, ErrorTitle) = 2)
  187.       ' yield process
  188.       DoEvents
  189.    End If
  190.  
  191.    ' check if an auto logging must be performed
  192.    If (AutoLog = True) Then
  193.  
  194.       ' open the logging file in append mode
  195.       Close #Chan
  196.       Open FileLOG For Append Shared As #Chan
  197.  
  198.       ' save the error and his description
  199.       Print #Chan, ErrorTitle; " "; mcReadText("6", Date$ & "~" & Time$)
  200.       Print #Chan, ""
  201.       ' save the full stack name of each routines founden
  202.       Print #Chan, RoutineStack
  203.       Print #Chan, ""
  204.       ' check if the CANCEL button pushed or TimeOut
  205.       If (StopExit = True) Then
  206.          ' yes stop by operator, save text for CANCEL
  207.          Print #Chan, mcReadText("7", "")
  208.       Else
  209.          ' no, retry by operator, save text for RETRY
  210.          Print #Chan, mcReadText("8", "")
  211.       End If
  212.       ' save separator
  213.       Print #Chan, String$(78, "-")
  214.  
  215.       ' close the file
  216.       Close #Chan
  217.  
  218.    End If
  219.  
  220.    ' if stop the program the END the application
  221.    If (StopExit = True) Then End
  222.  
  223.    ' no stop, resumes to next line in the main application
  224.    mcIDErrorHandler = True
  225.  
  226. End Function
  227.  
  228. Sub mcOnlineDisplay (ID As Integer)
  229.  
  230.    Dim Chan          As Integer
  231.    Dim ActualLine    As String
  232.  
  233.    ' find the next valid unused file number.
  234.    Chan = FreeFile
  235.  
  236.    ' open the file with the definition of each routines (file must be in the WINDOWS directory)
  237.    Close #Chan
  238.    Open FileHND For Random Shared As #Chan Len = Len(HNDERR)
  239.  
  240.    ' read the handle
  241.    Get #Chan, ID, HNDERR
  242.  
  243.    ' close the file
  244.    Close #Chan
  245.  
  246.    If (LastHandle = ID) Then
  247.       TotalSameHandle = TotalSameHandle + 1
  248.    Else
  249.       If (frmDisplayOnline.lstOnline.ListIndex > -1) Then
  250.          ActualLine = frmDisplayOnline.lstOnline.List(frmDisplayOnline.lstOnline.ListIndex)
  251.          frmDisplayOnline.lstOnline.List(frmDisplayOnline.lstOnline.ListIndex) = TotalSameHandle & Mid$(ActualLine, InStr(ActualLine, Chr$(9)))
  252.       End If
  253.       TotalSameHandle = 1
  254.    End If
  255.  
  256.    frmDisplayOnline.lblCounter = TotalSameHandle
  257.    frmDisplayOnline.lblHandle = ID
  258.  
  259.    If (LastHandle <> ID) Then
  260.       frmDisplayOnline.lstOnline.AddItem TotalSameHandle & Chr$(9) & Trim$(HNDERR.RoutineHandle) & Chr$(9) & Trim$(HNDERR.ModuleName) & Chr$(9) & Trim$(HNDERR.RoutineName)
  261.       If (frmDisplayOnline.lstOnline.ListCount > 25) Then frmDisplayOnline.lstOnline.RemoveItem 0
  262.       frmDisplayOnline.lstOnline.ListIndex = frmDisplayOnline.lstOnline.NewIndex
  263.    End If
  264.  
  265.    LastHandle = ID
  266.  
  267.    DoEvents
  268.  
  269. End Sub
  270.  
  271. Sub mcPopID (ID As Integer)
  272.    Call cPopID(IDArray(0), ID)
  273. End Sub
  274.  
  275. Sub mcPopLastID ()
  276.    Call cPopLastID(IDArray(0))
  277. End Sub
  278.  
  279. Sub mcPushID (ID As Integer)
  280.  
  281.    Call cPushID(IDArray(0), ID)
  282.  
  283.    If (DisplayOnline = True) Then Call mcOnlineDisplay(ID)
  284.  
  285. End Sub
  286.  
  287. Function mcReadText (TextOrder As String, InsertText As String) As String
  288.  
  289.    Dim Tmp              As String
  290.    Dim BasisText        As String
  291.  
  292.    ' read the text in the language file
  293.    BasisText = cGetIni("VBHNDERR", TextOrder, "?", FileLNG)
  294.    
  295.    ' insert some text if any
  296.    Tmp = cInsertBlocks(BasisText, InsertText)
  297.  
  298.    ' change all º by a CR and all ú by TAB
  299.    Call cChangeChars(Tmp, "ºú", Chr$(13) + Chr$(9))
  300.  
  301.    mcReadText = Tmp
  302.  
  303. End Function
  304.  
  305.