VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "DebugRecorder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'Standard class declarations
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private ErStr           As String                 'holds text for last error encountered
Private IAmADll         As Boolean                'TRUE if module is running as a DLL
Private IniRead         As Boolean                'TRUE if .ini file has been read
Private MyIniFileName   As String                 'location of my .ini file
Private MyPath          As String                 'path where this code resides
'Class specific declarations
Private Const ModuleName = "Debug"
Const DebugLineLength = 100                       'Max length of text on a debug line; remainders are wrapped to succeeding lines
Const DebugStringLimit = 5000                     'Maximum length of DebugString
Dim CSV                 As CSVStrings
Dim Dbg                 As Integer                'debug flag; non-zero causes debug output
Dim DbgTS               As TextStream             'debug text file object
Dim DebugFile           As String                 'Fully qualified name of debugging file
Dim DebugString         As String                 'Retained debug information
Dim ErrorPOC            As String                 'Point of Contact for error reporting; format is 'lastname,firstname' or 'firstname lastname'; use '' to indicate apostrophe embedded in name
Dim ErrorsFound         As Boolean                'True if errors found during processing
Dim FSO                 As FileSystemObject       'file system object
Dim PrintDebug          As String                 'Y=print debug at termination; N=don't print
Private lSubst          As String                 'symbolic substitutions; %U=abc,%E=xyz, etc.

Public Property Let Substitutions(ByVal NewSubstitutions As String)
  lSubst = NewSubstitutions
End Property

Public Property Get Recording() As Boolean 'Returns TRUE if debug is being recorded
  Recording = Dbg <> 0
End Property

Private Function AddPath(s As String) As String 'Add path value to file name if not already specified
  If InStr(s, ":") = 0 And InStr(s, "\\") = 0 Then
    AddPath = MyPath + s                'no path given; add it
  Else
    AddPath = s                         'path already provided
  End If
End Function

Function ChangeChar(s As String, C1 As String, C2 As String) As String 'Change all occurances of C1 with C2 in the string S.
  Dim ans As String                     'result string
  Dim l As Long                         'position of C1 in Lcl
  Dim Lcl As String                     'internal copy of S
  Lcl = s
  If Lcl <> "" Then
    l = InStr(Lcl, C1)
  Else
    l = 0
  End If
  While l <> 0
    ans = ans + Left$(Lcl, l - 1) + C2
    Lcl = Right$(Lcl, Len(Lcl) - (l - 1 + Len(C1)))
    l = InStr(Lcl, C1)
  Wend
  ChangeChar = ans + Lcl
End Function

Private Function ConditionPath(s)       'Guarantees trailing \ on path value S
  Dim ans As String
  ans = Trim(s)
  If ans = "\" Then ans = ""            'eliminate \ only
  If ans <> "" Then                     'prevent \ only
    If Right$(ans, 1) <> "\" Then ans = ans & "\"
  End If
  ConditionPath = ans
End Function

Public Property Get Error() As String   'Returns text describing last error occurrance. Use clears the stored text.
  Error = ErStr
  ErStr = ""
End Property

Private Function Exists(FileName As String) As Boolean 'Returns TRUE if FileName exists.
  On Error Resume Next
  Exists = Len(Dir$(FileName)) <> 0 And FileName <> ""
  If Err <> 0 Then Exists = False
  On Error GoTo 0
End Function

Private Sub FormatError(SubName, ErrorNumber, Description, Optional ErrorLine As Integer = 0) 'Formats an error message as "ModuleName.SubName: ErrorNumber ErrorLine: Description"
  ErStr = ModuleName + "." + SubName + ": Error " + Trim(str(ErrorNumber))
  If ErrorLine <> 0 Then ErStr = ErStr + " at line " + Trim(str(ErrorLine))
  ErStr = ErStr + ": " + Description
End Sub

