Ereignismakros "kollidieren"
07.03.2017 09:38:15
Florian
Guten Morgen
Meine Ereignismakros scheinen zu kollidieren, oder ein Makro funktioniert nicht sauber.
Da der Upload relativ schwierig ist, weil z.B. 7zip als Backup Programm benötigt wird, versuche ich das ganze erstmal ohne - wenn es nicht ohne Datei geht, kann ich versuchen die betroffenen Makros aus meinem Programm in eine Beispieldatei zu packen.
Es gibt eine Seite "Einstellungen" welche ich über eine Userform bediene und dann Werte in True und False ändere - hierauf greife ich dann mit anderen Makros zu.
So auch E4 für Autosave True oder False.
Nun gibt es ein Makro im Workbook_BeforeClose:
With ThisWorkbook.Worksheets("Einstellungen")
MsgBox ("läufT")
.Range("A1") = Year(Date)
If .Range("E4") = True Then ActiveWorkbook.Save
If .Range("G7") = True Then Call DelDatensicherung
End With
Wenn also E4 Wahr ist, wird meine Datei beim schließen gespeichert, die Meldung "wollen sie speichern vorm beenden" wird unterdrückt.
Das funktioniert soweit, jedoch nicht, wenn meine Datensicherung läuft.
Dann soll die Datei beendet werden (was auch klappt) - es erscheint aber die Meldung ob gespeichert werden soll.
Diese kommt sowohl, wenn ich die Datensicherung manuell starte, als auch wenn sie automatisch startet.
Ich kann mir jedoch nicht erklären, warum das so ist.
Hier die Makros die ich dafür für relevant erachte:
Ereignismakros:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
With ThisWorkbook.Worksheets("Einstellungen")
MsgBox ("läufT")
.Range("A1") = Year(Date)
If .Range("E4") = True Then ActiveWorkbook.Save
If .Range("G7") = True Then Call DelDatensicherung
End With
End Sub
Sub Workbook_Activate()
Application.Caption = Worksheets("Einstellungen").Range("B2").Value & " offene Lieferungen _
/ " & Worksheets("Einstellungen").Range("B4").Value & " offene Kundenbestellungen"
ActiveWindow.Caption = "Bestellwesen"
If Worksheets("Einstellungen").Range("E10") = False Then Application.DisplayFormulaBar = _
False
End Sub
Private Sub Workbook_Open()
With ThisWorkbook.Worksheets("Einstellungen")
If Year(Date) = .Range("A1") + 1 Then
Call Jahreswechselmakro
ElseIf .Range("E5") = True Then
Application.OnTime Now, "letzteDatensicherung"
End If
End With
End Sub
Jahreswechselmakro wird nur gestartet, wenn das Jahr eins größer wird.
'Makro für Zeitdifferenz der letzten Datensicherung
Sub letzteDatensicherung()
Dim strVerzeichnis As String
Dim StrDatei As String
Dim i As Integer
Dim strTyp As String
Dim Dateiname As String
Dim zeit As Date
Dim Difzeit As Long
strVerzeichnis = ThisWorkbook.Path & "\zbackup\"
strTyp = "*.zip"
Dateiname = Dir(strVerzeichnis & strTyp)
If Dateiname = "" Then
If MsgBox("Es gibt keine Datensicherung" & _
Chr(10) & "Soll diese nun erzeugt werden?", vbYesNo) = vbNo Then Exit Sub
Call Datensicherung
Exit Sub
End If
zeit = FileDateTime(strVerzeichnis & Dateiname)
Do While Dateiname ""
If zeit = Worksheets("Einstellungen").Range("E6").Value Then
If MsgBox("Die letzte Datensicherung ist " & Difzeit & " Tage alt." & _
Chr(10) & "Soll jetzt eine Datensicherung erzeugt werden?", vbYesNo) = vbNo Then Exit _
Sub
Call Datensicherung
End If
End Sub
'Makro zum erstellen der Datensicherung
Sub Datensicherung()
Dim Pfad7z As String
Dim PfadBackup As String
Dim PfadDateien As String
Dim datum As String
datum = Format(Now, "YYYY.MM.DD HH.MM")
Pfad7z = ThisWorkbook.Path & "\Programme\7zip\"
PfadBackup = ThisWorkbook.Path & "\zbackup\"
PfadDateien = ThisWorkbook.Path
TBbeendet = True
FFbeendet = True
ActiveWorkbook.Save
'Prüfem ob Thunderbird läuft
TBbeenden
If TBbeendet = False Then Exit Sub
'Prüfen ob Firefox läuft
FFbeenden
If FFbeendet = False Then Exit Sub
'Datensicherung von allem
Shell (Pfad7z & "7za a -tzip " & Chr(34) & PfadBackup & datum & ".zip" & Chr(34) & " " & _
Chr(34) & PfadDateien & Chr(34) & " -xr!*.zip"), vbNormalFocus
ThisWorkbook.Close
End Sub
'Makro zum löschen der Datensicherungen
Public Sub DelDatensicherung()
Dim strVerzeichnis As String
Dim strTyp As String
Dim Dateiname As String
Dim lngbehalten As Long
Dim i As Integer
Dim arrDateiname() As String
Dim j As Long
strVerzeichnis = ThisWorkbook.Path & "\zbackup\"
strTyp = "*.*"
Dateiname = Dir(strVerzeichnis & strTyp)
lngbehalten = ThisWorkbook.Worksheets("Einstellungen").Range("E7").Value
Do While Dateiname ""
i = i + 1
ReDim Preserve arrDateiname(1 To i)
arrDateiname(i) = Dateiname
Dateiname = Dir
Loop
BubbleSort arrDateiname(), False
For j = 1 To i
If j > lngbehalten Then
Kill strVerzeichnis & arrDateiname(j)
End If
Next
End Sub