How can I track users of my Excel worksheet?

Question

I've created an Excel worksheet and I would like to track who in my company uses it. Currently, it's freely available on our company intranet for downloading without any restriction.

I would like to implement a restriction where the Excel worksheet's VBA functionality stops working after 12 months of use. The user would have to contact me for an "reactivation code" of some sort to let the user continue using the sheet for another 12 months.

If the user doesn't find the Excel worksheet useful then they simply don't need a reactivation code. Is this possible to do within Excel?

EDIT 1: I need to stay within the confines of Excel. I don't want to bring in other options like embedding with an .exe or creating restrictions on the downloading of the Excel file on the company website. Thanks.

Floris · Accepted Answer

I have run into a similar situation previously.

If you expect that your users are going to be online when they use the application, you can make a simple http request from within a sub that's called when the worksheet is opened; that request can include the user name, and your server can log the request (and thus know who is using the application). To make it less inconvenient for the users, make sure that you include some failsafe code so that the application works normally when the server cannot be reached / is down.

You need to know how to do five things:

Run code when the worksheet is opened
Request the user (network) name to insert in the request
Make an http request from inside VBA (handle differences between PC and Mac...)
Handle failure of the request gracefully (don't cripple the worksheet)
Log the request so you have information about the use

Let me know if you don't know how to do one of these, and I can help further (but there will be a bit of delay in my response...). Answers for all these can be found on SO, but the synthesis may take some effort.

solution

Warning - this is a bit of a monster piece of code. I wrote it as much for myself as for you... It may need further explanation.

step 1 Add this code to ThisWorkbook in order to respond to the file being opened:

Private Sub Workbook_Open()
  On Error GoTo exitSub
  registerUse
  exitSub:
End Sub

This calls the registerUse Sub when the workbook is opened.

step 2 get the user name. This is quite complex; create a module called "username" and paste in all the following code (note - a chunk of this was copied from Dev Ashish, the rest - in particular, dealing with the Mac solution - is my own work). Call the function currentUserName() to get the current user name (if it can resolve the "long name" from the network, it will; otherwise it will use the name/ID you use to log in with):

' ******** Code Start ********
'This code was originally written by Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'
' Modifications by Floris - mostly to make Mac compatible

Private Type USER_INFO_2
    usri2_name As Long
    usri2_password  As Long  ' Null, only settable
    usri2_password_age  As Long
    usri2_priv  As Long
    usri2_home_dir  As Long
    usri2_comment  As Long
    usri2_flags  As Long
    usri2_script_path  As Long
    usri2_auth_flags  As Long
    usri2_full_name As Long
    usri2_usr_comment  As Long
    usri2_parms  As Long
    usri2_workstations  As Long
    usri2_last_logon  As Long
    usri2_last_logoff  As Long
    usri2_acct_expires  As Long
    usri2_max_storage  As Long
    usri2_units_per_week  As Long
    usri2_logon_hours  As Long
    usri2_bad_pw_count  As Long
    usri2_num_logons  As Long
    usri2_logon_server  As Long
    usri2_country_code  As Long
    usri2_code_page  As Long
End Type

 
Private Declare Function apiNetGetDCName _
    Lib "netapi32.dll" Alias "NetGetDCName" _
    (ByVal servername As Long, _
    ByVal DomainName As Long, _
    bufptr As Long) As Long
 
' function frees the memory that the NetApiBufferAllocate
' function allocates.
Private Declare Function apiNetAPIBufferFree _
    Lib "netapi32.dll" Alias "NetApiBufferFree" _
    (ByVal buffer As Long) _
    As Long
 
' Retrieves the length of the specified wide string.
Private Declare Function apilstrlenW _
    Lib "kernel32" Alias "lstrlenW" _
    (ByVal lpString As Long) _
    As Long
 
Private Declare Function apiNetUserGetInfo _
    Lib "netapi32.dll" Alias "NetUserGetInfo" _
    (servername As Any, _
    username As Any, _
    ByVal level As Long, _
    bufptr As Long) As Long
 
' moves memory either forward or backward, aligned or unaligned,
' in 4-byte blocks, followed by any remaining bytes
Private Declare Sub sapiCopyMem _
    Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
    Source As Any, _
    ByVal Length As Long)
 
