Beim Öffnen Sicherungskopie in Unterordner

Sub speichern() Dim dname As String Dim dateiname As String Dim pfad As String dateiname = "Name der Sicherung " pfad = "C:\Dokumente und Einstellungen\..\Eigene Dateien\..\sicherung\2008" dname = Format(Now, "DD_MM_YYYY") Application.DisplayAlerts = False If Dir(pfad & "/" & dateiname & dname & ".xls") = "" Then ActiveWorkbook.SaveCopyAs Filename:=pfad & "/" & dateiname & dname & ".xls" End If Application.DisplayAlerts = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub speichern() Dim dname As String Dim dateiname As String Dim pfad As String dateiname = "Name der Sicherung " pfad = ThisWorkbook.Path & "\Sicherung\" dname = Format(Now, "DD_MM_YYYY") Application.DisplayAlerts = False If Dir(pfad & "/" & dateiname & dname & ".xls") = "" Then ActiveWorkbook.SaveCopyAs Filename:=pfad & dateiname & dname & ".xls" End If Application.DisplayAlerts = True End Sub

Hallo,
in das Modul DieseArbeitsmappe:

Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long

Private Sub Workbook_Open()
    Const COPY_FOLDER As String = "Sicherung"
    Dim lngReturn As Long
    Dim strPath As String, strFilename As String
    strPath = Path & "\" & COPY_FOLDER & "\"
    lngReturn = MakeSureDirectoryPathExists(strPath)
    If lngReturn = 1 Then
        strFilename = Left$(Name, InStrRev(Name, ".") - 1) & "_" & _
            Format(Date, "YYYY_MM_DD") & "." & Right$(Name, Len(Name) - InStrRev(Name, "."))
        If Dir$(strPath & strFilename) <> vbNullString Then Call Kill(strPath & strFilename)
        Call SaveCopyAs(strPath & strFilename)
    Else
        Call MsgBox("Ordner für Sicherungskopie konnte nich angelegt werden." & _
            vbLf & vbLf & "Bitte unbedingt Herrn Fritz W. verständigen.", vbCritical, "Fehler")
    End If
End Sub

Gruß
Nepumuk

Hallo,
so werden die Kopien nach 8 Wochen automatisch gelöscht:

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long

Private Sub Workbook_Open()

    Const COPY_FOLDER As String = "\Sicherung\"
    Const STORE_DAYS As Long = 56

    Dim lngReturn As Long
    Dim strPath As String, strFilename As String
    Dim strWorkbookName As String, strExtension As String

    strPath = Path & COPY_FOLDER

    lngReturn = MakeSureDirectoryPathExists(strPath)

    If lngReturn = 1 Then

        strWorkbookName = Left$(Name, InStrRev(Name, ".") - 1)
        strExtension = Right$(Name, Len(Name) - InStrRev(Name, ".") + 1)

        strFilename = strWorkbookName & "_" & Format(Now, "yyyy_mm_dd_hh_nn_ss") & strExtension

        Call SaveCopyAs(strPath & strFilename)

        strFilename = Dir$(strPath & strWorkbookName & "*" & strExtension)

        Do Until strFilename = vbNullString

            If Now - FileDateTime(strPath & strFilename) > STORE_DAYS Then _
                Call Kill(strPath & strFilename)

            strFilename = Dir$

        Loop

    Else
        Call MsgBox("Ordner für Sicherungskopie konnte nich angelegt werden." & _
            vbLf & vbLf & "Bitte unbedingt Herrn Kaffl Tel. 1625 verständigen.", vbCritical, "Fehler")
    End If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Beim Öffnen Sicherungskopie in Unterordner

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread