VBA time trial

Gregm66

Board Regular
Joined
Jan 23, 2016
Messages
170
Hi everyone,

i have found some vba on the net that creates a time trial for workbook, it is also ment to create a logfile. But it is not creating the log file for some reason,
if any one can have a look over the code and possible help correct this problem i would be appreciative.

and if possible once the time period has expired show a form with a label showing a given number specified by me, and have a text box that allows the user to insert another number (Serial Number) given by be to overide the trial period and allow access to the workbook..

not sure if this is easy enough or can be done.

Thanks all in advance..

Code:
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# = 1 / 144   '< 10 mins trial


      'set your own obscure path and file-name
      Const ObscurePath$ = "C:\"
      Const ObscureFile$ = "TestFileLog.Log"
      '*****************************************


      If Dir(ObscurePath & ObscureFile) = Empty Then
            StartTime = Format(Now, "#0.#########0")
            Open ObscurePath & ObscureFile For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
            Print [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , StartTime
      Else
            Open ObscurePath & ObscureFile For Input As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
            Input [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , StartTime
            CurrentTime = Format(Now, "#0.#########0")
            If CurrentTime < StartTime + TrialPeriod Then
                  Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
                  Exit Sub
            Else
                  If [A1] <> "Expired" Then
                        MsgBox "Sorry, your trial period has expired - your data" & vbLf & _
                        "will now be extracted and saved for you..." & vbLf & _
                        "" & vbLf & _
                        "This workbook will then be made unusable."
                        Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
                        SaveShtsAsBook
                        [A1] = "Expired"
                        ActiveWorkbook.Save
                        Application.Quit
                  ElseIf [A1] = "Expired" Then
                        Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
                        Application.Quit
                  End If
            End If
      End If
      Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
End Sub


Second code that is ment to run

Code:
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
            For N = 1 To Sheets.Count
                  Sheets(N).Activate
                  SheetName = ActiveSheet.Name
                  Cells.Copy
                  Workbooks.Add (xlWBATWorksheet)
                  With ActiveWorkbook
                        With .ActiveSheet
                              .Paste
                              .Name = SheetName
                              [A1].Select
                        End With
                        'save book in this folder
                        .SaveAs Filename:=MyFilePath _
                                          & "\" & SheetName & ".xls"
                        .Close SaveChanges:=True
                  End With
                  .CutCopyMode = False
            Next
      End With
            Open MyFilePath & "\READ ME.log" For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
            Print [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , "Thank you for trying out this product."
            Print [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , "If it meets your requirements, visit"
            Print [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , "http://www.xxxxx/xxxx to purchase"
            Print [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , "the full (unrestricted) version..."
            Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
End Sub
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

Gregm66

Board Regular
Joined
Jan 23, 2016
Messages
170
Thankyou to everyone that has looked at my question.

I managed to solve this one with some code changes... Using macros and a userform..

Thankuou all
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,013
.
Please post the solution code for others to learn and benefit.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,079
Messages
5,639,941
Members
417,119
Latest member
adityaj252

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top