我创建了一个 Excel 工作表，我想跟踪我公司中有哪些人使用它。目前在我公司内网免费下载，没有任何限制。
我想实现一个限制，即 Excel 工作表的 VBA 功能在使用 12 个月后停止工作。用户必须与我联系以获取某种“重新激活代码”，以让用户继续使用该表 12 个月。
如果用户不觉得 Excel 工作表有用，那么他们根本不需要重新激活代码。这可以在 Excel 中完成吗？
编辑 1:我需要留在 Excel 的范围内。我不想引入其他选项，例如使用 .exe 嵌入或限制在公司网站上下载 Excel 文件。谢谢。
最佳答案
我以前也遇到过类似的情况。
如果您希望您的用户在使用该应用程序时会在线，您可以在打开工作表时调用的子程序中发出一个简单的 http 请求；该请求可以包含用户名，并且您的服务器可以记录该请求(从而知道谁在使用该应用程序)。为了减少对用户的不便，请确保包含一些故障安全代码，以便在服务器无法访问/关闭时应用程序正常工作。
你需要知道如何做五件事:
如果您不知道如何做其中之一，请告诉我，我可以提供进一步的帮助(但我的回复会有一点延迟......)。所有这些的答案都可以在 SO 上找到，但综合起来可能需要一些努力。
解决方案
警告 - 这是一段很长的代码。我为自己写的和为你写的一样多……它可能需要进一步的解释。
第 1 步 将此代码添加到
ThisWorkbook为了响应正在打开的文件:Private Sub Workbook_Open()
On Error GoTo exitSub
registerUse
exitSub:
End Sub
registerUse打开工作簿时的 Sub。第 2 步 获取用户名。这是相当复杂的；创建一个名为“用户名”的模块并粘贴以下所有代码(注意 - 其中一部分是从 Dev Ashish 复制的，其余的 - 特别是处理 Mac 解决方案 - 是我自己的工作)。调用函数
currentUserName()获取当前用户名(如果它可以从网络解析“长名称”，它会；否则它将使用您用于登录的名称/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
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
softwareReg 的小 php 脚本。三列:user , application , 和 date (系统生成的时间戳)。通过以下形式的请求记录使用:http://www.floris.us/SO/logUse.php?name=myName&application=thisApplication
myName是根据 currentUserName() 的用户名和 thisApplication是您要注册的应用程序/工作簿的名称(可能包括版本号)。如果您想尝试，您可以直接在浏览器中执行此操作(尽管想法是 VBA 脚本会为您执行此操作...)您可以通过以下请求向同一页面请求使用摘要:
http://www.floris.us/SO/logUse.php?summary=thisApplication
all 时，将输出所有应用程序及其使用的表。 :http://www.floris.us/SO/logUse.php?summary=all
something 和 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();
}
}
?>
关于excel - 如何跟踪我的 Excel 工作表的用户？，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/21052675/