Debug Combining Macro for Trial Period, Enabling, Copying & Hiding

L

Larry Anderson

New Member
Joined
Jul 13, 2005
Messages
24
I am new to macros in Excel and I am trying to combine 4 of the macros posted in MrExcel. Somehow I have managed to really mess up the combined macro and keep receiving a Compile Error: Syntax Error message and am completely lost when trying to run the macro. I am hoping that someone can help with a solution to my first macro. I am attaching the macro below. I would be most appreciative for any help. The macro is combined to force the user to: 1) enable macros, if disable is selected a message appears telling them they must enable macros 2) macro contains a trial period of 285 days and then shuts down with a notice to contact me 3) macro contains code to disable the hide and unhide feature under Format Sheet Hide(Unhide) and needs to enable the hide and unhide upon exiting the workbook 4) macro contains code to disable the cut, copy, paste, pastespecial, this includes the shortcut keys and then enable them upon exiting the workbook. This spreadsheet is for a High School that I want them to use but retain control at the end of the school year. I want to prevent the school from distributing without my permission or copying the workbook. (Where This Section... appears is Not in Macro).....

-----------------THIS SECTION IS THE TRIAL PERIOD--------------------------
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# = 285 '< 30 days 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 #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 -
****************MsgBox "Please contact: Xxxxxxxx X. Xxxxxxxx
****************MsgBox "about renewing trial period - your data" & vbLf & _
****************"will now be extracted and saved for you..." & vbLf & _
****************"" & vbLf & _
****************"This workbook will then be made unusable."
****************Close #1
****************SaveShtsAsBook
****************[A1] = "Expired"
****************ActiveWorkbook.Save
****************Application.Quit
************ElseIf [A1] = "Expired" Then
****************Close #1
****************Application.Quit
************End If
********End If
****End If
****Close #1
End Sub

Private 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
******************** '//N.B. to remove all the cell formulas,
******************** '//uncomment the 4 lines of code below...
******************** 'With Cells
******************** '.Copy
******************** '.PasteSpecial Paste:=xlPasteValues
******************** 'End With
********************.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 #1
****Print #1, "Thank you for using this product."
****Print #1, "Please contact: Xxxxxxxx X. Xxxxxxxx"
****Print #1, "at: XXXXxxxxx@xxx.com"
****Print #1, "or call at: (999) 999-9999..."
****Close #1
End Sub

-----------------THIS SECTION IS THE HIDE/UNHIDE SECTION----------------------

Private Sub Workbook_Open()
Private Sub SheetsUnHideHide_Disable()
****With Application
********.CommandBars.FindControl(ID:=890).Enabled = False '&Hide
********.CommandBars.FindControl(ID:=891).Enabled = False '&Unhide...
****End With
End Sub

Private Sub SheetsUnHideHide_Enable()
****With Application
********.CommandBars.FindControl(ID:=890).Enabled = True '&Hide
********.CommandBars.FindControl(ID:=891).Enabled = True '&Unhide...
****End With
End Sub


---------THIS SECTION IS THE ENABLE MACROS WITH MESSAGE SECTION--------------

Option Explicit

Private Sub Workbook_Open()

With Application
'disable the ESC key
.EnableCancelKey = xlDisabled
.ScreenUpdating = False

Call UnhideSheets

.ScreenUpdating = True
're-enable ESC key
.EnableCancelKey = xlInterrupt
End With

End Sub
'
Private Sub UnhideSheets()
'
Dim Sheet As Object
'
For Each Sheet In Sheets
If Not Sheet.Name = "Prompt" Then
Sheet.Visible = xlSheetVisible
End If
Next
'
Sheets("Prompt").Visible = xlSheetVeryHidden
'
Application.Goto Worksheets(1).[A1], True '< Optional
'
Set Sheet = Nothing
ActiveWorkbook.Saved = True

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Application
.EnableCancelKey = xlDisabled
.ScreenUpdating = False

Call HideSheets

.ScreenUpdating = True
.EnableCancelKey = xlInterrupt
End With
End Sub

