Error Handler Document

'*   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 Files\Common Files\Walker Brothers\ErrorHandler\" & 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 Files\Common Files\Walker Brothers\ErrorHandler\" & 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 Files\Common Files\Walker Brothers\ErrorHandler") = False Then
    Exit Function
  End If
  On Error GoTo Err_Handler
  If ErrMDBPassword <> "" Then
    Set NewDB = Workspaces(0).CreateDatabase("C:\Program Files\Common Files\Walker Brothers\ErrorHandler\" & ErrMDB, dbLangGeneral & ";pwd=" & ErrMDBPassword)
  Else
    Set NewDB = Workspaces(0).CreateDatabase("C:\Program Files\Common Files\Walker Brothers\ErrorHandler\" & 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 Files\Common Files\Walker Brothers\ErrorHandler\" & 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