Code von Nepomuk

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Code von Nepumuk

09.04.2015 09:44:20

Nepumuk

AW: Code von Nepomuk

09.04.2015 09:44:44

Nepomuk

AW: Code von Nepomuk

09.04.2015 10:01:40

Nepomuk

AW: Code von Nepomuk

09.04.2015 10:23:14

Nepomuk

AW: Code von Nepomuk

09.04.2015 10:34:00

Nepomuk

AW: Code von Nepomuk

09.04.2015 10:37:43

Nepomuk

AW: Code von Nepomuk

09.04.2015 11:05:54

Nepomuk

AW: Code von Nepomuk

09.04.2015 11:09:05

Nepomuk

AW: Code von Nepomuk

09.04.2015 11:17:40

Nepomuk

besten Dank an Nepumuk

09.04.2015 11:31:50

Thomas

#If win64 Then Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal _ DirPath As String) As Long #Else Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As _ String) As Long #End If

Hallo,
teste mal:

Option Explicit

Private Declare 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
    Const BACKUP_DATE As String = "BackupDate"

    Dim lngReturn As Long
    Dim strPath As String, strFilename As String
    Dim strWorkbookName As String, strExtension As String
    Dim blnFound As Boolean
    Dim objDocumentProperty As DocumentProperty

    For Each objDocumentProperty In CustomDocumentProperties
        If objDocumentProperty.Name = BACKUP_DATE Then
            blnFound = True
            Exit For
        End If
    Next

    If Not blnFound Then CustomDocumentProperties.Add Name:=BACKUP_DATE, _
        LinkToContent:=False, Type:=msoPropertyTypeDate, Value:=Date - 1

    If CustomDocumentProperties.Item(BACKUP_DATE).Value <> Date Then

        CustomDocumentProperties.Item(BACKUP_DATE).Value = Date

        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 If
End Sub

Gruß
Nepumuk

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") & 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

Hallo,
jetzt hab ich noch einen Fehler gefunden. Nachdem ich das Datum der Sicherungskopie geändert habe, muss ich speichern sonst wird beim 2. mal Öffnen ein weiterer Backup erstellt.

Option Explicit

Private Declare 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
    Const BACKUP_DATE As String = "BackupDate"

    Dim lngReturn As Long
    Dim strPath As String, strFilename As String
    Dim strWorkbookName As String, strExtension As String
    Dim blnFound As Boolean
    Dim objDocumentProperty As DocumentProperty

    For Each objDocumentProperty In CustomDocumentProperties
        If objDocumentProperty.Name = BACKUP_DATE Then
            blnFound = True
            Exit For
        End If
    Next

    If Not blnFound Then CustomDocumentProperties.Add Name:=BACKUP_DATE, _
        LinkToContent:=False, Type:=msoPropertyTypeDate, Value:=Date - 1

    If CustomDocumentProperties.Item(BACKUP_DATE).Value <> Date Then

        CustomDocumentProperties.Item(BACKUP_DATE).Value = Date

        Call Save

        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 If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread