AW: Schreibschutz + dynamischer Dateiname
29.05.2017 16:48:04
fcs
Hallo Kisska,
hier noch ein Versuch. Hier wird die Option "Schreibgeschütz öffnen empfohlen" im Speichern-unter-Dialog --> "Tools" --> "Allgemeine Optionne..." genutzt.
Hier kann der Anwender beim öffnen entscheiden, wie die Datei geöffnet werden soll.
Beim Versuch zu Speichern wird dann jedoch immer der Dialog entsprechend angezeigt mit höhere r Versionsnummer als Vorgabe.
Gruß
Franz
'Makro unter DieseArbeitsmappe / Thisworkbook - Erstellt unter Excel 2010
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sPath As String, sFilename As String, sVersion As String
On Error GoTo Fehler
' If Me.ReadOnly = True Then 'Zeile aktivieren wenn Version nur erhöht werden soll wenn _
schreibgeschützt geöffnet wurde
If Me.Saved = True Then
If MsgBox("Die schreibgeschützte Datei wurde nicht geändert" & vbLf & vbLf _
& "Trotzdem neue Version speichern?", _
vbQuestion + vbYesNo, _
"Neue Version speichern") = vbNo Then
Cancel = True
Exit Sub
End If
End If
Cancel = True
sPath = Me.Path & Application.PathSeparator
sFilename = Me.Name
sVersion = Mid(sFilename, InStrRev(sFilename, "V") + 1)
sVersion = Left(sVersion, InStrRev(sFilename, ".") - 1)
sVersion = Format(Val(sVersion) + 1, "0")
sFilename = Left(sFilename, InStrRev(sFilename, "V")) & sVersion ' & ".xlsm"
Application.EnableEvents = False
'Neue Version direkt speichern
' Me.SaveAs Filename:=sPath & sFilename, FileFormat:=52, addtomru:=True, _
ReadOnlyRecommended:=True
'mit Anzeige Dialog "Speichern unter" mit Fileformat =52 (mit Makros) und ReadOnlyRecommended = _
True
Application.Dialogs(xlDialogSaveAs).Show sFilename, 52, , , , True
Application.EnableEvents = True
' End If 'Zeile aktivieren wenn Version nur erhöht werden soll wenn _
schreibgeschützt geöffnet wurde
Fehler:
With Err
Select Case .Number
Case 0
Case 1004
Cancel = True
MsgBox "Es wurde eine ältere Version der Datei geöffnet" & vbLf & vbLf _
& "Speichern wird abgebrochen", _
vbOKOnly + vbCritical, "neue Version speichern"
Application.EnableEvents = True
Case Else
Cancel = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "Speichern wird abgebrochen", _
vbOKOnly + vbCritical, "neue Version speichern"
Application.EnableEvents = True
End Select
End With
End Sub