|
Hallo,
ich habe es nun mit der application.GetSaveAsFilename die ich hier lernen konnte viel einfacher (fast) gelöst. Die Originaldatei soll einfach bleiben wo sie ist. Wenn ein Benutzer versucht zu überschreiben öffnet sich der SaveAs Dialog fordert auf wo anders zu speichen und gibt auch einen anderen Ordner und Namens Vorschlag.
Es klappt ganz gut, bis auf eine Kleinigkeit, und zwar kann der Benutzer im SaveAs Dialog den Namen und Pfad wieder zurück ändern und kann dann das Original üerschreiben. Wie schreibe ich es, dass bei der Frage ob man überschreiben möchte automatisch "NEIN" gewählt wird und stattdessen eine MsgBox("Überschreiben nicht möglich") kommt? Display Alerts aus und dann?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If ActiveWorkbook.Worksheets("Daten").Range("D30") = "XXX" Then
If ActiveWorkbook.Name = "XXX.xlsm" And ActiveWorkbook.Path = "G:\YYY\ZZZ" Then
Cancel = True
Call Speichern
End If
End If
End Sub
Sub Speichern()
Dim Dateiname As String
Dim strFilePathNeu As String
Dim varResult As Variant
Dateiname = "XXX_" & Environ("Username") & "_" & Date
strFilePathNeu = ActiveWorkbook.Path & Application.PathSeparator & "falsch gespeichert" & Application.PathSeparator & Dateiname
MsgBox (Application.UserName & "! Das Original kann nicht überschrieben werden!")
varResult = Application.GetSaveAsFilename(InitialFileName:=strFilePathNeu, Filefilter:="Excel Arbeitsmappe mit Makros (*.xlsm), *.xlsm", _
FilterIndex:=IIf(ActiveWorkbook.HasVBProject, 1, 1))
If varResult <> False Then
ActiveWorkbook.Worksheets("Daten").Range("D30").Value = ""
ActiveWorkbook.SaveAs varResult
End If
End Sub
|