Private Sub HideSheets()
'
Dim Sheet As Object '< Includes worksheets and chartsheets
'
With Sheets("Prompt")
'
'the hiding of the sheets constitutes a change that generates
'an automatic "Save?" prompt, so IF the book has already
'been saved prior to this point, the next line and the lines
'relating to .[A100] below bypass the "Save?" dialog...
If ThisWorkbook.Saved = True Then .[A100] = "Saved"
'
.Visible = xlSheetVisible
'
For Each Sheet In Sheets
If Not Sheet.Name = "Prompt" Then
Sheet.Visible = xlSheetVeryHidden
End If
Next
'
If .[A100] = "Saved" Then
.[A100].ClearContents
ThisWorkbook.Save
End If
'
Set Sheet = Nothing
End With
'
End Sub


---------------THIS SECTION IS THE COPY/CUT AND PASTE SECTION---------------

Private Sub DisableCopyCutAndPaste()
EnableControl 21, False ' cut
EnableControl 19, False ' copy
EnableControl 22, False ' paste
EnableControl 755, False ' pastespecial
Application.OnKey "^c", "Dummy"
Application.OnKey "^v", "Dummy"
Application.OnKey "+{DEL}", "Dummy"
Application.OnKey "+{INSERT}", "Dummy"
Application.CellDragAndDrop = False
Application.OnDoubleClick = "Dummy"
CommandBars("ToolBar List").Enabled = False
End Sub

Private Sub EnableCopyCutAndPaste()
EnableControl 21, True ' cut
EnableControl 19, True ' copy
EnableControl 22, True ' paste
EnableControl 755, True ' pastespecial
Application.OnKey "^c"
Application.OnKey "^v"
Application.OnKey "+{DEL}"
Application.OnKey "+{INSERT}"
Application.CellDragAndDrop = True
Application.OnDoubleClick = ""
CommandBars("ToolBar List").Enabled = True
End Sub

Private Sub EnableControl(Id As Integer, Enabled As Boolean)
Dim CB As CommandBar
Dim C As CommandBarControl

On Error Resume Next
For Each CB In Application.CommandBars
Set C = CB.FindControl(Id:=Id, recursive:=True)
If Not C Is Nothing Then C.Enabled = Enabled
Next

End Sub

Private Sub Dummy()
'// NoGo
MsgBox "Sorry command not Available!"
MsgBox “Theft of Copyrighted Material is Against the Law!!!”
MsgBox “Now, are you not ashamed of yourself?”
End Sub
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
Not an answer. Just replying with your code in a more readable format. Good luck! :)

Code: 
'-----------------THIS SECTION IS THE TRIAL PERIOD--------------------------
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# = 285 '< 30 days 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 #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 -"
                MsgBox "Please contact: Xxxxxxxx X. Xxxxxxxx"
                MsgBox "about renewing trial period - your data" & vbLf & _
                "will now be extracted and saved for you..." & vbLf & _
                "" & vbLf & _
                "This workbook will then be made unusable."
                Close #1
                SaveShtsAsBook
                [A1] = "Expired"
                ActiveWorkbook.Save
                Application.Quit
            ElseIf [A1] = "Expired" Then
                Close #1
                Application.Quit
            End If
        End If
    End If
    Close #1
End Sub

Private 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
                     '//N.B. to remove all the cell formulas,
                     '//uncomment the 4 lines of code below...
                     'With Cells
                     '.Copy
                     '.PasteSpecial Paste:=xlPasteValues
                     'End With
                    .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 #1
    Print #1, "Thank you for using this product."
    Print #1, "Please contact: Xxxxxxxx X. Xxxxxxxx"
    Print #1, "at: XXXXxxxxx@xxx.com"
    Print #1, "or call at: (999) 999-9999..."
    Close #1
    
End Sub

Code: 
-----------------THIS SECTION IS THE HIDE/UNHIDE SECTION----------------------

'Private Sub Workbook_Open()
Private Sub SheetsUnHideHide_Disable()
    With Application
        .CommandBars.FindControl(Id:=890).Enabled = False '&Hide
        .CommandBars.FindControl(Id:=891).Enabled = False '&Unhide...
    End With
End Sub

Private Sub SheetsUnHideHide_Enable()
    With Application
        .CommandBars.FindControl(Id:=890).Enabled = True '&Hide
        .CommandBars.FindControl(Id:=891).Enabled = True '&Unhide...
    End With
End Sub

Code: 
'---------THIS SECTION IS THE ENABLE MACROS WITH MESSAGE SECTION--------------

Option Explicit

