溶液

Question

我已经创建了一个Excel工作表，我想跟踪我公司中的哪些人使用它。目前，它可以在我们公司的内部网上免费下载，不受任何限制。

我想实施限制，其中Excel工作表的VBA功能在使用12个月后停止工作。用户必须联系我以获取某种“重新激活代码”，以便让用户继续使用该工作表再过12个月。

如果用户没有找到有用的Excel工作表，那么他们根本不需要重新激活代码。这可以在Excel中完成吗？

编辑1：我需要保持在Excel的范围内。我不想引入其他选项，例如嵌入.exe或在公司网站上下载Excel文件时创建限制。感谢。

Answer 1

我以前遇到过类似的情况。

如果您希望用户在使用该应用程序时将在线，您可以在打开工作表时调用的子内部发出简单的http请求;该请求可以包含用户名，您的服务器可以记录请求（从而知道谁在使用该应用程序）。为了减少用户的不便，请确保包含一些故障安全代码，以便在无法访问/关闭服务器时应用程序正常工作。

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

打开工作表时运行代码
请求在请求中插入用户（网络）名称
从VBA内部发出http请求（处理PC和Mac之间的差异......）
优雅地处理请求失败（不要使工作表瘫痪）
记录请求，以便获得有关使用的信息

如果您不知道如何做其中的一项，请告诉我，我可以进一步提供帮助（但我的回复会有一些延迟......）。所有这些的答案都可以在SO上找到，但合成可能需要一些努力。

溶液

警告 - 这是一段怪物代码。我为自己写的和你一样多......可能需要进一步解释。

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

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

在打开工作簿时调用registerUse Sub。

第2步获取用户名。这非常复杂;创建一个名为“username”的模块并粘贴以下所有代码（注意 - 其中一部分是从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

第3步＆amp; 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步：记录请求。为此，我写了一个小的PHP脚本，用三列更新表softwareReg：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

这将创建一个使用汇总表，其中包含用户名和最后使用日期，按“最多注册数”排序 - 换句话说，最常用的用户将位于顶部。显然你可以改变格式，排序顺序等 - 但这应该满足你的基本要求。我模糊了用户名，密码等，但这是在上面的URL运行的代码。玩它，看看你是否可以让它工作。同一个数据库可以记录多个应用程序/工作簿的注册;现在，当参数是应用程序的名称时，脚本将为一个应用程序吐出结果，或者当参数为all时，所有应用程序及其使用的表格都会吐出一个应用程序的结果：

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

会生成这样的表格（用于测试我使用的应用程序名称something和nothing）：

enter image description here

<?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

检查此答案How to hide code in VBA applications 显然你可以锁定VBA代码。在您的VBA代码中，您可以连接到DB并为每个用户运行检查。如果用户访问权限过期，请让用户输入一些密码并使VBA关闭文件。

另一个问题，用户可能会关闭宏。因此，您需要创建功能，如果没有宏，则无法正常工作

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

2 个答案:

溶液