使用excel使工作表过期

我有一个excel工作表，我需要设置一个过期日期，这样当过期日期出现时，文件将变得无用，他们必须与我联系以获取文件的新版本

我编写了一个脚本，如果宏未启用，并且工作表显示必须启用宏才能继续，则强制显示第一个工作表并隐藏工作表2（其中包含日期）。一旦它们启用宏，第二张表就变为可见，并且它们可以利用这些数据。启用宏后，脚本将运行“过期日期”命令，如果当前日期超过过期日期，将显示一个消息窗口，提醒用户其文件已过期。问题是，关闭此消息窗口后，excel会提示用户保存、不保存或取消。如果用户选择取消，则出现的下一个消息框是到期日期窗口，其中到期日期报告他们还有负天数。然后，他们可以关闭该窗口并访问计算器

我已经尝试过下面的“ActiveWorkbook.Save=True”功能，但没有尝试过

Private子工作簿\u关闭前（取消为布尔值）
ActiveWorkbook.Saved=True
末端接头

它禁用了我的工作表，该工作表要求用户启用宏，这是不允许的，基本上使文件无用

我附上了VBA脚本，希望你们能帮忙

非常感谢

代码如下：

Private Const dsWarningSheet As String = "sheet1" 'Enter name of the Entry/Warning Page

私有子工作簿\u在保存之前（ByVal SaveAsUI为布尔值，Cancel为布尔值）

端接头

私有子工作簿_Open（）

端接头

私有子工作簿_Openxx（）

---

结束子项

关闭工作簿并告诉它不要保存。见下文

Dim wb as workbook
set wb = <yourworkbook>

wb.Close SaveChanges:=Excel.XlSaveAction.xlDoNotSaveChanges 

Dim wb as工作簿
设置wb=
wb.Close SaveChanges:=Excel.XlSaveAction.xlDoNotSaveChanges

这是我在这里的第一篇帖子。我为这个问题创建了一个解决方案，我想与您分享

如果要为Excel工作簿、外接程序等设置过期日期，可以使用以下代码，该代码将向用户发送消息，然后删除、关闭并卸载外接程序（如果是这样）

您只需将其添加到文件的“工作簿打开”事件中，然后在项目的VBA代码上输入密码

当过期日期出现并且用户打开该文件时，该文件将被完全删除

Private Sub Workbook_Open()

Dim exdate As Date
Dim i As Integer

anul = 2015   ' (year) change these according to your expiration date
luna = 11     '(month)
ziua = 1      '(day)     

exdate = DateSerial(anul, luna, ziua)

If Date > exdate Then
    MsgBox ("The application " & ThisWorkbook.Name & " has expired !" & vbNewLine & vbNewLine _
    & "Expiration set up date is: " & exdate & " :)" & vbNewLine & vbNewLine _
    & "Contact xxx person(you) to renew the version !"), vbCritical, ThisWorkbook.Name

    expired_file = ThisWorkbook.Path & "\" & ThisWorkbook.Name


   On Error GoTo ErrorHandler
With Workbooks(ThisWorkbook.Name)
    If .Path <> "" Then

        .Saved = True
        .ChangeFileAccess xlReadOnly

        Kill expired_file

        'get the name of the addin if it is addin and unistall addin
        If Application.Version >= 12 Then
         i = 5
        Else: i = 4
        End If

        If Right(ThisWorkbook.Name, i) = ".xlam" Or Right(ThisWorkbook.Name, i) = ".xla" Then
            wbName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - i)
             'uninstall addin if it is installed
             If AddIns(wbName).Installed = True Then
                AddIns(wbName).Installed = False
              End If
        End If

        .Close

    End If
End With

Exit Sub

End If

Exit Sub

ErrorHandler:
MsgBox "Fail to delete file.. "
Exit Sub

End Sub

