AW: Datei speichert trotz Schreibschutz
10.09.2011 09:05:42
fcs
Hallo reiner,
absolut erzwingen ist nur bedingt möglich.
Solange beim Öffnen der Datei die Makros aktiviert werden, kann man steuern, dass mit "Speichern unter" oder bei schreibgeschützt geöffneter Datei die neu Datei in einem bestimmten Verzeichnis gespeichert werden muss.
Der Code ist so aufgebaut, dass die "neue" Datei im gleichen Verzeichns gespeichert werden muss wie die geöffnete Datei, aber nicht unter dem gleichen Namen.
Erfahrene Anwender können das aber einfach umgehen, indem sie die Ereignismakros deaktivieren.
Gruß
Franz
'Code unter DieseArbeitsmappe
'Erstellt unter Excel 2007
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sPath As String, sDateiName As String, vAuswahl
Dim sDir As String
On Error GoTo Fehler
sDir = Me.Path 'Verzeichnis dieser Datei merken bzw. das Verzeichnis unter dem _
gespeichert werden soll
If SaveAsUI = True Or Me.ReadOnly = True Then
'Speichern erfolgt über den Dialog-Speichern unter
Cancel = True 'Anzeige des Standard-Dialogs abbrechen
Application.EnableEvents = False
'Vorgabe für neuen Dateinamen
sDateiName = Left(Me.Name, InStrRev(Me.Name, ".") - 1) & " Kopie"
DialogSaveAs:
With Application.FileDialog(msoFileDialogSaveAs)
.InitialFileName = sDir & Application.PathSeparator & sDateiName
.Title = "### Datei speichern unter ###"
.AllowMultiSelect = False
If .Show = False Then
'Dialog abgebrochen
Else
vAuswahl = .SelectedItems(1)
sPath = Left(vAuswahl, InStrRev(vAuswahl, Application.PathSeparator) - 1)
If LCase(sPath) LCase(sDir) Then 'Prüfung Verzeichnis
MsgBox "Diese Datei darf nur im Verzeichnis """ & sDir & """ gespeichert werden!", _
vbInformation + vbCritical, "Datei - Speichern unter"
GoTo DialogSaveAs
ElseIf LCase(vAuswahl) = LCase(Me.FullName) Then 'Prüfung Dateiname
MsgBox "Die Datei """ & Me.Name _
& """ darf nicht unter dem gleichen Namen gespeichert werden!", _
vbInformation + vbCritical, "Datei - Speichern unter"
GoTo DialogSaveAs
Else
Application.DisplayAlerts = False
Me.SaveAs Filename:=vAuswahl, addtomru:=True
Application.DisplayAlerts = True
End If
End If
End With
Application.EnableEvents = True
End If
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, vbInformation, "Fehler in "" _
Before Save"
Application.EnableEvents = True
End Select
End With
End Sub