GURLBIKE.INFO

Video nice off vba screen turn updating excel Girl and

Force Users to Enable Macros in a Workbook

The following code forces a user to enable macros in a workbook. If a user opens the workbook and disables macros, only a warning sheet is displayed and all other sheets are hidden. They cannot be unhidden using Excel's menus. The warning sheet asks the user to re-open the workbook and enable macros. Once macros are enabled, the warning sheet is hidden and all other sheets are displayed.

After you've added the code to your workbook, you'll need to create a new worksheet and you'll need to name the worksheet "Warning". Then you'll need to add a message on the worksheet asking the user to re-open the workbook and enable macros. Lastly, you'll need to save your workbook.

Note that this code uses a custom save routine, which avoids the dialog box for the Compatibility Checker. Therefore, if you're saving an Excel 2007-2010 workbook as an Excel 97-2003 workbook, make sure that there are no compatibility issues or that only minor ones exist.

'Force the explicit declaration of variables
OptionExplicit

'Assign the name of the warning sheet to a constant
Const Warning AsString = "Warning"

PrivateSub Workbook_Open()

    'Turn off screen updating
    Application.ScreenUpdating = False
    
    'Call the ShowAllSheets routine
    Call ShowAllSheets
    
    'Set the workbook's Saved property to True
    Me.Saved = True
    
    'Turn on screen updating
    Application.ScreenUpdating = True
    
EndSub

PrivateSub Workbook_BeforeClose(Cancel AsBoolean)

    'Declare the variable
    Dim Ans AsInteger
    
    'If the workbook's Saved property is False, emulate Excel's default save prompt
    If Me.Saved = FalseThen
        Do
            Ans = MsgBox("Do you want to save the changes you made to '" & _
                Me.Name & "'?", vbQuestion + vbYesNoCancel)
            SelectCase Ans
                Case vbYes
                    Call CustomSave
                Case vbNo
                    Me.Saved = True
                Case vbCancel
                    Cancel = True
                    ExitSub
            EndSelect
        LoopUntil Me.Saved
    EndIf
    
EndSub

PrivateSub Workbook_BeforeSave(ByVal SaveAsUI AsBoolean, Cancel As Boolean)

    'Cancel regular saving
    Cancel = True
    
    'Call the CustomSave routine
    Call CustomSave(SaveAsUI)
    
EndSub