Private Declare Function apiGetUserName Lib _
    "advapi32.dll" Alias "GetUserNameA" _
    (ByVal lpBuffer As String, _
    nSize As Long) _
    As Long
 
Private Const MAXCOMMENTSZ = 256
Private Const NERR_SUCCESS = 0
Private Const ERROR_MORE_DATA = 234&
Private Const MAX_CHUNK = 25
Private Const ERROR_SUCCESS = 0&
 
Function currentUserID()
' added this function to isolate user from windows / mac differences
' hoping this works!
' note - one can also use Application.OperatingSystem like "*Mac*" etc.

Dim tempString
On Error GoTo CUIerror
tempString = "Unknown"

#If Win32 Or Win64 Then
  tempString = fGetUserName
#Else
  tempString = whoIsThisMacID
#End If

' trim string to correct length ... there's some weirdness in the returned value
' we fall to this point if there's an error in the lower level functions, too
' in that case we will have the default value "Unknown"
CUIerror:
currentUserID = Left(tempString, Len(tempString))

End Function

Function currentUserName()
Dim tempString

On Error GoTo CUNerror
tempString = "Unknown"

#If Win32 Or Win64 Then
  tempString = fGetFullNameOfLoggedUser
#Else
  tempString = whoIsThisMacName
#End If

' trim string to get rid of weirdness at the end...
' and fall through on error:
CUNerror:
currentUserName = Left(tempString, Len(tempString))

' in some cases the lower level functions return a null string:
If Len(currentUserName) = 0 Then currentUserName = currentUserID

End Function

#If Mac Then
Function whoIsThisMacID()
Dim sPath As String, sCmd As String

On Error GoTo WIDerror

sPath = "/usr/bin/whoami"
 
