能否用VBA判断Excel加载项是否首次激活并实现试用验证？

核心思路 #

加载项的Workbook_Open事件仅在Excel启动且加载项被激活（包括首次勾选加载项、Excel重启时加载项已启用）时触发，不会随用户打开新工作簿重复执行。要实现「首次激活/试用到期才弹密码」的逻辑，需把验证状态和试用信息存在用户本地（比如注册表）——因为xlam加载项是只读格式，无法直接在自身存储状态。

具体实现步骤 #

1. 替换加载项ThisWorkbook事件代码 #

以下是适配加载项的完整验证逻辑，通过注册表记录验证状态，避免重复弹窗：

Private Sub Workbook_Open()
    Dim regKey As String
    Dim lastValidatedDate As Date
    Dim currentTrialExpiry As Date
    Dim trials As Integer, passCnt As Integer
    Dim AllPassWords() As String
    Dim ExpDate() As Date
    Dim PassWord As String
    Dim i As Integer
    
    ' 定义注册表存储路径（仅当前用户可见，不会随工作簿转移）
    regKey = "HKEY_CURRENT_USER\Software\MyAddinTrial\"
    
    ' 初始化试用配置
    trials = 3
    passCnt = 4
    ReDim AllPassWords(1 To trials) As String
    AllPassWords(1) = "123"
    AllPassWords(2) = "456"
    AllPassWords(3) = "789"
    ReDim ExpDate(1 To trials) As Date
    ExpDate(1) = DateSerial(2023, 1, 30)
    ExpDate(2) = DateSerial(2023, 2, 28) ' 修正原代码的2月30日无效日期
    ExpDate(3) = DateSerial(2023, 3, 31)
    
    ' 获取当前有效的试用到期日
    currentTrialExpiry = GetCurrentValidExpiry(ExpDate)
    
    ' 读取上次验证通过的记录
    On Error Resume Next
    lastValidatedDate = CDate(CreateObject("WScript.Shell").RegRead(regKey & "LastValidated"))
    On Error GoTo 0
    
    ' 判断是否需要触发验证：首次激活（无注册表记录） 或 当前已过试用到期日
    If IsEmpty(lastValidatedDate) Or Date > currentTrialExpiry Then
        ' 执行密码验证流程
        For i = 1 To passCnt
            PassWord = InputBox("请输入试用密码，当前为" & GetTrialName(currentTrialExpiry, ExpDate) & "：")
            If PassWord = GetMatchingPassword(currentTrialExpiry, ExpDate, AllPassWords) Then
                ' 验证通过，更新注册表记录
                CreateObject("WScript.Shell").RegWrite regKey & "LastValidated", Date, "REG_SZ"
                MsgBox "验证成功！您还剩" & currentTrialExpiry - Date & "天试用期限"
                Exit For
            ElseIf i < passCnt Then
                MsgBox "密码错误，剩余" & passCnt - i & "次尝试机会"
            Else
                MsgBox "尝试次数用完，加载项将无法使用"
                ' 可选：禁用加载项的Public函数
                DisableAddinFunctions
            End If
        Next i
    End If
End Sub

' 辅助函数：获取当前有效的试用到期日
Private Function GetCurrentValidExpiry(expDates() As Date) As Date
    Dim d As Date
    For Each d In expDates
        If Date <= d Then
            GetCurrentValidExpiry = d
            Exit Function
        End If
    Next d
    ' 所有试用到期，返回过期日期触发验证
    GetCurrentValidExpiry = DateSerial(1900, 1, 1)
End Function

' 辅助函数：匹配当前到期日对应的密码
Private Function GetMatchingPassword(expiryDate As Date, expDates() As Date, passwords() As String) As String
    Dim i As Integer
    For i = 1 To UBound(expDates)
        If expDates(i) = expiryDate Then
            GetMatchingPassword = passwords(i)
            Exit Function
        End If
    Next i
    GetMatchingPassword = ""
End Function

' 辅助函数：返回当前试用阶段名称
Private Function GetTrialName(expiryDate As Date, expDates() As Date) As String
    Dim i As Integer
    For i = 1 To UBound(expDates)
        If expDates(i) = expiryDate Then
            GetTrialName = "第" & i & "阶段试用"
            Exit Function
        End If
    Next i
    GetTrialName = "试用已到期"
End Function

' 可选：禁用加载项的Public函数（试用失败时触发）
Private Sub DisableAddinFunctions()
    ' 可将Public函数替换为空实现，或添加到期提示逻辑
End Sub

2. 关键细节说明 #

• 注册表存储优势：用WScript.Shell读写注册表，记录验证状态，Excel重启或加载项重新激活时能精准判断是否需要再次验证。
• 触发时机控制：仅在「首次激活加载项（无注册表记录）」或「当前日期超过试用到期日」时，才会弹出密码输入框，用户打开新工作簿不会触发。
• 错误修正：原代码中DateSerial(2023,2,30)是无效日期，已修正为2月28日。

3. 加载项最终处理 #

• 给VBA工程设置密码保护：打开VBA编辑器→工具→VBAProject属性→保护选项卡，勾选「锁定工程以便查看」并设置密码。
• 另存为Excel加载项：文件→另存为→选择保存类型为「Excel加载项（*.xlam）」，用户安装后勾选激活时即触发验证逻辑。

内容的提问来源于stack exchange，提问作者Joshua Kilian