Private子工作簿\u Open（）
将exdate变为日期
作为整数的Dim i
anul=2015'（年份）根据您的到期日期更改这些
月亮=11'（月）
ziua=1'（天）
exdate=DateSerial（anul、luna、ziua）
如果日期>exdate，则
MsgBox（“应用程序”&ThisWorkbook.Name&“已过期！”&vbNewLine&vbNewLine_
&过期设置日期为：“&exdate&“：）”&vbNewLine&vbNewLine_
&“请与xxx人员（您）联系以续订版本！”），vbCritical，This工作簿。名称
过期的\u文件=ThisWorkbook.Path&“\”&ThisWorkbook.Name
关于错误转到错误处理程序
使用工作簿（ThisWorkbook.Name）
如果.Path为“”，则
.Saved=True
.ChangeFileAccess xlReadOnly
杀死过期的文件
'获取加载项的名称（如果是加载项和unistall加载项）
如果Application.Version>=12，则
i=5
其他：i=4
如果结束
如果Right（ThisWorkbook.Name，i）=“.xlam”或Right（ThisWorkbook.Name，i）=“.xla”，则
wbName=Left（ThisWorkbook.Name，Len（ThisWorkbook.Name）-i）
'卸载加载项（如果已安装）
如果AddIns（wbName）.Installed=True，则
加载项（wbName）.Installed=False
如果结束
如果结束
.结束
如果结束
以
出口接头
如果结束
出口接头
错误处理程序：
MsgBox“无法删除文件…”
出口接头
端接头

现在，我的问题是，如何编写代码来检查用户使用文件的计算机或他离开公司的日期

我想一些代码，将不允许用户使用其他个人电脑的文件以外的工作。（为了在他们离开公司时不随身携带excel工具）

Dim myCount        'This line of code is optional
Dim i                     'This line of code is optional
On Error Resume Next
myCount = Application.Sheets.Count
Sheets(1).Visible = True
Range("A1").Select
For i = 2 To myCount
Sheets(i).Visible = xlVeryHidden
If i = myCount Then
End If
Next i
ActiveWorkbook.Save

Dim myCount        'This line of code is optional
Dim i                     'This line of code is optional
On Error Resume Next

myCount = Application.Sheets.Count
For i = 2 To myCount
Sheets(i).Visible = True
If i = myCount Then
Sheets(1).Visible = xlVeryHidden
End If
Next i

Dim wb as workbook
set wb = <yourworkbook>

wb.Close SaveChanges:=Excel.XlSaveAction.xlDoNotSaveChanges 

Private Sub Workbook_Open()

Dim exdate As Date
Dim i As Integer

anul = 2015   ' (year) change these according to your expiration date
luna = 11     '(month)
ziua = 1      '(day)     

exdate = DateSerial(anul, luna, ziua)

If Date > exdate Then
    MsgBox ("The application " & ThisWorkbook.Name & " has expired !" & vbNewLine & vbNewLine _
    & "Expiration set up date is: " & exdate & " :)" & vbNewLine & vbNewLine _
    & "Contact xxx person(you) to renew the version !"), vbCritical, ThisWorkbook.Name

    expired_file = ThisWorkbook.Path & "\" & ThisWorkbook.Name


   On Error GoTo ErrorHandler
With Workbooks(ThisWorkbook.Name)
    If .Path <> "" Then

        .Saved = True
        .ChangeFileAccess xlReadOnly

        Kill expired_file

        'get the name of the addin if it is addin and unistall addin
        If Application.Version >= 12 Then
         i = 5
        Else: i = 4
        End If

        If Right(ThisWorkbook.Name, i) = ".xlam" Or Right(ThisWorkbook.Name, i) = ".xla" Then
            wbName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - i)
             'uninstall addin if it is installed
             If AddIns(wbName).Installed = True Then
                AddIns(wbName).Installed = False
              End If
        End If

        .Close

    End If
End With

Exit Sub

End If

Exit Sub

ErrorHandler:
MsgBox "Fail to delete file.. "
Exit Sub

End Sub