Private Sub FSplit(str As String, FilePath As String, FileName As String, Ext As String) 'Splits FileName into its parts
  Dim LName As String                   'local copy of FileName
  Dim I As Integer
  FileName = ""
  FilePath = ""
  Ext = ""
  LName = UCase$(str)
  I = InStr(LName, ".")
  If I <> 0 Then
    Ext = Right$(LName, Len(LName) - I + 1)
    LName = Left$(LName, I - 1)
  End If
  If InStr(LName, "\") = 0 Then
    FileName = LName
    Exit Sub                            'no path
  End If
  I = Len(LName)
  While I > 0 And Mid$(LName, I, 1) <> "\"
    I = I - 1
  Wend
  If I = 0 Then
    FileName = LName
  ElseIf I = Len(LName) Then
    FilePath = LName
  Else
    FilePath = Left$(LName, I)
    FileName = Right$(LName, Len(LName) - I)
  End If
End Sub

Private Sub GetProfile()
1  Dim s                   As String                 'temporary string
2  Dim cmd                 As String                 'substitution command
3  Dim rpl                 As String                 'substitution string
   Dim msg                 As String
4    On Error GoTo HandleTheError
5    Dbg = GetPrivateProfileInt(ModuleName, ModuleName, 0, MyIniFileName)
6    PrintDebug = UCase$(Left$(GetProfileText(ModuleName, "PrintDebug", "N"), 1))
7    ErrorPOC = GetProfileText(ModuleName, "ErrorPOC", "")
8    If ErrorPOC <> "" Then ErrorPOC = "'" + ErrorPOC + "'"
9    DebugFile = AddPath(GetProfileText(ModuleName, "DebugFile", UCase("c:\" + App.EXEName + ".txt")))
10   DebugString = ""
'11   On Error Resume Next
12   Call PutProfileText(ModuleName, ModuleName, str$(Dbg))
13   Call PutProfileText(ModuleName, "PrintDebug", PrintDebug)
14   Call PutProfileText(ModuleName, "ErrorPOC", ErrorPOC)
15   Call PutProfileText(ModuleName, "DebugFile", RemoveMyPath(DebugFile))
'16   On Error GoTo 0
17   If Dbg <> 0 Then                                'debug file is wanted
18     If lSubst <> "" Then
19       While lSubst <> ""
20         s = CSV.StringFrom(lSubst)
21         cmd = Left$(s, 2)
22         rpl = Right$(s, Len(s) - 3)
23         DebugFile = ChangeChar(DebugFile, cmd, rpl)
24       Wend
25     End If
26     If DbgTS Is Nothing Then                      'and not yet open
27       Set FSO = New FileSystemObject              'get the base object
28       Set DbgTS = FSO.CreateTextFile(DebugFile, True) 'open debug file
29     End If
30     s = "Debug profile for " + App.EXEName + _
                        " Version " + Trim(str(App.Major)) + "." + Trim(str(App.Minor)) + "." + Trim(str(App.Revision)) + _
                        " IniFileName=" + MyIniFileName + " ErrorPOC=" + ErrorPOC
31     Call DbgTS.WriteLine(s)                       'record essential facts)
32   End If
33   IniRead = True                                  '.ini has been read
34   '{AWHTE
35   Exit Sub
HandleTheError:
36   msg = "DebugRecorder.GetProfile|" + dbGetError
     If Err.Number = 70 Then
       msg = msg + ". Check the specification for DebugFile in the [Debug] section of " + MyIniFileName + " to make sure it points to a directory that is writeable."
       msg = msg + " The current DebugFile specification = " + DebugFile
     End If
     MsgBox msg, vbCritical, "This is BAD!"
37   Exit Sub
38   'AWHTE}
End Sub

Function GetProfileInt(PName As String, ItemName As String, Default As Long) As Long
  GetProfileInt = GetPrivateProfileInt(ByVal PName, ByVal ItemName, Default, MyIniFileName)
End Function

Private Function GetProfileText(PName As String, ItemName As String, Optional Default As String = "") As String 'Returns MyIniFileName contents from section [Pname] for item [ItemName]. Default provides a default value if nothing is found.
  Dim ans As String * 255
  Dim Result As Integer
  ans = ""
  Result = GetPrivateProfileString(ByVal PName, ByVal ItemName, ByVal Default, ans, Len(ans), MyIniFileName)
  ans = (Left$(ans, Result))
  If Trim(ans) = "" Then ans = Default
  GetProfileText = Trim(ans)
End Function

Private Function GetStringArg(Arg, Def) As String 'Interprets string argument Arg and returns "", Def, or Arg depending on what is found in Arg (Null, "", or string)
  Dim ans As String
  If IsNull(Arg) Then                   'no value desired; return empty string
    ans = ""
  ElseIf Arg = "" Then                  'argument value not given; use default value
    ans = Def
  Else                                  'use supplied argument value
    ans = Arg
  End If
  GetStringArg = ans
End Function

Function Pad(s As String, l As Long)    'postfix string with blanks to desired length
  Dim ans As String
  If Len(s) > l Then
    Pad = Left$(s, l)
    Exit Function
  End If
  ans = s
  While Len(ans) < l
    ans = ans & " "
  Wend
  Pad = ans
End Function

Private Sub PutProfileText(Sect As String, Item As String, V As String) 'Write string 'V' to the .ini file in section 'Sect' with the name 'Item'
  Dim Result As Integer
  Result = WritePrivateProfileString(ByVal Sect, ByVal Item, ByVal V, MyIniFileName)
End Sub

Private Function RemoveMyPath(s As String) As String 'If S begins with MyPath, returns S with MyPath removed. Otherwise returns S unchanged.
  'Using this with .ini files, allows them to be moved to new directories without
  'change as long as the associated data files are in the same directory as the program.
  If InStr(UCase$(s), UCase$(MyPath)) = 1 Then
    RemoveMyPath = Right$(s, Len(s) - Len(MyPath))
  Else
    RemoveMyPath = s
  End If
End Function

Public Sub SetupIni(APath As String, AnIniFile As String) 'Sets MyPath=APath and MyIniFileName=AnIniFile
  If APath <> "" Then MyPath = ConditionPath(APath)
  If AnIniFile <> "" Then MyIniFileName = AddPath(AnIniFile)
End Sub

Public Sub LogError(ByVal ErrorString As String) 'Log that an error has been found
  ErrorsFound = True
  Call Record("ErrorsFound set to TRUE because of following item!!!!!")
  Call Record(ErrorString)              'record the error
End Sub

Public Sub Record(DbgStr As String)               'Record debugging text
Dim I                   As Integer                'string length
Dim st                  As String                 'substring to print
Dim T                   As String                 'local copy of DbgStr
Dim tme                 As String                 'time stamp string
Dim pos                 As Integer
  If Not IniRead Then GetProfile                  'get .ini file data
  tme = Trim(str(Now)) + " "                      'build time stamp string
  T = Trim(DbgStr) + " "                          'make local copy of string
  While T > " "                                   'loop until we're done
    pos = Min(Len(T), DebugLineLength)            'move to end of display line
    While pos > 0 And InStr(" ,;()[]=|", Mid$(T, pos, 1)) = 0 'look backward for a blank
      pos = pos - 1
    Wend
    st = tme + Left$(T, pos)
    If tme <> "" Then tme = Pad("", Len(tme))
    T = Trim(Right$(T, Len(T) - pos)) + " "       'remove used part from source text
    If Dbg <> 0 And Not DbgTS Is Nothing Then
      Call DbgTS.WriteLine(st)                    'print what we have so far
    End If
    DebugString = DebugString + vbCrLf + st       'accumulate debug text
    If Len(DebugString) > DebugStringLimit Then   'string is longer than limit; we may clip off the front end
      If Not ErrorsFound Then                     'no errors found; clip retained text; else let it accumulate
        DebugString = Right$(DebugString, DebugStringLimit - 1000)
      End If
    End If
    T = Trim(Right$(T, Len(T) - I)) + " "         'toss out what we printed
  Wend
  DoEvents
End Sub

Private Sub Class_Initialize()
  IAmADll = (App.StartMode = vbSModeAutomation) 'TRUE if we are operating as a DLL
  If IAmADll Then
    MyPath = App.Path + "\"
    MyIniFileName = MyPath + App.EXEName + ".ini"
  Else
  End If
  IniRead = False
  Dbg = 0                               'debug flag; non-zero causes debug output
  DebugFile = ""                        'Fully qualified name of debugging file
  DebugString = ""                      'Retained debug information
  ErrorPOC = ""                         'Point of Contact for error reporting; format is 'lastname,firstname' or 'firstname lastname'; use '' to indicate apostrophe embedded in name
  ErrorsFound = False                   'True if errors found during processing
  PrintDebug = "N"                      'Y=print debug at termination; N=don't print
  lSubst = ""                   'turn off symbolic substitutions
  Set CSV = New CSVStrings
End Sub

Private Sub Class_Terminate()
  Dim s As String
  Dim Sndr As FileSender
  Set CSV = Nothing
  If Dbg <> 0 Then                      'debug file is open
    If ErrorsFound And ErrorPOC <> "" Then
      Set Sndr = New FileSender
      Call Sndr.MAPISend(ErrorPOC, "Automatic Error Report for " + App.EXEName, "", DebugFile)
      Set Sndr = Nothing
    End If
    If Not DbgTS Is Nothing Then        'close it
      DbgTS.Close
      Set DbgTS = Nothing
      If PrintDebug = "Y" Then          'print the debug file
        Printer.Orientation = vbPRORPortrait 'portrait orientation
        Printer.FontName = "Courier New" 'set the font
        Printer.FontSize = 8            'and it's size
        Open DebugFile For Input As #Dbg 're-open debug file
        While Not EOF(Dbg)              'loop through all records
          Line Input #Dbg, s            'read a record
          Printer.Print s               'print a record
        Wend
        Close #Dbg                      'close the file
        Printer.EndDoc                  'finish off the printing
      End If
    End If
  Else                                  'no debug file
    If ErrorsFound Then
      Set Sndr = New FileSender
      If IAmADll Then
        Call Sndr.MAPISend(ErrorPOC, "Automatic Error Report for " + App.EXEName, DebugString, "")
      Else
        Call Sndr.ExchangeSend(ErrorPOC, "", "Automatic Error Report for " + App.EXEName, DebugString)
      End If
      Set Sndr = Nothing
    End If
  End If
End Sub