Sub TrackAccessToProject()
' Local Variables
Const ForReading As Integer = 1, ForWriting As Integer = 2, ForAppending As Integer = 8
Const TristateUseDefault As Integer = -2, TristateTrue As Integer = -1, TristateFalse As Integer = 0
Dim objFileSystem As Object, objFile As Object, objFileStream As Object
Dim strFileName As String, strUserID As String, strDateTime As String
Dim strOpSys As String, strOffVer As String, strPCID As String
Dim intCounter As Integer
' Determine data to send to tracking text file ( .csv file )
strFileName = ThisWorkbook.FullName
strUserID = UserName
strPCID = PCName
strDateTime = Format(Now(), "mm/dd/yyyy hh:mm:ss")
strOpSys = UCase(Application.OperatingSystem)
If InStr(strOpSys, "WINDOWS") > 0 And InStr(strOpSys, "NT") > 0 Then strOpSys = "WinXP"
If InStr(strOpSys, "WINDOWS") > 0 And InStr(strOpSys, "NT") = 0 Then strOpSys = "Win98"
If InStr(strOpSys, "WINDOWS") > 0 And InStr(strOpSys, "NT") > 0 Then strOpSys = "Win07"
strOffVer = Application.Version
If strOffVer = "11.0" Then strOffVer = "Office 2003"
If strOffVer = "10.0" Then strOffVer = "Office 2002"
If strOffVer = "9.0" Then strOffVer = "Office 2000"
If strOffVer = "8.0" Then strOffVer = "Office 2007"
' Append this data to data workbook
Do While intCounter < 1000
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
[COLOR=blue] Set objFileStream = objFileSystem.OpenTextFile("[/COLOR][URL="file://\\THEFILEPATHGOESHERE.txt"][COLOR=blue]\\THEFILEPATHGOESHERE.txt[/COLOR][/URL][COLOR=yellow][COLOR=blue]", ForAppending, TristateFalse)[/COLOR]
[/COLOR] If Not IsNull(objFileStream) Then
objFileStream.Write strDateTime & "," & strUserID & "," & strFileName & "," & strOpSys & "," & strOffVer & "," & strPCID & Chr(13) & Chr(10)
objFileStream.Close
Exit Do
End If
intCounter = intCounter + 1
Application.StatusBar = intCounter
Loop
'' Track Project Opening
' Call TrackAccessToProject
End Sub