How can I track users of my Excel worksheet? - excel

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.

Answer 1

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):
<?php
if (isset($_GET)) {
if (isset($_GET['user']) && isset($_GET['application'])) {
$user = $_GET['user'];
$application = $_GET['application'];
$mode = 1;
}
if (isset($_GET['summary'])) {
$application = $_GET['summary'];
$mode = 2;
}
// create database handle:
$dbhost = 'localhost';
$dbname = 'LoneStar';
$dbuser = 'DarkHelmet';
$dbpass = '12345';
try {
$DBH = new PDO("mysql:host=$dbhost;dbname=$dbname", $dbuser, $dbpass);
$DBH->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 = "</td><td width = 200 align = center>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 "<html><center><h1>The following is the last time these users accessed '" . $application . "'</h1><br>";
echo "<table border=1>";
echo "<t><td width = 100 align = center>user</td><td width = 200 align=center>last access</td><td width = 100 align = center>count".$table_hstring."</td></tr>";
while ($row = $STHread->fetch()){
if($application == "all") {
echo "<tr><td align = center>" . $row['user'] .
"</td><td align = center>" . $row['mDate'] .
"</td><td align = center>" . $row['uCount'] .
"</td><td align = center>" . $row['application'] . "</tr>";
}
else {
echo "<tr><td align = center>" . $row['user'] . "</td><td align = center>" . $row['mDate'] . "</td><td align = center>" . $row['uCount'] . "</tr>";
}
}
echo "</table></html>";
}
}
catch(PDOException $e) {
echo "error connecting!<br>";
echo $e->getMessage();
}
}
?>

Answer 2

Check this answer How to hide code in VBA applications
Apperantly you can lock VBA code. And in your VBA code you can connect to DB and run the checks for each user. Make user enter some password and make VBA close the file if user access expired.
Another question, user may turn off macros. So you need to create functionality, wich doesn't work without macros