home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 February / Chip_2002-02_cd1.bin / zkuste / vbasic / Data / Utility / RegWiz.exe / Dev / RegWiz / Include / CGUIErr.cls next >
Text File  |  2000-01-27  |  11KB  |  304 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CGUIErr"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. ' Replacement for native Err object. Wraps it up with enhanced Error
  15. ' raising capabilities.
  16. ' At the top of each module where it is used put a statement:
  17. '     Private Err as New CGUIErr
  18. '
  19. ' This will then over-ride the VBA Err object.
  20. '
  21. Private Const VALUES_DELIMITER As String = "|"
  22. Private Const VALUES_START As String = "Values="
  23. Private Const DEFAULT_ERRORTEXT As Long = 9999
  24.  
  25. Option Explicit
  26. '====================================================================
  27. ' Start of Standard Err Properties/Methods
  28. '====================================================================
  29. Public Property Get Description() As String
  30.     Description = VBA.Err.Description
  31. End Property
  32.  
  33. Public Property Get HelpContext() As Long
  34.     HelpContext = VBA.Err.HelpContext
  35. End Property
  36.  
  37. Public Property Let HelpContext(ByVal iHelpContext As Long)
  38.     VBA.Err.HelpContext = iHelpContext
  39. End Property
  40.  
  41. Public Property Get Erl() As Long
  42.         Erl = VBA.Erl
  43. End Property
  44.  
  45. Public Property Get HelpFile() As String
  46.     HelpFile = VBA.Err.HelpFile
  47. End Property
  48.  
  49. Public Property Let HelpFile(ByVal iHelpFile As String)
  50.     VBA.Err.HelpFile = iHelpFile
  51. End Property
  52.  
  53. Public Property Get Source() As String
  54.     Source = VBA.Err.Source
  55. End Property
  56.  
  57. Public Property Get Number() As Long
  58.     Number = VBA.Err.Number
  59. End Property
  60.  
  61. Public Property Let Source(ByVal iSource As String)
  62.     VBA.Err.Source = iSource
  63. End Property
  64.  
  65. Public Property Let Description(ByVal iDescription As String)
  66.     VBA.Err.Description = iDescription
  67. End Property
  68.  
  69. Public Property Let Number(ByVal iNumber As Long)
  70.     VBA.Err.Number = iNumber
  71. End Property
  72.  
  73. Public Sub Clear()
  74.     VBA.Err.Clear
  75. End Sub
  76.  
  77. '====================================================================
  78. ' Start of Enhanced Err Properties/Methods
  79. '====================================================================
  80.  
  81. 'Description:
  82. '  Raises an error using VBA.Err.Raise
  83. '  However, it formats the error description to add information that will be used
  84. '  both to build a callstack and provide a more friendly user error message.
  85. '
  86. Public Sub Raise(Optional ByVal Number As Variant, Optional ByVal Source As String, _
  87.           Optional ByVal Description As String, Optional ByVal HelpFile As String, _
  88.           Optional ByVal HelpContext As Long, Optional ByVal ProcName As String)
  89.     
  90. Dim sNumber As String
  91. Dim sDescription As String
  92. Dim sErl As String
  93. Dim sSource As String
  94. Dim sProcName As String
  95. Dim lNumber As Long
  96.  
  97. Const ERRTEXT As String = "Err="
  98.     '
  99.     'Check that optional parameters are supplied and either use them or
  100.     'take the VBA.Err values. Expand the texts into more dev friendly text.
  101.     '
  102.     If IsMissing(Number) Then lNumber = VBA.Err.Number Else lNumber = Number
  103.     If Len(Description) = 0 Then sDescription = VBA.Err.Description Else sDescription = Description
  104.     If Len(Source) = 0 Then sSource = VBA.Err.Source Else sSource = Source
  105.     If Len(ProcName) = 0 Then sProcName = sSource Else sProcName = ProcName
  106.     'Translate the error number into something that may be more meaningful
  107.     'Assume that anything 'near' vbObjectError is a user defined error
  108.     '
  109.     
  110.     sDescription = FormatDescription(lNumber, sDescription, sProcName)
  111.     
  112.     VBA.Err.Raise lNumber, sSource, sDescription, HelpFile, HelpContext
  113.  
  114. End Sub
  115.  
  116. 'Description:
  117. '  An extended version of raise that expects a number, description and a TokenisedList.
  118. Public Sub RaiseEx(ByVal Number As Long, _
  119.           ByVal Description As String, ParamArray Values() As Variant)
  120. Dim sValuesList As String
  121. Dim lIndex As Long
  122.  
  123.     'Paranoia check. If there are no values then quit.
  124.     If LBound(Values()) > UBound(Values()) Then
  125.         sValuesList = vbNullString
  126.     Else
  127.         'Build an output string which is the array elements separated by the token
  128.         sValuesList = vbNullString
  129.         For lIndex = LBound(Values()) To UBound(Values())
  130.             sValuesList = sValuesList & CStr(Values(lIndex)) & VALUES_DELIMITER
  131.         Next lIndex
  132.         
  133.         sValuesList = vbCrLf & "Values=" & Left$(sValuesList, Len(sValuesList) - Len(VALUES_DELIMITER))
  134.     End If
  135.     
  136.     Raise Number, Source, Description & sValuesList, HelpFile, HelpContext
  137.     
  138. End Sub
  139.  
  140. 'Shows the error.
  141. 'The number and description is passed around to preserve it.
  142. Public Sub Show(Optional ByVal ProcName As String)
  143.     
  144.     ' Handle custom errors using a Resource string, display the rest
  145. Dim sDescription As String
  146. Dim sOriginalDescription As String
  147. Dim sUserText As String
  148. Dim lErrNo As Long
  149. Dim frmErr As frmError
  150.  
  151.     lErrNo = VBA.Err.Number
  152.     sOriginalDescription = FormatDescription(lErrNo, Description, ProcName)
  153.     sUserText = FormatUserText(lErrNo, sOriginalDescription)
  154.     
  155.     'Show an error form and then destroy it
  156.     Set frmErr = New frmError
  157.     frmErr.ShowError lErrNo, sUserText, sOriginalDescription
  158.     Set frmError = Nothing
  159.     
  160. End Sub
  161.  
  162. 'Logs the error for those times when there is nowhere to raise an error to
  163. 'Logging must be switched on in the app or it will just not log anywhere
  164. Public Sub Log(Optional ProcName As String)
  165. Dim sDescription As String
  166. Dim lNumber As Long
  167.     
  168.     lNumber = VBA.Err.Number
  169.     sDescription = "Application=" & App.Title & vbCrLf & _
  170.         "Version=" & App.Major & "." & App.Minor & "." & App.Revision & vbCrLf & _
  171.         "Path=" & App.Path & vbCrLf & _
  172.         "Error Number=" & lNumber & vbCrLf & _
  173.         "Error Text Follows" & vbCrLf & vbCrLf & _
  174.         FormatDescription(lNumber, Description, ProcName)
  175.     
  176.     App.LogEvent sDescription, vbLogEventTypeError
  177.  
  178. End Sub
  179.  
  180. '====================================================================
  181. ' Start of Private Methods
  182. '====================================================================
  183.  
  184.  
  185. 'Description:
  186. ' Creates a piece of text based on a resource string, inserts values into it from
  187. ' the original description text.
  188. ' If it cannot find a resource string it will use the 9999 default string
  189. Private Function FormatUserText(ByVal ErrNo As Long, ByVal Description As String)
  190. Dim sOutText As String
  191. Dim sInText As String
  192. Dim lTokenPtr As Long
  193. Dim lTokenEnd As Long
  194. Dim lValueListPtr As Long
  195. Dim sValue As String
  196. Dim vntValues As Variant
  197. Dim iIndex As Integer
  198.  
  199.        
  200.    lValueListPtr = InStr(Description, VALUES_START)
  201.     
  202.     'If a value is found then return it otherwise return null
  203.     If lValueListPtr > 0 Then
  204.         'A list has been found, extract the list
  205.         vntValues = Split(Mid$(Description, lValueListPtr + Len(VALUES_START)), VALUES_DELIMITER)
  206.     Else
  207.         'Force it to be an empty variant array
  208.         vntValues = Array()
  209.     End If
  210.  
  211.     'Res string may not be there, if it is not it will force an error
  212.     On Error Resume Next
  213.     If ErrNo < vbObjectError \ 2 Then
  214.         sInText = LoadResString(ErrNo - vbObjectError)
  215.     Else
  216.         sInText = LoadResString(DEFAULT_ERRORTEXT)
  217.     End If
  218.     
  219.     On Error GoTo 0
  220.     
  221.     ' A space is added on to ease parsing
  222.     sInText = sInText & " "
  223.     sOutText = vbNullString
  224.        
  225.     'Parse the input text until nothing is left
  226.     ' replace tokens with their values
  227.     Do While Len(sInText) > 0
  228.         lTokenPtr = InStr(sInText, "%")
  229.         If lTokenPtr > 0 Then
  230.             'Find the end of the number
  231.             lTokenEnd = lTokenPtr + 1
  232.             Do While IsNumeric(Mid$(sInText, lTokenEnd, 1))
  233.                 lTokenEnd = lTokenEnd + 1
  234.             Loop
  235.             
  236.             'Ignore a percentage symbol on its own, parse it if it is %n
  237.             If lTokenEnd - lTokenPtr > 1 Then ' it must be a number
  238.                 'Split returned a zero based array, users prefer 1 based arrays
  239.                 iIndex = CInt(Mid$(sInText, lTokenPtr + 1, lTokenEnd - lTokenPtr - 1)) - 1
  240.                 If iIndex < LBound(vntValues) Or iIndex > UBound(vntValues) Then
  241.                     sValue = vbNullString
  242.                 Else
  243.                     sValue = vntValues(iIndex)
  244.                 End If
  245.                 'Replace %n with its equivalent value and then move on
  246.                 sOutText = sOutText & Left$(sInText, lTokenPtr - 1) & sValue
  247.                 sInText = Mid$(sInText, lTokenEnd)
  248.             Else
  249.                 'It is a percentage symbol on its own
  250.                 sOutText = sOutText & Left$(sInText, lTokenEnd - 1)
  251.                 sInText = Mid$(sInText, lTokenEnd)
  252.           End If
  253.         Else
  254.             sOutText = sOutText & sInText
  255.             sInText = vbNullString
  256.         End If
  257.     Loop
  258.     
  259.     FormatUserText = sOutText
  260.  
  261. End Function
  262.  
  263. 'Formats the description to produce an error stack and useful additional information
  264.  
  265. Private Function FormatDescription(ByVal ErrNo As Long, ByVal OldDescription As String, ByVal ProcName As String) As String
  266. Dim sNumber As String
  267. Dim sErl As String
  268. Dim sDescription As String
  269.  
  270. Const ERRTEXT As String = "Err="
  271.     '
  272.     'Check that optional parameters are supplied and either use them or
  273.     'take the VBA.Err values. Expand the texts into more dev friendly text.
  274.     '
  275.     sDescription = OldDescription
  276.     
  277.     'Translate the error number into something that may be more meaningful
  278.     'Assume that anything 'near' vbObjectError is a user defined error
  279.     '
  280.     If ErrNo > vbObjectError \ 2 Then
  281.         sNumber = vbCrLf & ERRTEXT & ErrNo & " "
  282.     Else
  283.         sNumber = vbCrLf & ERRTEXT & "vbObjectError+" & CStr(ErrNo - vbObjectError) & " "
  284.     End If
  285.     
  286.     'Grab the line number if available
  287.     If Erl <> 0 Then sErl = " Line=" & CStr(Erl) & " " Else sErl = " "
  288.     
  289.     'Include the error number if it has changed together with the description
  290.     If InStr(sDescription, sNumber) > 0 Then _
  291.         sNumber = vbNullString _
  292.     Else sNumber = sNumber & vbCrLf & "Description="
  293.     
  294.     If Len(ProcName) = 0 Then
  295.         FormatDescription = sNumber & sDescription
  296.     Else
  297.         FormatDescription = ProcName & sErl & vbCrLf & sNumber & sDescription
  298.     End If
  299.     
  300. End Function
  301.  
  302.  
  303.  
  304.