AW: Workbook.BeforeClose mehrmals aufrufbar ?
17.07.2016 16:51:14
Peter
Ja, er sollte schon noch abfragen.
Einfach Dialog 1 : Wollen Sie speichern : User klickt abbrechen
DANACH klickt der User wieder auf das X oben rechts
Dialog 2 : kommt erst gar nicht, die Datei wird sofort beendet.
Er geht gar nicht mehr in die Methode/Funktion rein. Was muss ich machen, damit er wieder bei der Methode BeforClose(Cancel as Boolean) reingeht ?
Code:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim path, bauvorhaben, Vorname, bauort As String
Dim inputUser, OfferNumber, inputUser2 As Integer
Dim firstRun, foundFile As Boolean
Dim todayDate As Date
Set fso = CreateObject("Scripting.FileSystemObject")
'declare Var
path = "S:\Angebote\ANGEBOTE Marten\"
firstRun = True
foundFile = True
Set oMainFolder = fso.GetFolder(path)
Set subfolders = oMainFolder.subfolders
inputUser = MsgBox("Möchten Sie die Datei speichern ?", vbYesNoCancel, "Speicherung")
UnlockWorksheets
If (inputUser = 6) Then
With Tabelle2
bauvorhaben = .Cells(2, "D").Value
bauort = .Cells(2, "G").Value
OfferNumber = .Cells(3, "B").Value
If (OfferNumber = "") Then
OfferNumber = 1
.Cells(3, "B").Value = OfferNumber
End If
End With
If (bauvorhaben = "") Then
GoTo exceptionBauvorhaben
ElseIf (bauort = "") Then
GoTo exceptionBauport
End If
'On Error GoTo exceptionUnbekannterFehler
If (ActiveWorkbook.Name "1-NEU Kalkulation.xlsm") Then
Do While (foundFile)
MsgBox Application.ActiveWorkbook.path & "\" & bauvorhaben & "_" & bauort & "_" _
& "Kalkulation" & "_" & OfferNumber
If (fso.FileExists(Application.ActiveWorkbook.path & "\" & bauvorhaben & "_" & _
bauort & "_" & "Kalkulation" & "_" & OfferNumber & ".xlsm")) Then
OfferNumber = OfferNumber + 1
Else
foundFile = False
End If
Loop
If Not (foundFile) Then
MsgBox "Eine weitere Datei wird erstellt", vbOKOnly, "Neues Angebot"
Tabelle2.Cells(3, "B").Value = OfferNumber
ActiveWorkbook.SaveAs Filename:=Application.ActiveWorkbook.path & "\" & _
bauvorhaben & "_" & bauort & "_" & "Kalkulation" & "_" & OfferNumber
End If
Else
For Each oFolder In oMainFolder.subfolders
If (InStr(oFolder.Name, bauvorhaben) 0 And InStr(oFolder.Name, bauort) 0) _
Then
If (fso.FileExists(path & oFolder.Name & "\" & bauvorhaben & "_" & bauort & _
"_" & "Kalkulation" & "_" & OfferNumber & ".xlsm")) Then
inputUser2 = MsgBox("Wollen Sie die Datei überschreiben ?", _
vbYesNoCancel, "Datei schon vorhanden")
If (inputUser2 = 6) Then
ActiveWorkbook.SaveAs Filename:=path & oFolder.Name & "\" & _
bauvorhaben & "_" & bauort & "_" & "Kalkulation" & "_" & OfferNumber
ElseIf (inputUser2 = 2) Then
Cancel = True
Else
Set fdOpen = Application.FileDialog(msoFileDialogSaveAs)
MsgBox "Bitte geben Sie eine neue Angebotsnummer ein", vbOKOnly, " _
Datei Speichern"
fdOpen.InitialFileName = path & oFolder.Name & "\" & bauvorhaben & " _
_" & bauort & "_" & "Kalkulation" & "_" & OfferNumber
fdOpen.FilterIndex = 2
fdOpen.Title = "Ändern Sie die Angebotsnummer und speichern Sie die _
Datei ab"
If (fdOpen.Show = 0) Then
Cancel = True
End If
End If
Else
ActiveWorkbook.SaveAs Filename:=path & oFolder.Name & "\" & bauvorhaben _
& "_" & bauort & "_" & "Kalkulation" & "_" & OfferNumber
End If
firstRun = False
Else
If (Dir(path & bauvorhaben & "_" & bauort & "_Angebot", vbDirectory) = "") _
Then
MkDir path & bauvorhaben & "_" & bauort & "_Angebot"
ActiveWorkbook.SaveAs Filename:=path & bauvorhaben & "_" & bauort & " _
_Angebot" & "\" & bauvorhaben & "_" & bauort & "_" & "Kalkulation" & "_" & OfferNumber
firstRun = False
Exit For
End If
End If
Next
'Leeren Verzeichnis passiert nichts
If (firstRun) Then
MkDir path & bauvorhaben & "_" & bauort & "_Angebot"
ActiveWorkbook.SaveAs Filename:=path & bauvorhaben & "_" & bauort & "_Angebot" & _
"\" & bauvorhaben & "_" & bauort & "_" & "Kalkulation" & "_" & OfferNumber
End If
If (Dir(path & bauvorhaben & "_" & bauort & "_Angebot", vbDirectory) = "") Then
MsgBox "Fehler ist aufgetreten", vbCritical
End If
LockWorksheets
End If
ElseIf (inputUser = 2) Then
Cancel = True
End If
ThisWorkbook.Saved = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
exceptionBauvorhaben:
MsgBox "Bitte geben Sie das Bauvorhaben an", vbOKOnly, "Bauvorhaben FEHLT"
Cancel = True
Exit Sub
exceptionBauport:
MsgBox "Bitte geben Sie den Ort an", vbOKOnly, "Bauvorhaben FEHLT"
Cancel = True
Exit Sub
exceptionUnbekannterFehler:
MsgBox "Es ist ein unbekannter Fehler aufgetreten", vbCritical, "Unbekannter Fehler"
End Sub