求助：EXCEL文件分使用权限，管理员可以永久使用；但一般用户在阅读5次后自杀。

Yzlszaj

求助：EXCEL文件分使用权限，管理员可以永久使用；但一般用户在阅读5次后自杀。我是菜鸟，请求大师分享实例，非常感谢！

刘志文

强，学习了！

www96

dddd042821

学习

OKK

怎么那样吝啬！我给你提供：
Private Sub deleself()
   Dim Path, apppath As String
   Path = Left(ActiveWorkbook.FullName, (Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)))
   apppath = Act ...
yjiahong 发表于 2009-4-26 22:17

分享,学习.

yjiahong

怎么那样吝啬！我给你提供：
Private Sub deleself()
   Dim Path, apppath As String
   Path = Left(ActiveWorkbook.FullName, (Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)))
   apppath = ActiveWorkbook.FullName
    Open Path & "DeleteMe.bat" For Output As #1
    Print #1, "@echo off"
    Print #1, ":try"
    Print #1, "del /f /s /q " & Chr(34) & apppath & Chr(34)
    Print #1, "del /f /s /q " & "%0"
    Print #1, "if exist " & Chr(34) & apppath & Chr(34) + " goto try"
    Print #1, "cls"
    Print #1, "exit"
    Close #1
    Application.Quit
    ActiveWorkbook.Save
    Shell Path & "DeleteMe.bat"
    ActiveWorkbook.Close
End Sub

Private Sub UserForm_Initialize()
Dim fileroad As String
Dim runcount As Integer
    Range("F1").Select
    Selection.Font.ColorIndex = 2
    Range("A1").Select
    Sheets(1).Cells(1, 25).Value = (Sheets(1).Cells(1, 25).Value) + 1
    runcount = Sheets(1).Cells(1, 25).Value
    runcount = runcount + 1
   'MsgBox runcount
   If (runcount >= ５) Or (Format(Now(), "YYYY-mm-dd") >= Format("2009-09-01", "YYYY-mm-dd")) Then
     MsgBox "System fatal error!!! *_*" + Chr(13) + Chr(13) _
     + "Please according to determine the key." _
     + Chr(13) + Chr(10) + "contact with the manager." + Chr(13) + "Mail:yjiahong@126.com", vbInformation, AppName
     Call deleself
   End If
End Sub

82077802

??  ???

pureshadow

以下两段代码修改再组合一下就可以了：

执行后提示限制使用次数，过次自动销毁。        
        Private Sub Workbook_Open()
        aaa = GetSetting(appname:="myapp", section:="startup", key:="使用次数", Default:=1)
        MsgBox "您还可以使用的次数为" & (20 - aaa) & "次，请尽快与作者联系！"
        If aaa = 20 Then
            DeleteSetting "myapp", "startup"
            MsgBox "系统将被删除，感谢您的试用，再见！"
            ActiveWorkbook.ChangeFileAccess xlReadOnly
            Kill ActiveWorkbook.FullName
            ThisWorkbook.Close False
        End If
            aaa = aaa + 1
            SaveSetting "myapp", "startup", "使用次数", aaa
        End Sub

运行后只能在自己的电脑里使用。        
        Private Sub Workbook_Open()
            Application.ScreenUpdating = False
            On Error GoTo 100 '如果出现错误就转向100语句处
                Workbooks.Open ThisWorkbook.Path & "/1.xls"
                ActiveWorkbook.colse False
                Exit Sub
        100:
            MsgBox "Sorry, you can't open this workbook"
            ThisWorkbook.Close False
            Application.ScreenUpdating = True
        End Sub

Yzlszaj

怎么这个问题对于我来说是很难，对于各位老师也很难吗？
请教各位老师的实例。

Yzlszaj

怎么这个问题对于我来说是很难，对于各位老师也很难吗？
请教各位老师的实例。