Looking for vb code to prevent saving excel file to any other format other than 2003.

[Frank Rizzo]

Well, what a time I had in the past two days. I have been pulling my hair out but that's not what has me most upset. What upsets me most is that I joined a site not unlike this one but under a different name.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
I was/am looking for vb coding and didn't realize that there are vb pros on this site as well. It was only when I read a code on the net that this site popped back up.<o></o>
<o></o>
So I am VERY happy this site does everything I need and have needed in the past.<o></o>
<o></o>
Now on to why I am so upset;<o></o>
<o></o>
I posted a question of how to do something in vb code from the supposed 'cough experts cough' and after 2 days without so much as a single hint of an attempt to answer and oh did I mention that I spent two days looking through like 5 zillion posts and provided all the info that was needed to answer my question? Well yes I did!<o></o>
<o></o>
As it is, I was able to half hazzardly learn VB and put the code together myself and it seems fine although, the last thing I need is the following;<o></o>
<o></o>
I wish to prevent anyone from saving or saving as or any other type of saving my file including ‘X’-ing out and being asked to save and oh yeah, preventing anyone from simply copying the file by right clicking on it and left on copy or save as to any other format other than 2003.<o></o>
<o></o>
Is such a thing possible?<o></o>
<o></o>
Thank you sooo much in advance for anything.. I mean anything anyone has to offer on this subject.
<o></o>
-Frank
<o></o>
Ps; What I have so far is the following. If you see errors or recomendations, PLEASE advise.

WORKBOOK

Option Explicit
 
Const WelcomePage = "Macros"
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
     'Turn off events to prevent unwanted loops
    Application.EnableEvents = False
 
     'Evaluate if workbook is saved and emulate default propmts
    With ThisWorkbook
        If Not .Saved Then
            Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _
                vbYesNoCancel + vbExclamation)
            Case Is = vbYes
                 'Call customized save routine
                Call CustomSave
            Case Is = vbNo
                 'Do not save
            Case Is = vbCancel
                 'Set up procedure to cancel close
                Cancel = True
            End Select
        End If
 
         'If Cancel was clicked, turn events back on and cancel close,
         'otherwise close the workbook without saving further changes
        If Not Cancel = True Then
            .Saved = True
            Application.EnableEvents = True
            .Close savechanges:=False
        Else
            Application.EnableEvents = True
        End If
    End With
    Call ToggleCutCopyAndPaste(True)
End Sub
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
     'Turn off events to prevent unwanted loops
    Application.EnableEvents = False
 
     'Call customized save routine and set workbook's saved property to true
     '(To cancel regular saving)
    Call CustomSave(SaveAsUI)
    Cancel = True
 
     'Turn events back on an set saved property to true
    Application.EnableEvents = True
    ThisWorkbook.Saved = True
End Sub
 
Private Sub Workbook_Open()
     'Unhide all worksheets
    Application.ScreenUpdating = False
    Call ShowAllSheets
    Call ToggleCutCopyAndPaste(False)
    Application.ScreenUpdating = True
End Sub
 
Private Sub CustomSave(Optional SaveAs As Boolean)
    Dim ws As Worksheet, aWs As Worksheet, newFname As String
     'Turn off screen flashing
    Application.ScreenUpdating = False
 
     'Record active worksheet
    Set aWs = ActiveSheet
 
     'Hide all sheets
    Call HideAllSheets
 
     'Save workbook directly or prompt for saveas filename
    If SaveAs = True Then
        newFname = Application.GetSaveAsFilename( _
        fileFilter:="Excel Files (*.xls), *.xls")
        If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
    Else
        ThisWorkbook.Save
    End If
 
     'Restore file to where user was
    Call ShowAllSheets
    aWs.Activate
 
     'Restore screen updates
    Application.ScreenUpdating = True
End Sub
 
