Excel 2010 Speichern unter Dialog ohne Bestätigung

Sub Speichern_unter1()
 
Dim strDateiName As String
Dim strVerzeichnisPfad As String
Dim strSaveDatei As String
Dim bSpeichernDialog As Boolean
Dim bSpeichern As Boolean

bSpeichern = False
'Wert True = es wird defintiv gespeichert. False = nichts Speichern  

'------------------------------------------------------------------------  
'Festlegen ob der Speichern unter Dialog (GetSaveAsFileName) überhaupt aufgerufen werden soll  
'Wert auf Flase setzen wenn dies nicht gewünscht wird. Kann auch durch eine Zellabfrage (0 oder 1) erfolgen  
'dann bSpeichernDialog = Range("X1") wobei eine 0 Falsch und alles andere Wahr bedeutet. Ansonsten hier Manuell festlegen  

bSpeichernDialog = Range("X1")  
'bSpeichernDialog = False  

'------------------------------------------------------------------------  

'Verzeichnispfad Vorschlag festlegen  
strVerzeichnisPfad = "c:\temp\"  

'Dateiname aus Zelle F4 des aktuellen Blatts holen und Datum (Sortierbar) und Dateierweiterung dranhängen. Die yyymmdd ist bei sortierung richtig  
strDateiName = Range("F4") & Format(Date, "_yyyymmdd") & ".xlsm"  

'Speicherpfad und Dateiname zusammenfügen  
strSaveDatei = strVerzeichnisPfad & strDateiName

'------------------------------------------------------------------------  

'Mit dem jetzt vorhandenen Dateiname inkl. Pfad abfragen ob der Speicherort OK ist.  
'Dazu das Dialogfenster GetSaveAsFilename aufrufen (Achtung, mus Zwingend Bestätigt werden  
'Dies aber nur falls der Dialog abgefragt werden soll. bSpeicherDialog regelt dies über Wahr / Unwahr  
If bSpeichernDialog Then
    'Dialog zum bestätigen des Speicherorts und Datename aufrufen. Achtung, kann auch mit Abbrechen beendet werden  
    'Zuweisen des endgültigen Dateinamens oder ein Falsch wenn abbruch  
    strSaveDatei = SpeichernUnter(strSaveDatei)
    
    'Wurde abgebrochen?  
    If strSaveDatei = "Falsch" Then  
        'Es wurde im Speicherdialog auf Abbrechen geklickt. Nichts zu tun und Tschüß  
        bSpeichern = False
        'Exit Sub  
        'Mit Exit Sub kann hier die gesamte restliche SUB beendet werden. Unschön, aber manchmal nötig  
    Else
        'Im Dialog wurde auf Speichern geklickt  
        bSpeichern = True
    End If
Else
    'Der Dialog sollte nicht aufgerufen werden, also wird der DateiPfad und Name als gegeben und nicht änderbar angenommen.  
    bSpeichern = True
End If
'------------------------------------------------------------------------  

'Bestimmen ob dies eine Neue datei oder eine schon vorhandene ist.  
'Falls neu, das .SaveAs verwenden. Wen die Datei schon vorhanden ist, wird zwingend ein Dialog wegen überschreibung eingeblendet  
'daher falls die Datei schon vorhanden ist, das .Save verwenden was einen Überschreiben Dialog nicht aufruft  
Do While bSpeichern
    If DateiVorhanden(strSaveDatei) Then
        'Datei wird überschrieben OHNE Dialog  
        ActiveWorkbook.Save
    Else
        'Datei wird erstmalig erstellt Ohne Dialog  
        ActiveWorkbook.SaveAs strSaveDatei
    End If
    bSpeichern = False
Loop

End Sub

 
Function SpeichernUnter(VorgabeName As String) As String
' Dialog Aufrufen um den Speicherort zu bestätigen oder einen anderen Speicherort anzugeben und zu bestätigen  
'Kann auch abgebrochen werden. dann ist der Rückgabewert ein "Falsch", sonst der Pfad und Dateiname  

    SpeichernUnter = Application.GetSaveAsFilename(InitialFileName:=VorgabeName, Filefilter:="Excel Dateien (*.xlsm),*.xlsm*", FilterIndex:=1, Title:="Speichern unter...", ButtonText:="speichern")  
    'strSaveDatei = SpeichernUnter  
End Function


Function DateiVorhanden(DateipfadName As String) As Boolean
'Über die Dir Funktion schauen ob die Datei existirt. Wenn ja, wird der dateiname zurückgegeben, sonst ein null String  
'Mit dem vergleich > wird geschaut ob etwas zurück kam. Ergebniss ist True oder False  

    DateiVorhanden = (Dir(DateipfadName) > "")  
   
End Function