habe da ein Problem
Ist es möglich nach Betätigung der Button "Speichern" oder "Abbrechen" im Exceldialog "Speichern unter" einen Rückgabewert zu erhalten, welcher der beiden Button betätigt wurde.
Der Aufruf des Dialogs erfolgt aus einem Macro heraus und ist abhängig vom Dateinamen. Bei Betätigung des Buttons "Speichern" soll die Datei anschließend geschlossen werden, bei "Abbrechen" natürlich nicht. Da sich das ActiveWorkbook.Close Ereignis unmittelbar an die Ausführung des Dialogs anschließt möchte ich es bei "Abbrechen" abfangen.
Ich hab mal den Code angefügt
Sub Beih_Schließ()
Dim i As Integer
'On Error Resume Next
i = msgbox _
("Sollen Ihre Änderungen in ''" & ActiveWorkbook.Name & "'' gespeichert werden?", _
3 + 48, "Datei speichern?")
' Abbrechen
If i = 2 Then Exit Sub
' Schließen ohne speichern
If i = 7 Then
Application.DisplayFullScreen = False
ActiveWorkbook.Close savechanges:=False
Exit Sub
End If
' Schließen mit speichern
If i = 6 Then
Dim e As Integer, Workname, WorkNameNeu, pfad, _
LW, Laufw, str, persnum
Workname = ActiveWorkbook.Name
pfad = ActiveWorkbook.Path
persnum = Sheets("Antrag Seite 1").[b13]
'Speichern unter/in bestehemdem Namem/Verzeichnis
If ActiveWorkbook.Name <> "Beihilfe-Antrag.xls" Then GoTo 1:
'Speichernachfrage
If Workname = "Beihilfe-Antrag.xls" Then _
e = msgbox _
("Die Datei wird standardmäßig unter dem Namen Beihilfe-Antrag- und" & Chr(13) & _
"Ihrer Personal-/Versorgungsnummer (''Beihilfe-Antrag-" & persnum & ".xls'')" & Chr(13) & _
"im Verzeichnis der Grunddatei " & Chr(13) & _
"''" & pfad & "'' gespeichert" & Chr(13) & Chr(13) & _
"Sollten Sie dem zustimmen drücken Sie ''Ja''" & Chr(13) & Chr(13) & _
"Wenn Sie Dateiname und Speicherpfad selbst" & Chr(13) & _
"bestimmen möchten drücken Sie ''Nein''", 4 + 32, "Speichern unter")
If e = 7 Then
Debug.Print RunCommand(748) ' Datei speichern unter
ActiveWorkbook.Close savechanges:=False 'Da bereits unter neuem Namen gespeichert
Exit Sub
End If
'Speichern unter "Beihilfe-Antrag-PersNr. in bestehendem Verzeichnis
WorkNameNeu = "Beihilfe-Antrag-" & Sheets("Antrag Seite 1").[b13] & ".xls"
Laufw = Mid(pfad, 1, 3)
LW = Laufw
pfad = pfad
str = WorkNameNeu
ChDrive LW
ChDir pfad
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=str
Application.DisplayFullScreen = False
ActiveWorkbook.Close savechanges:=False
Exit Sub
1:
Application.DisplayFullScreen = False
ActiveWorkbook.Close savechanges:=True
End If
End Sub
Sub RunCommandTest()
Debug.Print RunCommand(748) ' Datei speichern unter
End Sub
Function RunCommand(lngID As Long)
Dim ctlTemp As CommandBarControl
Set ctlTemp = CommandBars.FindControl(ID:=lngID)
If ctlTemp Is Nothing Then
On Error Resume Next
With CommandBars.Add(Name:="Temp", Temporary:=True)
.Controls.Add ID:=lngID
.Controls(1).Execute
.Delete
End With
Else
ctlTemp.Execute
End If
RunCommand = (Err.Number = 0)
Application.DisplayFullScreen = False
End Function
Ich hoffe ihr könnt damit was angfangen und ho´ffe auf Hilfe.
Dank im voraus
Gruß Det