如何跟踪我的Excel工作表的用户？

我已经创build了一个Excel工作表，我想跟踪我公司中的谁使用它。 目前，我们的公司内部网免费提供下载，没有任何限制。

我想要在Excel工作表的VBAfunction在使用12个月后停止工作的情况下实施限制。 用户将不得不联系我一些“重新激活代码”，让用户继续使用该表12个月。

如果用户没有find有用的Excel工作表，那么他们根本就不需要重新激活代码。 这可能在Excel中做？

编辑1：我需要留在Excel的范围内。 我不想引入其他选项，如使用.exeembedded或在公司网站上下载Excel文件时创build限制。 谢谢。

Answer 1

我以前遇到类似的情况。

如果您希望用户在使用应用程序时将要联机，则可以在打开工作表时调用一个子内部的简单http请求; 该请求可以包含用户名，服务器可以logging该请求（从而知道谁在使用该应用程序）。 为了减less用户的不便，请确保包含一些故障安全代码，以便服务器无法到达/closures时应用程序正常工作。

你需要知道如何做五件事情：

1. 工作表打开时运行代码
2. 请求用户（networking）名称插入请求
3. 从VBA内部处理http请求（处理PC和Mac之间的差异…）
4. 正常处理请求失败（不要削弱工作表）
5. logging请求，以便获得有关使用的信息

让我知道如果你不知道如何去做其中的一个，我可以进一步提供帮助（但是我的回应会有一些延迟…）。 所有这些的答案都可以在SO上find，但综合可能需要一些努力。

解

警告 – 这是一段怪异的代码。 我为自己写了这么多的东西，可能需要进一步的解释。

步骤1将此代码添加到ThisWorkbook以响应正在打开的文件：

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

这将打开工作簿时调用registerUse Sub。

第2步获取用户名。 这很复杂， 创build一个名为“用户名”的模块并粘贴下面所有的代码（注意 – 其中的一部分是从Dev Ashish复制的，其余部分 – 特别是处理Mac解决scheme – 是我自己的工作）。 调用函数currentUserName()获取当前用户名（如果它可以parsing来自networking的“长名称”，它将会;否则它将使用您用来login的名称/ ID）：

 ' ******** 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 

第3步和第4步形成一个HTTP请求，并发送给服务器; 处理失败优雅（注意 – 现在“优雅地”涉及一个错误信息;你可以注释掉，然后用户在打开工作簿时就会注意到一点点的延迟）。 将以下代码粘贴到另一个模块（称为“注册”）：

 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 

第5步：logging请求。 为此，我编写了一个小php脚本，用三个列更新表softwareReg ： user ， application和date （系统生成的时间戳）。 通过提交表单的请求logging使用情况：

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

其中myName是根据currentUserName()的用户名称， thisApplication是您要注册的应用程序/工作簿的名称（可能包括版本号）。 如果你想尝试的话，你可以从你的浏览器中做到这一点（虽然这个想法是VBA脚本会为你做…）

您可以使用以下请求向同一页面请求使用摘要：

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

这将创build一个使用摘要表，用户名和最后使用date按“最多注册次数”sorting – 换句话说，最常见的用户将位于最前面。 显然你可以改变格式，sorting顺序等 – 但这应该满足你的基本要求。 我混淆了用户名称，密码等，但否则这是在上述URL运行的代码。 玩它，看看你能否得到它的工作。 同一个数据库可以logging多个应用程序/工作簿的注册; 现在脚本会在参数是应用程序名称的时候吐出一个应用程序的结果，或者当参数是all时，所有应用程序和它们的使用的表格：

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

会产生这样的表（用于testing我使用的应用程序名称和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

检查此答案如何在VBA应用程序中隐藏代码显然，您可以lockingVBA代码。 而在你的VBA代码中，你可以连接到数据库并为每个用户运行检查。 让用户input一些密码，并在用户访问过期时使VBAclosures文件。

另一个问题，用户可能会closuresmacros。 所以你需要创buildfunction，这是没有macros没有工作