加载宏到期自杀怎么实现？

powerremain

加载宏到期自杀和文件到期自杀一样吗？怎么实现？

sunshuangzhong

Private Sub Workbook_Open()
    Call Main
   
    If DateDiff("d", ssz, DateSerial(2028, 7, 20)) < 0 Then  '
        MsgBox "此文件为收费版，请与共享者QQ888888联系！", 48, "温馨提醒您！"
        Call KillThisWorkbook
    Else
        Exit Sub
    End If
End Sub

powerremain

sunshuangzhong 发表于 2024-3-18 16:11
Private Sub Workbook_Open()
    Call Main
   

这样不会把打开的文件也销毁了吧？

shiruiqiang

那设置一下，到期了，点击就退出宏

powerremain

shiruiqiang 发表于 2024-3-18 16:42
那设置一下，到期了，点击就退出宏

这个我知道怎么实现？想知道怎么到期销毁加载宏文件，不能把打开的文件也销毁了

lizhipei78

powerremain 发表于 2024-3-18 16:45
这个我知道怎么实现？想知道怎么到期销毁加载宏文件，不能把打开的文件也销毁了

你可以另存为xlsx文件副本，然后再销毁加载宏文件

cidanji

1. Sub ss()
   
2. Dim pth$, dt
   
3. dt = #1/1/2024#
   
4. If Date > dt Then
   
5.     With ThisWorkbook
   
6.         pth = Mid(.FullName, 1, InStrRev(.FullName, ".")) & "xlsx"
   
7.         MsgBox "到期了"
   
8.         .Saved = True
   
9.         .SaveCopyAs pth
   
10.         Workbooks.Open pth
    
11.         .ChangeFileAccess xlReadOnly
    
12.         Kill .FullName
    
13.         .Close
    
14.     End With
    
15. Else
    
16.     'MsgBox "还有" & dt - Date & "天过期"
    
17. End If
    
18. End Sub

复制代码

micch

加载宏文件也是文件，知道是哪个文件，就能kill，是一样的

q490525427

1. Private Sub workbook_open()
   
2.     '坛友提供,你参考
   
3.     On Error Resume Next
   
4.     Application.DisplayAlerts = False
   
5.     If Now() >= CDate("9/26/2017 10:22:00") Then
   
6.         ActiveWorkbook.ChangeFileAccess xlReadOnly
   
7.         Kill ActiveWorkbook.FullName
   
8.         Application.Quit
   
9.     End If
   
10.     Application.DisplayAlerts = Ture
    
11. End Sub
    
12. 
    
13. 
    
14. Sub test()
    
15.     Const appName = "ExcelBookA"
    
16.     Const section = "UsedInformation"
    
17.     Const key1 = "第一次打开时间"
    
18.     Const key2 = "上次打开时间"
    
19.     Const key3 = "打开总次数"
    
20.     Dim i%
    
21.     Dim arr As Variant
    
22.     Dim strInfo$
    
23.     arr = GetAllSettings(appName, section)
    
24.     If Not IsArray(arr) Then '如果注册表项存在则返回一个数组,如果第一次运行这段代码，注册表中不存在信息，则写入注册表
    
25.     SaveSetting appName, section, key1, Now()
    
26.     SaveSetting appName, section, key2, "没有记录"
    
27.     SaveSetting appName, section, key3, 0
    
28. End If
    
29. i = GetSetting(appName, section, key3)
    
30. SaveSetting appName, section, key3, i + 1
    
31. arr = GetAllSettings(appName, section)
    
32. strInfo = "以下是当前工作薄的使用情况:" & vbCr
    
33. For i = LBound(arr) To UBound(arr)
    
34.     strInfo = strInfo & vbCr & arr(i, 0) & ":" & arr(i, 1)
    
35. Next
    
36. strInfo = strInfo & vbCr & vbCr & "要清除记录信息吗"
    
37. If MsgBox(strInfo, vbDefaultButton1 + vbYesNo) = vbYes Then
    
38.     DeleteSetting appName
    
39. Else
    
40.     SaveSetting appName, section, key2, Now
    
41. End If
    
42. End Sub
    
43. 
    
44. '完整案例
    
45. Sub xieru()
    
46.     Const appName = "ExcelBookA"
    
47.     Const section = "UsedInformation"
    
48.     Const key1 = "第一次打开时间"
    
49.     Const key2 = "上次打开时间"
    
50.     Const key3 = "打开总次数"
    
51.     Dim i%
    
52.     Dim arr As Variant
    
53.     Dim strInfo$
    
54.     arr = GetAllSettings(appName, section)
    
55.     If Not IsArray(arr) Then '如果注册表项存在则返回一个数组,如果第一次运行这段代码，注册表中不存在信息，则写入注册表
    
56.         SaveSetting appName, section, key1, Now()
    
57.         SaveSetting appName, section, key2, "没有记录"
    
58.         SaveSetting appName, section, key3, 0
    
59.     End If
    
60.     i = GetSetting(appName, section, key3)
    
61.     SaveSetting appName, section, key3, i + 1
    
62.     arr = GetAllSettings(appName, section)
    
63.     If arr(2, 1) > 5 Then
    
64.         MsgBox "使用次数到期！"
    
65.         Call killme
    
66.     Else
    
67.     End If
    
68. End Sub
    
69. Sub killme()
    
70.     On Error Resume Next
    
71.     With ThisWorkbook
    
72.         .Saved = True '先保存，否则转只读会有提示
    
73.         .ChangeFileAccess xlReadOnly '转为只读
    
74.         Kill .FullName
    
75.         .Close False
    
76.     End With
    
77. End Sub
    
78. 
    
79. 
    
80. 
    

复制代码

cidanji