www.pudn.com > sqlserverdbfz.rar > HuntERR25.bas
Attribute VB_Name = "HuntERR25"
'========================================================================================
' HuntERR
' Error Handling and Reporting Library
' from URFIN JUS (www.urfinjus.net)
' All rights reserved.
'version 2.5, 05/31/2001
'=========================================================================================
Option Explicit
'Error map enum. Defines error ranges for UJ reserved errors, exceptions, and
'custom application errors. Must be included into exactly one public class.
' Notes:
' 1. Define your custom errors starting with ERRMAP_APP_FIRST + 1.
' 2. EXC_GENERAL and ERR_GENERAL may be used by your application if specific error number
' is not needed.
' 3. Error numbers (vbObjectError + [1..4096]) are used by OLE DB;
' See support.microsoft.com/support/kb/articles/Q168/3/54.ASP
'
'Copy and uncomment the ERRMAP declaration into one of your public clasess,
' or uncomment it right here.
'Public Enum ENUM_ERRMAP
' ERRMAP_FIRST = vbObjectError + 4096 'vbObjectError = $H80040000 = -2147221504
' ERRMAP_RESERVED_FIRST = ERRMAP_FIRST 'Errors reserved for HuntERR and UJ apps.
' ERRMAP_STACK_TRACE = ERRMAP_RESERVED_FIRST ' Stack tracing: used by HuntERR
' ERRMAP_RESERVED_LAST = ERRMAP_RESERVED_FIRST + 100
' ERRMAP_EXC_FIRST = ERRMAP_RESERVED_LAST + 1 'Exceptions - reraised by ErrorIn
' EXC_GENERAL = ERRMAP_EXC_FIRST
' ERRMAP_EXC_LAST = ERRMAP_EXC_FIRST + 1000
' ERRMAP_APP_FIRST = ERRMAP_EXC_LAST + 1
' ERR_GENERAL = ERRMAP_APP_FIRST
' 'Application errors
'End Enum
'Flags controlling actions of ErrorIn, through ErrorAction parameter
Public Enum ENUM_ERROR_ACTION
EA_RERAISE = 1 'Reraise error
EA_ADVANCED = 2 'Add trace information to error description
EA_SET_ABORT = 4 'If in COM+ application, call SetAbort on current object's context.
EA_DISABLE_COMMIT = 8 'Call DisableCommit on current objects' context. Recommended.
EA_ROLLBACK = 16 'If not in COM+, call Connection.Rollback
EA_WEBINFO = 32 'Add web request information
EA_DEFAULT = EA_ADVANCED + EA_RERAISE + EA_DISABLE_COMMIT 'Default value for ErrorIn
End Enum
Private Declare Function GetComputerNameAPI Lib "kernel32" Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Const STR_REPORT = _
"========================================================================================<$nl$>" & _
"Error in [<$MethodName$>]: <$Descr$> <$nl$>" & _
" Server='<$Server$>' Time='<$Time$>' App='<$App$>:<$Ver$>' InTransaction=<$InTrans$> <$nl$>" & _
" Number: <$ErrNum$> =vbObjectError+<$ErrNumRel1$>=ERRMAP_APP_FIRST+<$ErrNumRel2$> <$nl$>" & _
" Source: <$Source$> <$nl$>" & _
" Description: <$Descr$> <$nl$> "
Const STR_WEBINFO = _
"<$nl$>" & _
" <$WebHeader$> <$nl$>" & _
" RequestMethod='<$RequestMethod$>'<$nl$>" & _
" QueryString: '<$WebServer$><$URL$><$QS$>' <$nl$>" & _
" FormData: '<$FormData$>' <$nl$>" & _
" Cookies: '<$Cookies$>' <$nl$>"
Const STR_WEBHEADER = "WEB Request Info:" 'Web header is used to detect if Web information is already added.
Const STR_TRACEHEADER = " Trace: "
Private mErrNumber As Long, mErrSource As String, mErrDescr As String
Private mConn As ADODB.Connection, mMethodName As String, mArgNames As String
Private mErrorReport As String
'The main super-function. Should be called in error handling blocks
Public Function ErrorIn(ByVal MethodHeader As String, _
Optional ByVal arrArgs, _
Optional ByVal ErrorAction As Long = EA_DEFAULT, _
Optional ByVal DbObject As Object, _
Optional ByVal EnvVarNames As String, _
Optional ByVal arrEnvVars, _
Optional ByVal TransControlObject As Object) As String
StoreErr 'store error information in module variables.
If IsException(mErrNumber) Then
ReportClear 'No report, proceed to aborting transaction and re-raise
ElseIf FlagSet(ErrorAction, EA_ADVANCED) Then
ErrFindConnectionObject DbObject
SplitMethodHeader MethodHeader
If mErrNumber = ERRMAP_STACK_TRACE Then
'Error Propagation is on the way
mErrorReport = mErrDescr
Else
'Initial processing
ReportInit
ReportAddADOErrors
End If 'ErrNumber=ERRDB_STACK_TRACE ....
If FlagSet(ErrorAction, EA_WEBINFO) Then ReportAddWebInfo
ReportAddTraceInfo mMethodName, mArgNames, arrArgs, EnvVarNames, arrEnvVars
mErrNumber = ERRMAP_STACK_TRACE
mErrSource = "ErrorIn"
mErrDescr = mErrorReport
End If 'IsException(.... ElseIf FlagSet(...
ErrTerminateTrans ErrorAction, TransControlObject, mConn
ErrorIn = mErrorReport
RestoreErr
If FlagSet(ErrorAction, EA_RERAISE) Then Err.Raise Err.Number, Err.Source, Err.Description
End Function
Public Sub Check(ByVal Cond As Boolean, _
ByVal ErrNumber As Long, ByVal ErrDescr As String)
If Not Cond Then Err.Raise ErrNumber, "HuntERR.Check", ErrDescr
End Sub
'Returns true if error number is in range reserved for Exceptions
Public Function IsException(ByVal ErrNumber As Long) As Boolean
IsException = (ErrNumber >= ERRMAP_EXC_FIRST) And (ErrNumber <= ERRMAP_EXC_LAST)
End Function
'Returns report prepared by last call to ErrorIn
Public Property Get ErrorReport() As String
ErrorReport = mErrorReport
End Property
Public Function ErrOrigErrNumber() As Long
' Do it carefully, so it can be called from error handlers;
' even if ErrorReport is empty it shouldn't break
Dim S As String
S = Trim$(ErrExtract(mErrorReport, "Number: ", "="))
If S <> "" Then ErrOrigErrNumber = CLng(S) Else ErrOrigErrNumber = 0
End Function
Public Function ErrOrigErrDescr() As String
ErrOrigErrDescr = ErrExtract(mErrorReport, "Description: ", vbNewLine)
End Function
Public Function ErrOrigErrSource() As String
ErrOrigErrSource = ErrExtract(mErrorReport, "Source: ", vbNewLine)
End Function
'================================= Error logging ==========================================
'Don't forget, that Logging is ignored from within VB IDE!
Public Sub ErrLogError()
On Error GoTo errHandler
If mErrorReport <> "" Then
App.StartLogging "", vbLogToNT
App.LogEvent ErrorReport
End If 'mErrorReport...
Exit Sub
errHandler:
'nothing to do...
End Sub
Public Sub ErrSaveError(ByVal ErrFileName As String)
Dim F As Long, FName As String
On Error GoTo errHandler
If mErrorReport <> "" Then
F = FreeFile
FName = IIf(InStr(1, ErrFileName, "\") > 0, ErrFileName, App.Path & "\" & ErrFileName)
Open FName For Append As #F
Print #F, mErrorReport
Close #F
End If 'mErrorReport...
Exit Sub
errHandler:
'nothing to do...
End Sub
'Note: SQL script for creating database table and stored procedure is at the end of this file.
Public Function ErrSaveToDB(ByVal ConnectString As String, _
Optional ByVal AppID As Long = 1, _
Optional ByVal ProcName As String = "spErrorLogInsert") As Boolean
Dim Cmd As ADODB.Command, SQL As String
On Error GoTo errHandler
If mErrorReport <> "" Then
SQL = "Exec " & ProcName & " " & AppID & "," & ErrOrigErrNumber & "," & Qt(ErrOrigErrSource, 100) & _
"," & Qt(ErrOrigErrDescr, 250) & "," & Qt(ErrorReport, 7500)
Set Cmd = New ADODB.Command
Cmd.CommandType = adCmdText
Cmd.CommandText = SQL
Cmd.ActiveConnection = ConnectString
Cmd.Execute
End If
ErrSaveToDB = True
Exit Function
errHandler:
'nothing to do..., just return false
End Function
Private Function Qt(ByVal Param As String, ByVal MaxLen As Long) As String
If Len(Param) > MaxLen Then Param = Left$(Param, MaxLen)
Qt = "'" & Replace(Param, "'", "''") & "'"
End Function
'##################################### Private methods #########################################
Private Sub StoreErr()
mErrNumber = Err.Number
mErrDescr = Err.Description
mErrSource = Err.Source
End Sub
Private Sub RestoreErr()
Err.Number = mErrNumber
Err.Source = mErrSource
Err.Description = mErrDescr
End Sub
'Prepares initial report
Private Sub ReportInit()
mErrorReport = STR_REPORT
ReportSet "nl", vbNewLine
ReportSet "MethodName", mMethodName
ReportSet "Server", ErrGetComputerName
ReportSet "Time", Format(Now, "Mm/Dd/yy Hh:Nn:Ss")
ReportSet "App", App.EXEName
ReportSet "Ver", ErrGetDLLversion
ReportSet "InTrans", IIf(InContextTransaction, "Yes", "No")
ReportSet "ErrNum", mErrNumber
ReportSet "ErrNumRel1", CStr(mErrNumber - vbObjectError)
ReportSet "ErrNumRel2", CStr(mErrNumber - ERRMAP_APP_FIRST)
ReportSet "Source", mErrSource
ReportSet "Descr", mErrDescr
End Sub
Private Sub ReportSet(ByVal Tag As String, ByVal Value As String)
mErrorReport = Replace(mErrorReport, "<$" & Tag & "$>", Value)
End Sub
Private Sub ReportClear()
mErrorReport = ""
End Sub
Private Sub ReportAdd(ByVal Info As String)
mErrorReport = mErrorReport & Info & vbNewLine
End Sub
Private Sub ErrTerminateTrans(ByVal ErrorAction As Long, _
ByVal TransControlObject As Object, _
ByVal mConn As ADODB.Connection)
If Not TransControlObject Is Nothing Then
On Error Resume Next
TransControlObject.SetAbort
ElseIf InContext Then
If FlagSet(ErrorAction, EA_SET_ABORT) Then
SafeSetAbort
ElseIf FlagSet(ErrorAction, EA_DISABLE_COMMIT) Then
SafeDisableCommit
End If 'FlagSet(....
ElseIf (Not mConn Is Nothing) And FlagSet(ErrorAction, EA_ROLLBACK) Then
If mConn.State = adStateOpen Then
On Error Resume Next 'In case if there is no transaction
mConn.RollbackTrans
End If 'mConn.State
End If 'Not TransControlObject ....
End Sub
Private Sub ErrFindConnectionObject(ByVal DbObject As Object)
If DbObject Is Nothing Then Exit Sub
Select Case TypeName(DbObject)
Case "Connection": Set mConn = DbObject
Case "Command", "Recordset": Set mConn = DbObject.ActiveConnection
Case Else:
On Error Resume Next 'Important
Set mConn = DbObject.Connection 'Custom class, try to get its Connection property
End Select
End Sub
Private Sub ReportAddADOErrors()
Dim strMsgs As String, E As ADODB.Error
On Error GoTo errHandler
If mConn Is Nothing Then Exit Sub
If mConn.Errors.Count = 0 Then Exit Sub
ReportAdd " ADO Errors:"
For Each E In mConn.Errors
ReportAdd " " & E.Description
Next E
Exit Sub
errHandler:
'Nothing to do: failed for whatever reason, so no ADO errors
End Sub
'Reads information from IIS request object
Private Sub ReportAddWebInfo()
Dim objContext As Object, IISRequestObj As Object
Dim strReqMethod As String, strCookies As String, strServer As String
On Error GoTo errHandler
'Check if Web Request Info is already there
If InStr(1, mErrorReport, STR_WEBHEADER) > 0 Then Exit Sub
'Try to get Request object through ObjectContext
Set objContext = GetContext
If IsEmpty(objContext) Or (objContext Is Nothing) Then Exit Sub
Set IISRequestObj = objContext("Request")
'Request object retrieved, add web request info to the report
ReportAdd STR_WEBINFO
With IISRequestObj
ReportSet "WebHeader", STR_WEBHEADER
ReportSet "WebServer", .ServerVariables("SERVER_NAME")
ReportSet "RequestMethod", .ServerVariables("REQUEST_METHOD")
ReportSet "URL", .ServerVariables("URL")
ReportSet "QS", IIf(.QueryString = "", "", "?" & .QueryString)
ReportSet "FormData", CStr(.Form)
ReportSet "Cookies", .Cookies
ReportSet "nl", vbNewLine
End With
Exit Sub
errHandler:
'Nothing to do: failed for whatever reason, so no web info.
End Sub
Private Sub SplitMethodHeader(ByVal MethodHeader As String)
Dim arrBuf() As String
mMethodName = ""
mArgNames = ""
arrBuf = Split(MethodHeader, "(")
If UBound(arrBuf) >= 0 Then mMethodName = arrBuf(0)
If UBound(arrBuf) > 0 Then mArgNames = Left$(arrBuf(1), Len(arrBuf(1)) - 1) 'get rid of ")"
End Sub
Private Sub ReportAddTraceInfo(ByVal mMethodName As String, _
ByVal mArgNames As String, _
ByVal arrArgs, _
ByVal EnvVarNames As String, _
ByVal arrEnvVars)
On Error GoTo errHandler
If InStr(1, mErrorReport, STR_TRACEHEADER) = 0 Then ReportAdd STR_TRACEHEADER
ReportAdd " proc " & mMethodName & "(" & ErrCreateNameValueList(mArgNames, arrArgs) & ")"
If EnvVarNames <> "" Then
ReportAdd " Env: " & ErrCreateNameValueList(EnvVarNames, arrEnvVars) & vbNewLine
End If
Exit Sub
errHandler:
'Nothing to do: failed for whatever reason, so no trace info.
End Sub
Private Function ErrCreateNameValueList(ByVal strNames As String, ByVal arrValues) As String
Dim arrNames() As String, i As Long, strList As String, strValue As String, strNameValue As String
On Error GoTo errHandler
'arrValues maybe array of values, or a single value.
If Not IsArray(arrValues) Then arrValues = Array(arrValues)
arrNames = Split(strNames, ",")
For i = 0 To UBound(arrValues)
strValue = ErrVarToString(arrValues(i))
If i <= UBound(arrNames) Then
strNameValue = arrNames(i) & "=" & strValue
Else
strNameValue = strValue
End If 'i<=....
If strList <> "" Then strList = strList & ", "
strList = strList & strNameValue
Next i
ErrCreateNameValueList = strList
Exit Function
errHandler:
'Nothing to do: failed for whatever reason
End Function
Private Function ErrVarToString(ByVal V) As String
Dim L As Long, U As Long
On Error GoTo errHandler
If IsArray(V) Then
ErrVarToString = "{Array}"
Else 'If IsArray(...
Select Case VarType(V)
Case vbInteger, vbLong, vbByte, _
vbSingle, vbDouble, vbCurrency, _
vbBoolean, vbDecimal:
ErrVarToString = CStr(V)
Case vbDate: ErrVarToString = "'" & CStr(V) & "'"
Case vbError: ErrVarToString = "" 'Missing arg falls here
Case vbEmpty: ErrVarToString = "{Empty}"
Case vbNull: ErrVarToString = "{Null}"
Case vbString: ErrVarToString = "'" & V & "'"
Case vbObject: ErrVarToString = "{" & TypeName(V) & "}"
Case Else: ErrVarToString = "{?}"
End Select
End If 'IsArray...
Exit Function
errHandler:
ErrVarToString = "{?}"
End Function
Private Function FlagSet(ByVal Value As Long, ByVal Flag As Long) As Boolean
FlagSet = ((Value And Flag) <> 0)
End Function
Public Function ErrGetComputerName() As String
Dim sBuffer As String * 255, lLen As Long
lLen = Len(sBuffer)
If CBool(GetComputerNameAPI(sBuffer, lLen)) Then ErrGetComputerName = Left$(sBuffer, lLen)
End Function
Public Function ErrGetDLLversion() As String
ErrGetDLLversion = App.Major & "." & App.Minor & "." & App.Revision
End Function
' Operations on object context
'
Public Sub SafeDisableCommit()
Dim Ctx As Object
Set Ctx = GetContext
If Not Ctx Is Nothing Then
If Ctx.IsInTransaction Then Ctx.DisableCommit
End If
End Sub
Public Sub SafeEnableCommit()
Dim Ctx As Object
Set Ctx = GetContext
If Not Ctx Is Nothing Then
If Ctx.IsInTransaction Then Ctx.EnableCommit
End If
End Sub
Public Sub SafeSetComplete()
Dim Ctx As Object
Set Ctx = GetContext
If Not (Ctx Is Nothing) Then
If Ctx.IsInTransaction Then Ctx.SetComplete
End If
End Sub
Public Sub SafeSetAbort()
Dim Ctx As Object
Set Ctx = GetContext
If Not (Ctx Is Nothing) Then
If Ctx.IsInTransaction Then Ctx.SetAbort
End If
End Sub
Private Function InContext() As Boolean
Dim Ctx As Object
Set Ctx = GetContext
InContext = Not (Ctx Is Nothing)
End Function
Private Function InContextTransaction() As Boolean
Dim Ctx As Object
Set Ctx = GetContext
If Not (Ctx Is Nothing) Then
InContextTransaction = Ctx.IsInTransaction
End If
End Function
Private Function GetContext() As Object
'If the following line doesn't compile, then do one of the following
' 1) Add reference to "COM+ Services Type Library" in Project|References.
' Note: In IIS 5 even if your WEB app is not COM+ configured,
' still ALL components created in ASP are running with ObjectContext,
' 2) Comment the following line. GetContext will return Nothing, but HuntERR will work OK.
'Set GetContext = GetObjectContext
End Function
Private Function ErrExtract(ByVal AReport As String, ByVal FromStr As String, ByVal ToStr As String)
Dim PStart As Long, PEnd As Long
PStart = InStr(1, AReport, FromStr) + Len(FromStr)
PEnd = InStr(PStart, AReport, ToStr) - 1
If (PStart > 0) And (PEnd >= PStart) Then ErrExtract = Mid$(AReport, PStart, PEnd - PStart + 1)
End Function
' -- Script to create table and sp for error logging
'CREATE TABLE [dbo].[tblErrorLog] (
' [ErrorID] [int] IDENTITY (1, 1) NOT NULL , [DateCreated] [datetime] NOT NULL ,
' [AppID] [int] NULL , [Number] [int] NULL , [Source] [varchar] (100) NULL ,
' [Description] [varchar] (250) NULL , [ErrorReport] [varchar] (7500) NULL
') ON [PRIMARY]
'GO
'CREATE PROCEDURE dbo.spErrorLogInsert
' @AppID INT, @Number INT, @Source varchar(100), @Description varchar(250), @ErrorReport varchar(7500)
'AS
'INSERT INTO tblErrorLog (DateCreated, AppID, Number, Source, Description, ErrorReport)
'VALUES (GetDate(),@AppID, @Number, @Source, @Description, @ErrorReport)
'GO
'GRANT EXECUTE ON spErrorLogInsert to public