Private Sub HideAllSheets()
    Dim ws As Worksheet
    ActiveWorkbook.Unprotect Password:="123"
    ActiveSheet.Unprotect Password:="123"
    'Hide all worksheets except the macro welcome page
    Worksheets(WelcomePage).Visible = xlSheetVisible
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
    Next ws
    ActiveSheet.Protect Password:="123"
    ActiveWorkbook.Protect Password:="123"
    Worksheets(WelcomePage).Activate
End Sub
 
Private Sub ShowAllSheets()
    Dim ws As Worksheet
    ActiveWorkbook.Unprotect Password:="123"
    ActiveSheet.Unprotect Password:="123"
    'Show all worksheets except the macro welcome page
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
        If ws.Name = "Sheet2" Then ws.Visible = xlSheetVeryHidden
    Next ws
    Worksheets(WelcomePage).Visible = xlSheetVeryHidden
    ActiveSheet.Protect Password:="123"
    ActiveWorkbook.Protect Password:="123"
End Sub
Private Sub Workbook_Deactivate()
    Call ToggleCutCopyAndPaste(True)
End Sub
Private Sub Workbook_Activate()
    Call ToggleCutCopyAndPaste(False)
End Sub

STANDARD MODULE

Option Explicit
 
Sub ToggleCutCopyAndPaste(Allow As Boolean)
     'Activate/deactivate cut, copy, paste and pastespecial menu items
    Call EnableMenuItem(21, Allow) ' cut
    Call EnableMenuItem(19, Allow) ' copy
    Call EnableMenuItem(22, Allow) ' paste
    Call EnableMenuItem(755, Allow) ' pastespecial
 
     'Activate/deactivate drag and drop ability
    Application.CellDragAndDrop = Allow
 
     'Activate/deactivate cut, copy, paste and pastespecial shortcut keys
    With Application
        Select Case Allow
        Case Is = False
            .OnKey "^c", "CutCopyPasteDisabled"
            .OnKey "^v", "CutCopyPasteDisabled"
            .OnKey "^x", "CutCopyPasteDisabled"
            .OnKey "+{DEL}", "CutCopyPasteDisabled"
            .OnKey "^{INSERT}", "CutCopyPasteDisabled"
        Case Is = True
            .OnKey "^c"
            .OnKey "^v"
            .OnKey "^x"
            .OnKey "+{DEL}"
            .OnKey "^{INSERT}"
        End Select
    End With
End Sub
 
Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)
     'Activate/Deactivate specific menu item
    Dim cBar As CommandBar
    Dim cBarCtrl As CommandBarControl
    For Each cBar In Application.CommandBars
        If cBar.Name <> "Clipboard" Then
            Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True)
            If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled
        End If
    Next
End Sub
 
Sub CutCopyPasteDisabled()
     'Inform user that the functions have been disabled
    MsgBox "Sorry!  Cutting, copying and pasting have been disabled in this workbook!"
End Sub

 

[Frank Rizzo]

Hummm, I am really starting to think that I am asking the impossible here. Perhaps it's the way I am asking? Maybe I need to say pretty please with a cherry on top?

Ok then; how about this;

What is the chance the code below can be altered to restrict the user to saving the workbook only as a 2003 .xls format when either closing the workbook or going to the command bar and selecting save as?.

I have been sitting in front of this computer for the last 18 hours trying to sort this.

Please help if you are able.

Thank you

-Frank

Private Sub CustomSave(Optional SaveAs As Boolean)
    Dim ws As Worksheet, aWs As Worksheet, newFname As String
     'Turn off screen flashing
    Application.ScreenUpdating = False
     'Record active worksheet
    Set aWs = ActiveSheet
     'Hide all sheets
    Call HideAllSheets
     'Save workbook directly or prompt for saveas filename
    If SaveAs = True Then
        newFname = Application.GetSaveAsFilename( _
        fileFilter:="Excel Files (*.xls), *.xls")
        If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
    Else
        ThisWorkbook.Save
    End If
     'Restore file to where user was
    Call ShowAllSheets
    aWs.Activate
     'Restore screen updates
    Application.ScreenUpdating = True
End Sub