Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1560to1564
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Schreibschutz + dynamischer Dateiname

Schreibschutz + dynamischer Dateiname
28.05.2017 21:01:19
Kisska
Hallöchen!
Ich habe eine Datei mit folgender Namenskonvention: Name_v1
v1 steht für Version 1.
Wenn ich beispielsweise bei den Eigenschaften der Datei den Schreibschutz aktiviere und dann die Datei überschreiben möchte, kommt eine Meldung und man kann die Datei als Kopie speichern.
So etwas ähnliches hätte ich gerne mittels VBA gelöst, allerdings soll gleich ein Name zum Speichern vorgeschlagen werden, bei dem die Version fortlaufend wird.
D.h., wenn ich die Datei "Name_V1" öffne und dann auf Speichern gehe, soll als Speicher-Name "Name_V2" vorgeschlagen werden.
Geht es überhaupt?
Viele Grüße
Kisska

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Schreibschutz + dynamischer Dateiname
28.05.2017 21:52:52
Sepp
Hallo Kisska,
so?
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub saveCopy()
Dim strFilename As String, strPath As String, strSaveAs As String, strExt As String
Dim lngFileFormat As Long, lngIndex As Long

On Error GoTo ErrExit

Application.EnableEvents = False

lngFileFormat = ThisWorkbook.FileFormat

strPath = ThisWorkbook.Path & "\"

strFilename = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)

strExt = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))

lngIndex = Clng(Right(strFilename, 1))

strFilename = Left(strFilename, Len(strFilename) - 1)

Do
  lngIndex = lngIndex + 1
Loop While Dir(strPath & strFilename & lngIndex & strExt, vbNormal) <> ""

strFilename = strPath & strFilename & lngIndex & strExt

With Application.FileDialog(msoFileDialogSaveAs)
  .InitialFileName = strFilename
  .Title = "Kopie speichern"
  .ButtonName = "Kopie speichern"
  .InitialView = msoFileDialogViewList
  .FilterIndex = 2
  If .Show = -1 Then strSaveAs = .SelectedItems(1)
End With

If Len(strSaveAs) Then
  ThisWorkbook.SaveAs strSaveAs, lngFileFormat
End If

ErrExit:
Application.EnableEvents = True
End Sub

Gruß Sepp

Anzeige
direkt über "Speichern" ?
28.05.2017 22:06:04
Kisska
Cool, ja! Aber geht es direkt automatisch, wenn man auf "Speichern" geht, ohne dass man VBA ausführen muss?
AW: direkt über "Speichern" ?
28.05.2017 22:21:17
Sepp
Hallo Kisska,
ohne VBA? Du meinst wohl, ohne das man ein Makro ausführen muss.
unter "DieseArbeitsmappe".
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFilename As String, strPath As String, strSaveAs As String, strExt As String
Dim lngFileFormat As Long, lngIndex As Long

On Error GoTo ErrExit

Application.EnableEvents = False

If LCase(Me.Sheets("Tabelle1").Range("A1")) <> "save" Then
  Cancel = True
  
  lngFileFormat = ThisWorkbook.FileFormat
  
  strPath = ThisWorkbook.Path & "\"
  
  strFilename = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
  
  strExt = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
  
  lngIndex = Clng(Right(strFilename, 1))
  
  strFilename = Left(strFilename, Len(strFilename) - 1)
  
  Do
    lngIndex = lngIndex + 1
  Loop While Dir(strPath & strFilename & lngIndex & strExt, vbNormal) <> ""
  
  strFilename = strPath & strFilename & lngIndex & strExt
  
  With Application.FileDialog(msoFileDialogSaveAs)
    .InitialFileName = strFilename
    .Title = "Kopie speichern"
    .ButtonName = "Kopie speichern"
    .InitialView = msoFileDialogViewList
    .FilterIndex = 2
    If .Show = -1 Then strSaveAs = .SelectedItems(1)
  End With
  
  If Len(strSaveAs) Then
    ThisWorkbook.SaveAs strSaveAs, lngFileFormat
  End If
End If
ErrExit:
Application.EnableEvents = True
End Sub

Du kannst die Mappe allerdings nicht mehr "normal" speichern.
Deshalb habe ich eine Hintertür eingebaut. Wenn du in Tabelle1 in A1 "save" schreibst, wird die Datei normal gespeichert. Die Tabelle un die Zelle kannst du natürlich an deine Gegebenheiten anpassen.
Gruß Sepp

