Thema Datum  Von Nutzer Rating
Antwort
11.09.2015 12:44:38 Enrico
NotSolved
11.09.2015 17:22:12 BigBen
NotSolved
Rot Datei vor überschreiben schützen
 11.09.2015 17:34:39 Gast87410
NotSolved
14.09.2015 11:11:22 Gast85128
NotSolved
14.09.2015 11:48:50 BigBen
NotSolved
14.09.2015 19:14:53 BigBen
NotSolved
24.09.2015 11:13:43 Gast99094
NotSolved

Ansicht des Beitrags:
Von:
Gast87410		 Datum:
11.09.2015 17:34:39		 Views:
2275		 Rating:
     
Antwort:
  Ja
Thema:
Datei vor überschreiben schützen

Nachtrag:

Der zuvor gepostete Code speichert eine Datei nicht ab, wenn ein anderer Dateiname ausgewählt wird, mit diesem Code wird die Speicherung immer ausgeführt:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
''' <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
        Else
            ActiveWorkbook.SaveAs varResult
            FileSaveAs = True
        End If
    End If
End Function

Falls bereits eine Sicherungskopie von einem vorhergehenden Speicher-Vorgang angelegt wurde, wird diese ungefragt überschrieben!

Falls dies nicht sein soll, muss folgender Code verwendet werden:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
''' <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
'''
''' Falls eine Sicherungskopie bereits vorhanden ist, wird diese nicht überschrieben!
''' </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
            ' Prüfen, ob noch keine Sicherungskopie existiert
            If Not objFSO.FileExists(strFilePathSik) 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
            Else
                ActiveWorkbook.Save
                FileSaveAs = True
            End If
        Else
            ActiveWorkbook.SaveAs varResult
            FileSaveAs = True
        End If
    End If
End Function

VG, BigBen

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
11.09.2015 12:44:38 Enrico
NotSolved
11.09.2015 17:22:12 BigBen
NotSolved
Rot Datei vor überschreiben schützen
 11.09.2015 17:34:39 Gast87410
NotSolved
14.09.2015 11:11:22 Gast85128
NotSolved
14.09.2015 11:48:50 BigBen
NotSolved
14.09.2015 19:14:53 BigBen
NotSolved
24.09.2015 11:13:43 Gast99094
NotSolved