Private Sub Workbook_Open()

    With Application
        'disable the ESC key
        .EnableCancelKey = xlDisabled
        .ScreenUpdating = False
        
        Call UnhideSheets
        
        .ScreenUpdating = True
        're-enable ESC key
        .EnableCancelKey = xlInterrupt
    End With

End Sub
'
Private Sub UnhideSheets()
    '
    Dim Sheet As Object
    '
    For Each Sheet In Sheets
        If Not Sheet.Name = "Prompt" Then
            Sheet.Visible = xlSheetVisible
        End If
    Next
    '
    Sheets("Prompt").Visible = xlSheetVeryHidden
    '
    Application.Goto Worksheets(1).[A1], True '< Optional
    '
    Set Sheet = Nothing
    ActiveWorkbook.Saved = True

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    With Application
        .EnableCancelKey = xlDisabled
        .ScreenUpdating = False
        
        Call HideSheets
        
        .ScreenUpdating = True
        .EnableCancelKey = xlInterrupt
    End With
End Sub

Private Sub HideSheets()
    '
    Dim Sheet As Object '< Includes worksheets and chartsheets
    '
    With Sheets("Prompt")
        '
        'the hiding of the sheets constitutes a change that generates
        'an automatic "Save?" prompt, so IF the book has already
        'been saved prior to this point, the next line and the lines
        'relating to .[A100] below bypass the "Save?" dialog...
        If ThisWorkbook.Saved = True Then .[A100] = "Saved"
        '
        .Visible = xlSheetVisible
        '
        For Each Sheet In Sheets
            If Not Sheet.Name = "Prompt" Then
                Sheet.Visible = xlSheetVeryHidden
            End If
        Next
        '
        If .[A100] = "Saved" Then
            .[A100].ClearContents
            ThisWorkbook.Save
        End If
        '
        Set Sheet = Nothing
    End With
    '
End Sub

Code: 
'---------------THIS SECTION IS THE COPY/CUT AND PASTE SECTION---------------

    Private Sub DisableCopyCutAndPaste()
    EnableControl 21, False ' cut
    EnableControl 19, False ' copy
    EnableControl 22, False ' paste
    EnableControl 755, False ' pastespecial
    Application.OnKey "^c", "Dummy"
    Application.OnKey "^v", "Dummy"
    Application.OnKey "+{DEL}", "Dummy"
    Application.OnKey "+{INSERT}", "Dummy"
    Application.CellDragAndDrop = False
    Application.OnDoubleClick = "Dummy"
    CommandBars("ToolBar List").Enabled = False
End Sub

Private Sub EnableCopyCutAndPaste()
    EnableControl 21, True ' cut
    EnableControl 19, True ' copy
    EnableControl 22, True ' paste
    EnableControl 755, True ' pastespecial
    Application.OnKey "^c"
    Application.OnKey "^v"
    Application.OnKey "+{DEL}"
    Application.OnKey "+{INSERT}"
    Application.CellDragAndDrop = True
    Application.OnDoubleClick = ""
    CommandBars("ToolBar List").Enabled = True
End Sub

Private Sub EnableControl(Id As Integer, Enabled As Boolean)
    Dim CB As CommandBar
    Dim C As CommandBarControl
    
    On Error Resume Next
    For Each CB In Application.CommandBars
        Set C = CB.FindControl(Id:=Id, recursive:=True)
        If Not C Is Nothing Then C.Enabled = Enabled
    Next

End Sub

Private Sub Dummy()
    '// NoGo
    MsgBox "Sorry command not Available!"
    MsgBox "Theft of Copyrighted Material is Against the Law!!!"
    MsgBox "Now, are you not ashamed of yourself?"
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Re-enabling Copy, Cut, Paste, Drag/Drop Cells in Excel
Replies
5
Views
757
Peter_SSs
Peter_SSs
J
  • Question
VBA Macro for hiding and unhiding rows is rearranging cells
2
Replies
14
Views
957
dmt32
D
M
  • Question
Hide Rows based on cell with drop down values
Replies
1
Views
447
kevin9999
K
N
  • Question
ActiveX Checkbox fails after sheetname change
Replies
4
Views
154
bobsan42
bobsan42
C
  • Solved
VBA - Hide Columns and Copy to a New Workbook
Replies
2
Views
245
CLAZGRE
C

Forum statistics

Threads
1,215,212
Messages
6,123,655
Members
449,113
Latest member
Hochanz

Share this page

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
Back
Top