Excel Trial Period VB Code Editng Need Help

Question

0.00/5 (No votes)

See more:

i Have To editing in this code below For Then The Trial Period Expired My Workbook gos Very Hidden ...
I need to set very hidden Cammad Also Repley

Option Explicit
Private Sub Workbook_Open()
      Dim StartTime#, CurrentTime#
      '*****************************************
      'SET YOUR OWN TRIAL PERIOD BELOW
      'Integers (1, 2, 3,...etc) = number of days use
      '1/24 = 1Hr, 1/48 = 30Mins, 1/144 = 10Mins use
      
      Const TrialPeriod# = 0     '< 10000 day trial
      'set your own obscure path and file-name
      Const ObscurePath$ = "C:\"
      Const ObscureFile$ = "aamir.Log"
      '*****************************************
      If Dir(ObscurePath & ObscureFile) = Empty Then
            StartTime = Format(Now, "#0.#########0")
            Open ObscurePath & ObscureFile For Output As #1
            Print #1, StartTime
      Else
            Open ObscurePath & ObscureFile For Input As #1
            Input #1, StartTime
            CurrentTime = Format(Now, "#0.#########0")
            If CurrentTime < StartTime + TrialPeriod Then
                  Close #1
                  Exit Sub
            Else
                  If [A1] <> "Expired" Then
                        MsgBox "Sorry, your trial period has expired - your data" & vbLf & _
                        " www.xxxxxxx.com for your..." & vbLf & _
                        "" & vbLf & _
                        "This workbook will then be made unusable."
                        Close #1
                        SaveShtsAsBook
                        [A1] = "Expired"
                        ActiveWorkbook.Save
                        Application.Quit
                  ElseIf [A1] = "Expired" Then
          Worksheets("Sheet1").Visible = xlSheetVeryHidden
                        Close #1
                        Application.Quit
                  End If
            End If
      End If
      Close #1
End Sub
Sub SaveShtsAsBook()
      Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
      MyFilePath$ = ActiveWorkbook.Path & "\" & _
                    Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
      With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            On Error Resume Next    '<< a folder exists
            MkDir MyFilePath            '<< create a folder
             .Close SaveChanges:=True
                  End With
                  
            
      
            Open MyFilePath & "\READ ME.log" For Output As #1
            Print #1, "Thank you for trying out this product."
            Print #1, "If it meets your requirements, visit"
            Print #1, "http://www.xxxxxxxxx.net.tc to Resloved"
            Print #1, "the full (unrestricted) version..."
            Close #1
End Sub

Posted 7-Apr-11 20:40pm

Muhammad Aamir SumSum

Updated 7-Apr-11 20:41pm

Wendelius

v2

Add a Solution

Comments

Wendelius 8-Apr-11 2:41am

pre tags added

Maciej Los 9-Apr-11 7:36am

I can't understand why are you save some data into log file. Can't you use DocumentProperty or windows registry to save expired date? It's simplest. Which version of Excel? Is it Excel Addin?

1 solution

Add a Solution

Add your solution here

Treat my content as plain text, not as HTML

Preview 0

…

Existing Members

Sign in to your account

...or Join us

Download, Vote, Comment, Publish.

Your Email
Password
Forgot your password?

Your Email
This email is in use. Do you need your password?
Optional Password

I have read and agree to the Terms of Service and Privacy Policy
Please subscribe me to the CodeProject newsletters

When answering a question please:

Read the question carefully.
Understand that English isn't everyone's first language so be lenient of bad spelling and grammar.
If a question is poorly phrased then either ask for clarification, ignore it, or edit the question and fix the problem. Insults are not welcome.
Don't tell someone to read the manual. Chances are they have and don't get it. Provide an answer or move on to the next question.

Let's work to help developers, not make them feel stupid.

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

Maciej Los · Answer 1 · 2011-04-10T08:35:00

If file isn't Excel AddIn, execution of code depends on "Enable macros" option and macros level.
So, the code will never execute, if macro level is set to "high" or user choose "Disable macro" button.

VB

Option Explicit

Sub TestExpDate()

Dim retVal As Variant
retVal = GetExpiredDate()
'0 => not set
If retVal = 0 Then retVal = SetExpiredDate()
'date
If retVal > Date Then
    MsgBox DateDiff("d", Date, retVal) & " days left!", vbInformation, "Information..."
Else
    MsgBox "The end!", vbInformation, "Information..."
End If

End Sub

'set value to custom document property
'it's visible in Excel File->Properties menu or file properties (Explorer window)
Function SetExpiredDate() As Variant
Dim retVal As Variant, dp As DocumentProperty, dDate As Date

On Error GoTo Err_SetExpiredDate

'default value: 0 => can't set
retVal = 0
dDate = DateAdd("d", 30, Date)
DeleteExpDate
Set dp = ThisWorkbook.CustomDocumentProperties.Add(Name:="ExpDate", LinkToContent:=False, Type:=msoPropertyTypeDate, Value:=dDate, LinkSource:=False)
retVal = dp.Value

Exit_SetExpiredDate:
    On Error Resume Next
    Set dp = Nothing
    SetExpiredDate = retVal
    Exit Function
    
Err_SetExpiredDate:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_SetExpiredDate
    
End Function

'get value from custom document property
Function GetExpiredDate() As Variant
Dim retVal As Variant, dp As DocumentProperty

On Error GoTo Err_GetExpiredDate

'default value: 0 => not set
retVal = 0

'if exists "ExpDate", get value from custom document property
'if not exists, goto error handler to catch error
Set dp = ThisWorkbook.CustomDocumentProperties("ExpDate")
retVal = dp.Value

Exit_GetExpiredDate:
    On Error Resume Next
    Set dp = Nothing
    GetExpiredDate = retVal
    Exit Function
    
Err_GetExpiredDate:
    Select Case Err.Number
        Case 9, 5
            retVal = 0
        Case Else
            MsgBox Err.Description, vbExclamation, Err.Number
    End Select
    Resume Exit_GetExpiredDate
    
End Function

'deletes custom document property
Sub DeleteExpDate()
On Error Resume Next
ThisWorkbook.CustomDocumentProperties("ExpDate").Delete
End Sub

You can use some trick:
1) hide your "working" sheet,
2) add empty sheet and place information: "To use this file, you must enable macros.",
3) add code to make your sheet visible everytime when user open file until date is < exp. date.