PrivateSub CustomSave(Optional SaveAsAsBoolean)

    'Declare the variables
    Dim ActiveSht AsObject
    Dim FileFormat AsVariant
    Dim FileName AsString
    Dim FileFilter AsString
    Dim FilterIndex AsInteger
    Dim Msg AsString
    Dim Ans AsInteger
    Dim OrigSaved As Boolean
    Dim WorkbookSaved As Boolean
    
    'Turn off screen updating
    Application.ScreenUpdating = False
    
    'Turn off events so that the BeforeSave event doesn't occur
    Application.EnableEvents = False
    
    'Assign the status of the workbook's Saved property to a variable
    OrigSaved = Me.Saved
    
    'Assign the active sheet to an object variable
    Set ActiveSht = ActiveSheet
    
    'Call the HideAllSheets routine
    Call HideAllSheets
    
    'Save workbook or prompt for SaveAs filename
    If SaveAs Or Len(Me.Path) = 0 Then
        If Val(Application.Version) < 12 Then
            FileFilter = "Microsoft Office Excel Workbook (*.xls), *.xls"
            FilterIndex = 1
        Else
            FileFilter = "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm, " & _
                "Excel 97-2003 Workbook (*.xls), *.xls"
            If Right(Me.Name, 4) = ".xls" Then
                FilterIndex = 2
            Else
                FilterIndex = 1
            EndIf
        EndIf
        Do
            FileName = Application.GetSaveAsFilename( _
                InitialFileName:=Me.Name, _
                FileFilter:=FileFilter, _
                FilterIndex:=FilterIndex, _
                Title:="SaveAs")
            If FileName = "False" ThenExitDo
            If IsLegalFilename(FileName) = FalseThen
                Msg = "The file name is invalid.  Try one of the "
                Msg = Msg & "following:" & vbCrLf & vbCrLf
                Msg = Msg & Chr(149) & " Make sure that the file name "
                Msg = Msg & "does not contain any" & vbCrLf
                Msg = Msg & "   of the following characters:  "
                Msg = Msg & "< > ? [ ] : | or *" & vbCrLf
                Msg = Msg & Chr(149) & " Make sure that the file/path "
                Msg = Msg & "name does not exceed" & vbCrLf
                Msg = Msg & "   more than 218 characters."
                MsgBox Msg, vbExclamation, "Invalid File Name"
            Else
                If Val(Application.Version) < 12 Then
                    FileFormat = -4143
                Else
                    If Right(FileName, 4) = ".xls" Then
                        FileFormat = 56
                    Else
                        FileFormat = 52
                    EndIf
                EndIf
                If Len(Dir(FileName)) = 0 Then
                    Application.DisplayAlerts = False
                    Me.SaveAs FileName, FileFormat
                    Application.DisplayAlerts = True
                    WorkbookSaved = True
                Else
                    Ans = MsgBox("'" & FileName & "' already exists.  " & _
                        "Do you want to replace it?", vbQuestion + vbYesNo, _
                        "Confirm Save As")
                    If Ans = vbYes Then
                        Application.DisplayAlerts = False
                        Me.SaveAs FileName, FileFormat
                        Application.DisplayAlerts = True
                        WorkbookSaved = True
                    EndIf
                EndIf
            EndIf
        LoopUntil Me.Saved
    Else
        Application.DisplayAlerts = False
        Me.Save
        Application.DisplayAlerts = True
        WorkbookSaved = True
    EndIf
    
    'Call the ShowAllSheets routine
    Call ShowAllSheets
    
    'Activate the prior active sheet
    ActiveSht.Activate
    
    'Set the workbook's Saved property
    If WorkbookSaved Then
        Me.Saved = True
    Else
        Me.Saved = OrigSaved
    EndIf
    
    'Turn on screen updating
    Application.ScreenUpdating = True
    
    'Turn on events
    Application.EnableEvents = True
    
EndSub

PrivateSub HideAllSheets()

    'Declare the variable
    Dim Sh AsObject
    
    'Display the warning sheet
    Sheets(Warning).Visible = xlSheetVisible
    
    'Hide every sheet, except the warning sheet
    ForEach Sh In Sheets
        If Sh.Name <> Warning Then
            Sh.Visible = xlSheetVeryHidden
        EndIf
    Next Sh
    
EndSub

PrivateSub ShowAllSheets()

    'Declare the variable
    Dim Sh AsObject
    
    'Display every sheet, except the warning sheet
    ForEach Sh In Sheets
        If Sh.Name <> Warning Then
            Sh.Visible = xlSheetVisible
        EndIf
    Next Sh
    
    'Hide the warning sheet
    Sheets(Warning).Visible = xlSheetVeryHidden
    
EndSub

PrivateFunction IsLegalFilename(ByVal fname AsString) AsBoolean
    Dim BadChars AsVariant
    Dim i AsLong
    If Len(fname) > 218 Then
        IsLegalFilename = False
        ExitFunction
    Else
        BadChars = Array("\", "/", "<", ">", "?", "[", "]", ":", "|", "*", """")
        fname = GetFileName(fname)
        For i = LBound(BadChars) ToUBound(BadChars)
            If InStr(1, fname, BadChars(i)) > 0 Then
                IsLegalFilename = False
                ExitFunction
            EndIf
        Next i
    EndIf
    IsLegalFilename = True
EndFunction

PrivateFunction GetFileName(ByVal FullName As String) As String
    Dim i As Long
    For i = Len(FullName) To 1 Step -1
        If Mid(FullName, i, 1) = Application.PathSeparator ThenExitFor
    Next i
    GetFileName = Mid(FullName, i + 1)
EndFunction

Where to Put the Code

  1. Open the workbook in which to store the code.
  2. Open the Visual Basic Editor (Alt+F11).
  3. In the Project Explorer window (Ctrl+R), right-click ThisWorkbook, and select "View Code".
  4. Copy/paste the above code into the code module for ThisWorkbook.
  5. Return to Microsoft Excel (Alt+Q).
  6. Save the workbook.

Sample Workbook: Download

http://www.xl-central.com/force-users-to-enable-macros-in-a-workbook.html