Anzeige
AW: direkt über "Speichern" ?
28.05.2017 22:31:28
Kisska
Ja, ohne Makro!
Das Problem ist, dass ich mehrere Tabellenblätter habe, die überall befüllt sind. Extra neue Spalte hinzuzufügen wäre nicht erwünscht.
Also das "normale Abspeichern" ohne Bezug zu irgendwelchen Zellen oder Makroausführung ist nicht möglich, ja?
AW: Schreibschutz + dynamischer Dateiname
28.05.2017 22:49:22
fcs
Hallo Kisska,
ja das kann man mit einem Ereignismakro steuern, das im VBA-Editor unter "DieseArbeitsmappe" der Datei eingefügt wird.
Die Datei muss dann natürlich als Datei mit Makros gespeichert werden.
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
If Me.ReadOnly = True Then
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
'mit Anzeige Dialog "Speichern unter"
Application.Dialogs(xlDialogSaveAs).Show sFilename
Application.EnableEvents = True
End If
End Sub

Anzeige
AW: Schreibschutz + dynamischer Dateiname
28.05.2017 23:13:09
Kisska
Hi Franz,
es passiert nichts bei mir :-o Habe den Code, wie du gesagt hast, unter "DieseArbeitsmappe" eingefügt, VBA-Fenster geschlossen und dann auf "Speichern" geklickt, aber es kommt kein Fenster auf zum Abspeichern unter der neuen Version.
VG
Kisska
AW: Schreibschutz + dynamischer Dateiname
28.05.2017 23:43:54
fcs
Hallo Kisska,
damit das Makroden Speichern-Dialog anzeigt musst du die Datei nach dem Speichern schließen und dann im Dateimanager/-explorer die Eigenschaft "Schreibgeschütz" aktivieren. Dann sollte es funktionieren, denn das Makro prüft ja als erstes, ob die geöffnete Datei schreibgeschützt ist. Wenn nein, dann wird ganz normal gespeichert.
Ich hab das Makro nochmals etwas optimiert mit einer Fehlerbehandlung.
Diese ist insbesondere dann erforderlich, wenn du die Variante benutzt, die die neue Version direkt speichert. Alte schreibgeschützte Dateien sollen ja nicht überschrieben werden, wenn eine ältere Version geöffnet wird.
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
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
'mit Anzeige Dialog "Speichern unter"
Application.Dialogs(xlDialogSaveAs).Show sFilename
Application.EnableEvents = True
End If
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

Anzeige
AW: Schreibschutz + dynamischer Dateiname
29.05.2017 12:00:28
Kisska
Guten Morgen Franz,
wenn ich diesen Weg gehe, dann bleibt der Schreibschutz nur bei der ersten Version.
Die zweite Version, die durch das VBA abgelegt wurde, enthält keinen Schreibschutz mehr und der VBA-Code findet keine Anwendung mehr :/
Es sollen ja alle Versionen schreibgeschützt werden. Einmal den Schreibschutz über die Eigenschaften einzustellen, ist kein Problem, aber nicht jedes Mal aufs Neue :(
VG
Kisska
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 --&gt "Tools" --&gt "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

Anzeige
Klasse! Danke + Frage
29.05.2017 17:48:32
Kisska
Hi Franz,
erst mal einen ganz großen Lob an dich! Der Schreibschutz funktioniert super und ich bin mit der Lösung überglücklich! :-)
Erlaube mir bitte noch zwei Fragen:
1) Die Datei ohne das Fenster "mit oder ohne Schutz öffnen" kann man nicht weglassen? Oder zumindest ein Fenster mit nur einem Button "ok" für "Die Datei wird schreibgeschützt geöffnet" machen?
2) Eigentlich habe ich das nicht gebraucht, aber deine Lösung hat mich neugierig gemacht :)
Wenn ich im Fenster "ohne Schreibschutz" wähle, dann nach Bearbeitung auf Speichern gehe, kommt das Fenster "Die schreibgeschützte Datei wurde nicht geändert. Trotzdem neue Version speichern".
Kann man diesem Fall das Fenster weglassen und das Überschreiben zulassen?
Liebe Grüße
Kisska
Anzeige
AW: Klasse! Danke + Frage
30.05.2017 00:44:02
fcs
Hallo Kisska,
zu 1.)
diese Abfrage, wie bei derEinstellung "Schreibgeschützt öffnen empfohlen" die Datei geöffnet werden soll, ist in Excel integriert und kann nicht beeinflusst werden, dasie ja vor dem eigentlichen Öffnen de Datei efolgt..
zu 2.) wenn bei nicht schreibgeschützter Datei das Speichern "normal" erfolgen soll, dann müssen die If-Prüfungen wieder angepasst werden. Bei unveränderter schreibgeschützter Datei wird jetzt auch keine weitere Meldung vom Makro angeeigt - hab ich als Kommentar-Zeile dringelassen.
Ansonsten solltst du ggf. auch mal einen Blick auf die Komentare im Code werfen, umd die eine oder andere kleinere Anpassung selber machen.
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
If Me.Saved = True Then
'            MsgBox "Die schreibgeschützte Datei wurde nicht geändert", _
vbInformation + vbOKOnly, _
"Neue Version speichern"
Cancel = True
Exit Sub
Else
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
Else
'keine Aktion - nicht schreibgeschützte Datei normal speichern
End If
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

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige