VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "DataLogger" Attribute VB_GlobalNameSpace = True Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit 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 Active As Boolean 'TRUE if logging is in use Private Cycles As Integer 'ini setting value; number of log files to use Private FSO As FileSystemObject 'file system object Private LgTS As TextStream 'Text stream where log is written Private LogFileMode As String 'ini setting value; APPEND or REWRITE Private LoggingFile As String 'ini setting value; name of file to log to Private LogSize As Long Private MakeLog As Integer 'ini setting value; <>0 means do logging Private MyIniFileName As String 'location of my .ini file Private MyPath As String 'path where this code resides Private PrintLog As String 'ini setting value; Y means print log at program end Private IAmADll As Boolean 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 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 Function Exists(FileName As String) As Integer 'Determine if FileName exists. Answer <> 0 (True) if it does. On Error Resume Next Exists = Len(Dir$(FileName)) <> 0 And FileName <> "" If Err <> 0 Then Exists = False End Function 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 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 Public Function Logging() As Boolean Logging = Active 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 Function RemoveMyPath(s As String) As String 'If S begins with MyPath, return S with MyPath removed. '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 WriteLog(s As String) 1 Dim i As Integer 2 Dim LogPath As String 3 Dim LogName As String 4 Dim LogExt As String 5 Dim TName As String 6 On Error GoTo HandleTheError 7 If MakeLog < 0 Then 'we have not yet looked at ini file; go do it 8 GetProfile_Logging 9 If Active Then 10 Call LgTS.WriteLine(str(Now) + " ***** Start Log for " + App.EXEName + " ***** Version " + Trim(str(App.Major)) + "." + Trim(str(App.Minor)) + "." + Trim(str(App.Revision))) 11 End If 12 End If 13 If Active Then 'logging is active 14 If FileLen(LoggingFile) > LogSize * 1000000 Then 'restart file 15 LgTS.Close 'close the active file 16 If Cycles >= 1 Then 'multiple logs being kept 17 Call FSplit(LoggingFile, LogPath, LogName, LogExt) 'decompose file name 18 TName = LogPath + LogName + "." 'save some time 19 For i = Cycles To 1 Step -1 'do the renames 20 If i = Cycles And Exists(TName + Trim(str(i))) Then 21 Kill TName + Trim(str(i)) 'kill file at the end of the set 22 End If 23 If i = 1 Then 24 Name LoggingFile As TName + Trim(str(i)) 'current file becomes .1 25 Else 26 If Exists(TName + Trim(str(i - 1))) Then '.1 becomes .2, etc. 27 Name TName + Trim(str(i - 1)) As TName + Trim(str(i)) 28 End If 29 End If 30 Next 'I 31 End If 32 Set LgTS = FSO.OpenTextFile(LoggingFile, ForWriting) 'open file starting from beginning 33 End If 34 LgTS.WriteLine str(Now) + " " + s 'output the log info 35 End If 37 Exit Sub HandleTheError: 38 Err.Raise Err.Number, "", "DataLogger.WriteLog: Line " + str(Erl) + " " + Err.Description 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 Set FSO = New FileSystemObject 'get the base object Active = False MakeLog = -1 End Sub Private Sub Class_Terminate() Close_Logging Set FSO = Nothing End Sub Sub Close_Logging() 1 Dim s As String 2 On Error GoTo HandleTheError 3 If Active Then 4 LgTS.Close 5 If PrintLog = "Y" Then 'print the log file 6 Printer.Orientation = vbPRORPortrait 'portrait orientation 7 Printer.FontName = "Courier New" 'set the font 8 Printer.FontSize = 8 'and it's size 9 Set LgTS = FSO.OpenTextFile(LoggingFile, ForReading) 're-open log file 10 While Not LgTS.AtEndOfStream 'loop through all records 11 s = LgTS.ReadLine 'read a record 12 Printer.Print s 'print a record 13 Wend 14 LgTS.Close 'close the file 15 Printer.EndDoc 'finish off the printing 16 End If 17 End If 18 Active = False 19 Set LgTS = Nothing 21 Exit Sub HandleTheError: 22 Err.Raise Err.Number, "", "DataLogger.Close_Logging: Line " + str(Erl) + " " + Err.Description End Sub Sub GetProfile_Logging() ' Load private .INI file info 1 On Error GoTo HandleTheError 2 Call Close_Logging 'close any existing log file first 3 MakeLog = GetProfileInt("Logging", "MakeLog", 0) 4 If MakeLog > 0 Then 5 LoggingFile = AddPath(UCase$(GetProfileText("Logging", "FileName", App.EXEName + ".log"))) 6 LogSize = GetProfileInt("Logging", "LogSize", 1) 7 If LogSize < 1 Then LogSize = 1 8 Cycles = GetProfileInt("Logging", "Cycles", 1) 9 PrintLog = UCase$(Left$(GetProfileText("Logging", "PrintLog", "N"), 1)) 10 LogFileMode = UCase$(GetProfileText("Logging", "FileMode", "ReWrite")) 11 If LogFileMode = "REWRITE" Then 12 Set LgTS = FSO.OpenTextFile(LoggingFile, ForWriting, True) 'open file starting from scratch 13 Else 14 Set LgTS = FSO.OpenTextFile(LoggingFile, ForAppending, True) 'open file starting from end 15 End If 16 Active = True 17 End If 18 Call PutProfileText("Logging", "MakeLog", str(MakeLog)) 19 Call PutProfileText("Logging", "FileName", RemoveMyPath(LoggingFile)) 20 Call PutProfileText("Logging", "LogSize", str(LogSize)) 21 Call PutProfileText("Logging", "Cycles", str(Cycles)) 22 Call PutProfileText("Logging", "FileMode", LogFileMode) 23 Call PutProfileText("Logging", "PrintLog", PrintLog) 25 Exit Sub HandleTheError: 26 Err.Raise Err.Number, "", "DataLogger.GetProfile_Logging: Line " + str(Erl) + " " + Err.Description End Sub