AW: Prozedur-Fehler bei Auruf über BeforeClose/Save
14.04.2009 20:18:36
Rainer
Hi Gerd!
Dank Dir erstmal für die Antwort. Okay, hast sicherlich recht, war irgendwie davon ausgegangen das es eher ein generelles Problem ist als ein Codefehler ... aber natürlich, Hochmut kommt vor dem Fall. ^^
Hier ist der erste Teil:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Range("Data!AF1").Value = "JA"
ActiveWorkbook.Save
If Range("Data!AF3").Value "JA" Then GoTo Nichtmöglich
Dim Mappe As Workbook
Dim Name As String
For Each Mappe In Application.Workbooks
Name = Mappe.Name
If Not Name Like "Zentral.xls" Then
GoTo NichtSchliessen
End If
Next Mappe
' Abfrage für Schnellspeicherung ohne BU
frage = MsgBox _
("Schnellspeicherung ohne AutoBackup?" & vbLf & _
"(Wenn Sie auf einem mobilen Gerät unterwegs arbeiten, " & vbLf & _
"könnten die Speicherpfade für das Backup nicht vorhanden sein!)", vbYesNo + vbQuestion, " _
AutoBackup?")
If frage = vbYes Then GoTo Schluss ' wenn Ja als Antwort dann zum Ende ohne AutoBU
' und bei Nein normal weiter
If Range("Data!E29") = 2 Then BackupArbeitspfaderstellen Else GoTo Normal ' Abfang ob nur _
Kunden BU oder auch Arbeitsdateien BU gesetzt ist
Normal:
If Range("Data!E44") = 2 Then BackupKundenerstellen
If Range("data!G56") "" Then GoTo Warnung Else Cancel = False ' Abfang ob AutoBu für _
KundenZentral gesetzt
GoTo Schluss
Warnung:
frage = MsgBox _
("AutoBackup aktiv! Wenn Sie Excel schliessen, wird das AutoBackup nicht ausgeführt!" & vbLf & _
_
_
_
" " & vbLf & _
"Wollen Sie Excel wirklich verlassen?" & vbLf & _
" " & vbLf & _
"(ACHTUNG! Backup erfolgt nicht wenn Sie Excel jetzt verlassen!)", _
4 + vbCritical, "AutoBackup Aktiv!")
If frage = 7 Then Cancel = True Else Cancel = False
Schluss:
' Zurücksetzuung der Ausblendung die beim Öffnen aktiviert wurde
Application.CommandBars("Standard").Visible = True
Application.DisplayFormulaBar = True
Application.DisplayStatusBar = True
Exit Sub
Nichtmöglich:
Cancel = True
MsgBox "Schliessen nur über die interne Funktion möglich!", vbInformation
NichtSchliessen:
Cancel = True
MsgBox "Es sind noch Mappen offen, schliessen Sie diese bitte erst bevor Sie Zentral.xls _
schliessen!", vbCritical
End Sub
Und hier die Sub nicht normal problemlos läuft, ausser sie wird aus dem obigen Code heraus aufgerufen:
Sub BackupArbeitspfaderstellen()
ActiveWorkbook.Save
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
qpfad = Range("Data!C13").Value
zpfad = Range("Data!C22").Value
oname = Range("Data!C34").Value
neuname = Range("Data!C35").Value
lpfad = Range("Data!C24").Value
üpfad = Range("Data!D13").Value
laufwerk = Range("Data!C21").Value
On Error GoTo Fehler3
If Len(Dir(laufwerk, vbDirectory)) > 0 Then ChDir laufwerk Else _
GoTo Fehler3
On Error GoTo Anlegen
ChDir zpfad
GoTo BereitsAngelegt
Anlegen:
zpfad1 = Range("data!c21") & Range("data!c23")
If Len(Dir(zpfad1, vbDirectory)) > 0 Then ChDir zpfad1 Else GoTo ErstAnlegen
GoTo WeiterAnlegen
ErstAnlegen:
MkDir zpfad1
WeiterAnlegen:
On Error GoTo Fehler3
MkDir zpfad
BereitsAngelegt:
On Error GoTo Fehler
fso.CopyFolder qpfad, zpfad
Dim i As Integer
i = Range("data!d22").Value
i = i + 1
Range("Data!d22").Value = i
Range("data!C26").Value = zpfad
On Error GoTo ErrorHandler
Workbooks.Open Filename:=oname
oname = ActiveWorkbook.Name
Range("FB!C1").Value = üpfad
Set NewBook = ActiveSheet
NewBook.SaveAs Filename:=neuname
ActiveWorkbook.Close SaveChanges:=False
On Error GoTo Fehler2
If Range("data!d24") 0 Then fso.deletefolder lpfad Else GoTo Normal
MsgBox "Backup erfolgreich beendet, Ordner " & zpfad & " erstellt!" & vbLf & _
" " & vbLf & _
"Altes Backup " & lpfad & " wurde gelöscht."
Exit Sub
Normal:
MsgBox "Backup erfolgreich beendet, Ordner " & zpfad & " erstellt!" & vbLf & _
" " & vbLf & _
"Alte Backupdatei " & lpfad & " konnte nicht gelöscht werden."
Exit Sub
Fehler2:
MsgBox "Backup erfolgreich beendet, Ordner " & zpfad & " erstellt!" & vbLf & _
vbLf & _
"Aber Löschung altes Backup schlug fehl!"
Exit Sub
Fehler:
MsgBox "Backup ist fehlgeschlagen! Prüfen Sie bitte ob LW überhaupt existiert"
Exit Sub
Ende:
MsgBox "Backup erfolgreich beendet, Ordner " & zpfad & " erstellt!"
Exit Sub
Fehler3:
MsgBox "Auf Laufwerk/Verzeichnis für Backup Arbeitsdateien" & vbLf & _
"kann nicht zugegriffen werden!"
Exit Sub
ErrorHandler:
MsgBox "Für diese Prozedur ist das automatische Backup nicht verfügbar!"
End Sub
Hoffe ihr könnt nun besser was draus erkennen.
Gruß
Rainer