sCmd = "set RetVal1 to do shell script """ & sPath & """"
whoIsThisMacID = MacScript(sCmd)
Exit Function

WIDerror:
  whoIsThisMacID = "unknown"
  
End Function

Function whoIsThisMacName()
' given the user ID, find the user name using some magic finger commands...
Dim cmdString As String
Dim sCmd As String

On Error GoTo WHOerror
' use finger command to find out more information about the current user
' use grep to strip the line with the Name: tag
' use sed to strip out string up to and including 'Name: "
' the rest of the string is the user name
cmdString = "/usr/bin/finger " & whoIsThisMacID & " | /usr/bin/grep 'Name:' | /usr/bin/sed 's/.*Name: //'"

' send the command to be processed by AppleScript:
sCmd = "set RetVal1 to do shell script """ & cmdString & """"

whoIsThisMacName = MacScript(sCmd)
Exit Function

WHOerror:
whoIsThisMacName = "unknown"

End Function

Sub testName()
MsgBox whoIsThisMacName

End Sub
#End If

' do not compile this code if it's not a windows machine... it's not going to work!
#If Win32 Or Win64 Then

Function fGetFullNameOfLoggedUser(Optional strUserName As String) As String
'
' Returns the full name for a given UserID
'   NT/2000 only
' Omitting the strUserName argument will try and
' retrieve the full name for the currently logged on user
'
On Error GoTo ErrHandler
Dim pBuf As Long
Dim dwRec As Long
Dim pTmp As USER_INFO_2
Dim abytPDCName() As Byte
Dim abytUserName() As Byte
Dim lngRet As Long
Dim i As Long
 
    ' Unicode
    abytPDCName = fGetDCName() & vbNullChar
    If (Len(strUserName) = 0) Then strUserName = fGetUserName()
    abytUserName = strUserName & vbNullChar
 
    ' Level 2
    lngRet = apiNetUserGetInfo( _
                            abytPDCName(0), _
                            abytUserName(0), _
                            2, _
                            pBuf)
    If (lngRet = ERROR_SUCCESS) Then
        Call sapiCopyMem(pTmp, ByVal pBuf, Len(pTmp))
        fGetFullNameOfLoggedUser = fStrFromPtrW(pTmp.usri2_full_name)
    End If
 
    Call apiNetAPIBufferFree(pBuf)
ExitHere:
    Exit Function
ErrHandler:
    fGetFullNameOfLoggedUser = vbNullString
    Resume ExitHere
End Function
 
Function fGetUserName() As String
' Returns the network login name
On Error GoTo FGUerror
Dim lngLen As Long, lngRet As Long
Dim strUserName As String
    strUserName = String$(254, 0)
    lngLen = 255
    lngRet = apiGetUserName(strUserName, lngLen)
    If lngRet Then
        fGetUserName = Left$(strUserName, lngLen - 1)
    End If
Exit Function

FGUerror:
MsgBox "Error getting user name: " & Err.Description
fGetUserName = ""

End Function
 
Function fGetDCName() As String
Dim pTmp As Long
Dim lngRet As Long
Dim abytBuf() As Byte
On Error GoTo FGDCerror

    lngRet = apiNetGetDCName(0, 0, pTmp)
    If lngRet = NERR_SUCCESS Then
        fGetDCName = fStrFromPtrW(pTmp)
    End If
    Call apiNetAPIBufferFree(pTmp)
Exit Function

FGDCerror:
MsgBox "Error in fGetDCName: " & Err.Description
fGetDCName = ""

End Function
 
Private Function fStrFromPtrW(pBuf As Long) As String
Dim lngLen As Long
Dim abytBuf() As Byte
 
On Error GoTo FSFPerror

' Get the length of the string at the memory location
    lngLen = apilstrlenW(pBuf) * 2
    ' if it's not a ZLS
    If lngLen Then
        ReDim abytBuf(lngLen)
        ' then copy the memory contents
        ' into a temp buffer
        Call sapiCopyMem( _
                abytBuf(0), _
                ByVal pBuf, _
                lngLen)
        ' return the buffer
        fStrFromPtrW = abytBuf
    End If
    Exit Function
    
FSFPerror:
MsgBox "Error in fStrFromPtrW: " & Err.Description
fStrFromPtrW = ""

End Function
' ******** Code End *********
#End If

steps 3 & 4 form an HTTP request, and send it to a server; handle failure gracefully (note - right now "gracefully" involves an error message; you can comment it out, and then the user will notice just a slight delay when opening the workbook and nothing else). Paste the following code in another module (call it 'registration'):

Option Explicit
Option Compare Text

' use the name of the workbook you want to identify:
Public Const WB_NAME = "logMe 1.0"
' use the URL of the script that handles the request
' this one works for now and you can use it to test until you get your own solution up
Public Const DB_SERVER = "http://www.floris.us/SO/logUsePDO.php"

Sub registerUse()
' send http request to a server
' to log "this user is using this workbook at this time"
Dim USER_NAME As String
Dim regString As String
Dim response As String

' find the login name of the user:
USER_NAME = currentUserName()

' create a "safe" registration string by URLencoding the user name and workbook name:
regString = "?user=" & URLEncode(USER_NAME) & "&application=" & URLEncode(WB_NAME, True)

' log the use:
response = logUse(DB_SERVER & regString)

' remove the success / fail message box when you are satisfied this works; it gets annoying quickly:
If response = "user " & USER_NAME & " logged successfully" Then
  MsgBox "logging successful"
Else
  MsgBox "Response: " & response
End If
End Sub


'----------------------
' helper functions

' URLencode
' found at http://stackoverflow.com/a/218199/1967396
Public Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False _
) As String

  Dim StringLen As Long: StringLen = Len(StringVal)

  If StringLen > 0 Then
    ReDim result(StringLen) As String
    Dim i As Long, CharCode As Integer
    Dim Char As String, Space As String

    If SpaceAsPlus Then Space = "+" Else Space = "%20"

    For i = 1 To StringLen
      Char = Mid$(StringVal, i, 1)
      CharCode = Asc(Char)
      Select Case CharCode
        Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
          result(i) = Char
        Case 32
          result(i) = Space
        Case 0 To 15
          result(i) = "%0" & Hex(CharCode)
        Case Else
          result(i) = "%" & Hex(CharCode)
      End Select
    Next i
    URLEncode = Join(result, "")
  End If
End Function

Function logUse(s As String)
  Dim MyRequest As Object
  Set MyRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
  On Error GoTo noLog
  
  ' MsgBox "Sending request " & s
  MyRequest.Open "GET", s
  
  ' Send Request.
  MyRequest.Send

  'And we get this response
  logUse = MyRequest.ResponseText
  Exit Function
noLog:
  logUse = "Error: " & Err.Description
End Function

step 5: log the request. For this I wrote a small php script that updates a table softwareReg with three columns: user, application, and date (a system generated timestamp). The use is logged by making a request of the form:

http://www.floris.us/SO/logUse.php?name=myName&application=thisApplication

where myName is the name of the user according to currentUserName() and thisApplication is the name (maybe including the version number) of the application / workbook you want to register. You can do this right from your browser if you want to try (although the idea is that the VBA script will do it for you...)

You can request a summary of use with the following request to the same page:

http://www.floris.us/SO/logUse.php?summary=thisApplication

This will create a summary table of use, with names of users and the last date of use, sorted by "most number of registrations" - in other words, the most frequent users will be at the top. Obviously you could change the format, sort order, etc - but this should fulfill your basic requirement. I obfuscated the user names, passwords etc, but otherwise this is the code that runs at the above URL. Play with it and see if you can get it to work. The same database can record registrations for multiple applications / workbooks; right now the script will spit out results for one application at a time when the argument is the name of the application, or a table of all the applications and their use when the argument is all:

http://www.floris.us/SO/logUse.php?summary=all

Will produce a table like this (for testing I used application names something and nothing):

enter image description here

setAttribute( PDO::ATTR_ERRMODE, PDO::ERRMODE_WARNING ); 
    $STHinsert = $DBH->prepare("INSERT INTO softwareReg( user, application ) value (?, ?)");
    if($mode == 1) {
      $dataInsert = array($user, $application);  
      $STHinsert->execute($dataInsert);
      echo "user " . $user . " logged successfully";
    }
    if($mode == 2) {
      if ($application == "all") {
        $astring = ""; 
        $table_hstring = "application";
      }
      else {
        $astring = "WHERE application = ?";
        $table_hstring = "";
      }
      $STHread = $DBH->prepare("SELECT user, date, max(date) as mDate, count(user) as uCount, application FROM softwareReg ".$astring." GROUP BY user, application ORDER BY application, uCount DESC");
      $dataRead = array($application);
      $STHread->setFetchMode(PDO::FETCH_ASSOC);  
      $STHread->execute($dataRead);
      echo "The following is the last time these users accessed '" . $application . "'

";
      echo "";
      echo "";
      while ($row = $STHread->fetch()){
        if($application == "all") {
           echo "";
       }
        else {
          echo "";
        }
        
      }
      echo "user last access count".$table_hstring."
" . $row['user'] . 
             " " . $row['mDate'] . 
             " " . $row['uCount'] . 
             " " . $row['application'] . "
" . $row['user'] . " " . $row['mDate'] . " " . $row['uCount'] . "";  
    }
  }
  catch(PDOException $e) {  
    echo "error connecting!
";
    echo $e->getMessage();  
  }      
}       
?>

How can I track users of my Excel worksheet?

Answers (2)

solution

Related Questions