Excel Macro To Track Who Opens File

[JADownie]

I would like to create a macro that every time you open a workbook it writes the username and time it was opened to a hidden worksheet in the same (or different) workbook. First thing is that possible? Secondly if so, how?

If someone has done this or can provide me with any insight to a process for doing so, I would be greatly appreciative. Thanks!

 

[jeffreybrown]

Something like this...

Private Sub Workbook_Open()
Dim LR As Long
    With Sheets("Sheet1")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A" & LR + 1).Value = Time
        .Range("B" & LR + 1).Value = Environ("UserName")
    End With
End Sub

 

[JADownie]

Maybe...


I put this code on sheet 2 of my file, saved it and re-opened it, but nothing happened....



Private Sub Workbook_Open()
Dim LR As Long
With Sheets("Sheet2")
LR = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & LR + 1).Value = Time
.Range("B" & LR + 1).Value = Environ("UserName")
End With
End Sub

 

[jeffreybrown]

You need to place this macro on the ThisWorkbook module.

 

[ncraig]

What if my users don't save? Is there a way to show date to?

 

[combatvolcano]

What if my users don't save? Is there a way to show date to?

lol, if they don't save they don't save and it won't store it in the workbook

you could potentially use a module to append to a txt file on a network share instead... hrm... maybe I'll try that in some of mine

might be good to have usage statistics on the reports I send out

 

[ncraig]

Combatvolcano...
Thanks for the reply.
Ya you are right on the money with the TXT file, I have some code but, and maybe some sort of network protection is stoping it, cant seem to get it to work.

I put this in the "Workbook" sheet.

  Private Sub Workbook_Open()
'   Local Variables
'   Track Project Opening
    Call TrackAccessToProject
    Application.StatusBar = False
End Sub

 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

I put this in it's own module

 Option Explicit
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserName& Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long)
Private Const MAX_COMPUTERNAME_LENGTH As Long = 31

Public Function UserName()
    
'   Local Variables
    Dim strUserName     As String   ' Declare the buffer to hole the username
    Dim lngSize         As Long     ' This holds to size of the buffer
    Dim blnStatus       As Boolean  ' Declare variable to get success status
'   Initialize variables
    lngSize = 255
    strUserName = Space(lngSize)
'   Get UserName via API
    blnStatus = GetUserName(strUserName, lngSize)
    strUserName = Trim(strUserName)
    UserName = UCase(Mid(strUserName, 1, lngSize - 1))
'   GetUserName will return False if it fails
    If blnStatus = False Then
        MsgBox "The Call Failed!"
        Exit Function
    End If
'   Button only to be active iff ( Owner is logged in or is being emulated )
   If Worksheets("Permit_Tracking_#3.4_6-29-10").Range("dei_EmulateOtherUser") = "" Then
        UserName = UCase(Mid(strUserName, 1, lngSize - 1))
        Worksheets("Permit_Tracking_#3.4_6-29-10").Range("dei_EmulateOtherUser") = UCase(Mid(strUserName, 1, lngSize - 1))
    Else
        UserName = Worksheets("Permit_Tracking_#3.4_6-29-10").Range("dei_EmulateOtherUser")
    End If

End Function
Public Function PCName() As String
'   Local Variables
    Dim dwLen       As Long
    Dim strString   As String
'   Create a string buffer to return PC name
    dwLen = MAX_COMPUTERNAME_LENGTH + 1
    strString = String(dwLen, "X")
    
'   Get PC name via api
    GetComputerName strString, dwLen
    strString = Mid(strString, 1, dwLen)
    PCName = strString
End Function
Function IsUser_AOwner() As Boolean
'   Local Variables
    Dim strPCUser       As String, strOwners            As String
'   Get current user name
    strPCUser = UserName
'   Get owner list
    strOwners = Worksheets("Application Data").Range("ad_AppOwner").Offset(0, 1)
'   Test if current user is an owner
    IsUser_AOwner = False
    If InStr(strOwners, strPCUser) > 0 Then IsUser_AOwner = True
End Function

In the same location, on the shared drive, I created a txt file called "TrackProjAccess".

Ok...So...well first of I am NOT the creator of this code I am merely a Cut-n-paster. But I got this code to work as long as I greened out the "Button only to be active iff" portion of the code. And it only works for me, I tested it with my office nabers computer and got an error, damin runtime '9' error at the highlight above.

Maybe you can get it to work.

Thanks again for the reply.

 

[tjrobo19]

lol, if they don't save they don't save and it won't store it in the workbook

you could potentially use a module to append to a txt file on a network share instead... hrm... maybe I'll try that in some of mine

might be good to have usage statistics on the reports I send out

You can place an automatic save function. see below

Private Sub Workbook_Open()
Dim LR As Long
With Sheets("Sheet1")
LR = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & LR + 1).Value = Time
.Range("B" & LR + 1).Value = Environ("UserName")
ThisWorkbook.Save
End With
End Sub

 

[Question5]

If you copy and paste the excel file that has a tracker mod off of a network and put it on your local c drive. If you open the copied file, does the original still show that you opened it? Or does the original excel file need to be the one opened?

 

[Andrew Poulsom]

Welcome to MrExcel.

Data is written to the workbook that's opened.