This code pastes into a Module that Create (if not exists) a MDB to record the errors that occur in your application.
Original Author: WalkerBro
Inputs
Needs (DatabaseName, Date, Err.Number, Err.Description, PrivateNotes, Optional(User))
Load in “References” the “Microsoft DAO 3.51 Object Library”
Assumptions
Basic Error handling information.
Returns
True or False if it was succesful.
Side Effects
No known side effects.
API Declarations
Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Public Declare Function CreateDirectory Lib “kernel32” Alias “CreateDirectoryA” (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Code
'* Created by Walker Brother (tm)
'* web page : http://www.walkerbro.8m.com
'* e-mail : info@walkerbro.8m.com
'* This Module Logs the Errors your application may incounter into a MDB, if the MDB
'* does not exist the it Creates it.
'* It Creates a passworded MDB to stop other accessing your errors, you then can make
'* a frontend to read your errors.
'* Table Name : ErrList
'* Field Name : ErrDate, ErrDes, ErrNum, ErrNotes, ErrUser '* 'Usage
'* Error_Handler:
'* Select Case Error_Handler_Doc("Name.mdb", Now, 123, "Description", "Notes")
'* Case "True"
'* Case "False"
'* End Select
'* Load in "References" the "Microsoft DAO 3.51 Object Library"
Dim NewDB As Database
Dim ExistDB As Database
Dim ExistRS As Recordset
Public Function Error_Handler_Doc(ByVal ErrMDB As String, ErrDate As Date, ErrNum As Long, ErrDes As String, ErrNote As String, Optional ErrUser As String) As Boolean
Select Case Error_Handler_MDB(ErrMDB)
Case "False"
If Error_Handler_Create(ErrMDB, "!@#$") = False Then
Error_Handler_Doc = False
Exit Function
End If
End Select
Set ExistDB = OpenDatabase("C:Program FilesCommon FilesWalker BrothersErrorHandler" & ErrMDB, False, False, ";pwd=!@#$")
Set ExistRS = ExistDB.OpenRecordset("ErrList", dbOpenDynaset)
ExistRS.AddNew
ExistRS.Fields!ErrNum = ErrNum & ""
ExistRS.Fields!ErrDate = ErrDate & ""
ExistRS.Fields!ErrDes = ErrDes & ""
ExistRS.Fields!ErrNote = ErrNote & ""
ExistRS.Fields!ErrUser = ErrUser & ""
ExistRS.Update
ExistRS.Close
ExistDB.Close
Set ExistRS = Nothing
Set ExistDB = Nothing
Error_Handler_Doc = True
End Function
Public Function Error_Handler_MDB(ByVal ErrMDB As String) As Boolean
On Error Resume Next
Open "C:Program FilesCommon FilesWalker BrothersErrorHandler" & ErrMDB For Input As #1
If Err Then
Error_Handler_MDB = False
Exit Function
End If
Close #1
Error_Handler_MDB = True
End Function
Public Function Error_Handler_Create(ByVal ErrMDB As String, ByVal ErrMDBPassword As String) As Boolean
Error_Handler_Create = False
If CreateNewDirectory("C:Program FilesCommon FilesWalker BrothersErrorHandler") = False Then
Exit Function
End If
On Error GoTo Err_Handler
If ErrMDBPassword <> "" Then
Set NewDB = Workspaces(0).CreateDatabase("C:Program FilesCommon FilesWalker BrothersErrorHandler" & ErrMDB, dbLangGeneral & ";pwd=" & ErrMDBPassword)
Else
Set NewDB = Workspaces(0).CreateDatabase("C:Program FilesCommon FilesWalker BrothersErrorHandler" & ErrMDB, dbLangGeneral)
End If
'Now call the functions for each table
Dim b As Boolean
b = Error_Handler_Err_List
If b = False Then
Error_Handler_Create = False
NewDB.Close
Set NewDB = Nothing
Exit Function
End If
Error_Handler_Create = True
SetAttr "C:Program FilesCommon FilesWalker BrothersErrorHandler" & ErrMDB, vbHidden
Exit Function
Err_Handler:
If Err.Number <> 0 Then
Error_Handler_Create = False
NewDB.Close
Set NewDB = Nothing
Exit Function
End If
End Function
Public Function Error_Handler_Err_List() As Boolean
Dim TempTDef As TableDef
Dim TempField As Field
Dim TempIdx As Index
Error_Handler_Err_List = False
On Error GoTo Err_Handler
Set TempTDef = NewDB.CreateTableDef("ErrList")
Set TempField = TempTDef.CreateField("ErrDate", 8)
TempField.Attributes = 1
TempField.Required = False
TempField.OrdinalPosition = 0
TempTDef.Fields.Append TempField
TempTDef.Fields.Refresh
Set TempField = TempTDef.CreateField("ErrNum", 4)
TempField.Attributes = 1
TempField.Required = False
TempField.OrdinalPosition = 1
TempTDef.Fields.Append TempField
TempTDef.Fields.Refresh
Set TempField = TempTDef.CreateField("ErrDes", 12)
TempField.Attributes = 2
TempField.Required = False
TempField.OrdinalPosition = 2
TempField.AllowZeroLength = False
TempTDef.Fields.Append TempField
TempTDef.Fields.Refresh
Set TempField = TempTDef.CreateField("ErrNote", 12)
TempField.Attributes = 2
TempField.Required = False
TempField.OrdinalPosition = 3
TempField.AllowZeroLength = False
TempTDef.Fields.Append TempField
TempTDef.Fields.Refresh
Set TempField = TempTDef.CreateField("ErrUser", 10)
TempField.Attributes = 2
TempField.Required = False
TempField.OrdinalPosition = 4
TempField.Size = 50
TempField.AllowZeroLength = True
TempTDef.Fields.Append TempField
TempTDef.Fields.Refresh
NewDB.TableDefs.Append TempTDef
NewDB.TableDefs.Refresh
'Done, Close the objects
Set TempTDef = Nothing
Set TempField = Nothing
Set TempIdx = Nothing
Error_Handler_Err_List = True
Exit Function
Err_Handler:
If Err.Number <> 0 Then
Set TempTDef = Nothing
Set TempField = Nothing
Set TempIdx = Nothing
Error_Handler_Err_List = False
Exit Function
End If
End Function
Public Function CreateNewDirectory(ByVal NewDirectory As String) As Boolean
Dim sDirTest As String
Dim SecAttrib As SECURITY_ATTRIBUTES
Dim bSuccess As Boolean
Dim sPath As String
Dim iCounter As Integer
Dim sTempDir As String
Dim iFlag As Integer
On Error GoTo ErrorCreate
iFlag = 0
sPath = NewDirectory
If Right(sPath, Len(sPath)) <> "" Then
sPath = sPath & ""
End If
iCounter = 1
Do Until InStr(iCounter, sPath, "") = 0
iCounter = InStr(iCounter, sPath, "")
sTempDir = Left(sPath, iCounter)
sDirTest = Dir(sTempDir)
iCounter = iCounter + 1
'create directory
SecAttrib.lpSecurityDescriptor = &O0
SecAttrib.bInheritHandle = False
SecAttrib.nLength = Len(SecAttrib)
bSuccess = CreateDirectory(sTempDir, SecAttrib)
Loop
CreateNewDirectory = True
Exit Function
ErrorCreate:
CreateNewDirectory = False
Resume 0
End Function
' 'Usage
' Select Case Error_Handler_Doc("Name.mdb", Now, 123, "Description", "Notes")
' Case "True"
' Case "False"
' End Select