Hallo,
wenn die Sub Speichern durch meine Funktion FileSaveAs ersetzt wird, dann wird beim Speichern bei Bedarf eine Siicherungskopie angelegt:
''' <summary>
''' Speichert aktuelle Arbeitsmappe ab (mit DialogBox "Speichern unter")
''' </summary>
''' <returns>
''' Type: Boolean
''' True = Speichervorgang erfolgreich abgeschlossen
''' False = Speichervorgang nicht durchgeführt
''' </returns>
''' <remarks>
''' Falls der Anwender die Originaldatei überschreiben will, werden folgende Aktionen durchgeführt:
''' - die derzeitige Aktive Arbeitsmappe im %Temp% Verzeichnis speichern
''' - die Originaldatei verschieben in den Unterordner "Sik"
''' - verschieben der im %temp% Verzeichnis gespeicherten Arbeitsmappe in den ursprünglichen Ordner
''' </remarks>
Function FileSaveAs() As Boolean
Dim varResult As Variant
' Mit Verweis auf Mirosoft Scripting Runtime
Dim objFSO As New Scripting.FileSystemObject
' Alternativ Late Binding:
' ========================
'Dim objFSO As Object
'Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim strFilePathOrig As String
Dim strFilePathSik As String
Dim strTMPFile As String
strFilePathSik = ActiveWorkbook.Path & Application.PathSeparator & "sik" & Application.PathSeparator & ActiveWorkbook.Name
strFilePathOrig = ActiveWorkbook.Path & Application.PathSeparator & ActiveWorkbook.Name
varResult = Application.GetSaveAsFilename(InitialFileName:=strFilePathOrig, FileFilter:= _
"Excel Arbeitsmappe (*.xlsx), *.xlsx, Excel Arbeitsmappe mit Makros (*.xlsm), *.xlsm", _
FilterIndex:=IIf(ActiveWorkbook.HasVBProject, 2, 1))
If Not varResult = False Then
If LCase(varResult) = LCase(strFilePathOrig) Then
' Die aktuelle Datei als temporäre Datei speichern
strTMPFile = Environ("TEMP") & "\Temp.xls" & IIf(ActiveWorkbook.HasVBProject, "m", "x")
If objFSO.FileExists(strTMPFile) Then
Kill strTMPFile
End If
ActiveWorkbook.SaveAs strTMPFile
ActiveWorkbook.Close
' Original verschieben
If Not objFSO.FolderExists(objFSO.GetParentFolderName(strFilePathSik)) Then
MkDir objFSO.GetParentFolderName(strFilePathSik)
End If
If objFSO.FileExists(strFilePathSik) Then
Kill strFilePathSik
End If
objFSO.MoveFile strFilePathOrig, strFilePathSik
' Verschieben der Temporären Datei zur Original-Datei
objFSO.MoveFile strTMPFile, strFilePathOrig
Application.Workbooks.Open strFilePathOrig
FileSaveAs = True
End If
End If
End Function
Diese Funktion muss mit
call FileSaveAs()
im Sub Workbook_BeforeSave aufgerufen werden. Wichtig ist es, dass der Parameter CAncel weiterhin auf True gesetzt wird.
Der Rückgabewert von der Funktion FileSaveAs kann bei Bedarf ausgewertet werden, um den Benutzer darauf hinzuweisen, dass die Speicherung erfolgreich abgeschlossen (oder abgebrochen) wurde.
VG, BigBen
|