' ---------------------------------------------------------
' Funktion: SaveAsName_Date_Time
' Eingestellt von: Andre Schau
' Datum: 5. Julei 2012
' Kommentar:
' Parameter: optional Dateiname strFile, Pfad strPath,
' und mit Datum und Zeit boDT
' zusaetzlich benoetigte Funktionen:
' CheckPath, CheckFileName
' Hinweis: zusätzlich benoetigte Funktionen koennen
' durch Codeaenderung entfallen
' Rückgabe: Erfolg: "", ansonsten Fehlermeldung
' Aufruf:
Sub SaveWithNameDate()
Dim errMsg$
errMsg = SaveAsName_Date_Time
If errMsg <> "" Then MsgBox errMsg
End Sub
Private Function SaveAsName_Date_Time( _
Optional ByVal strPath As String, _
Optional ByVal strFile As String, _
Optional boDT As Boolean = True) As String
'Speichert diese Datei mit Name und Zeit
'benötigte Funktion: CheckFileName, ggf. CheckPath einbauen
SaveAsName_Date_Time = ""
'Variablendeklarationen
'String
Dim strDate$, strTime$, strFullName$, strExt$
'_Datum
strDate = Format(Date, "_yyyymmdd")
'_Zeit
strTime = Format(Now, "_hhmmss")
'Wenn Parameter strPfad leer, dann
If strPath = "" Then
'strPfad gleich Pfad von diesem Workbook setzen
strPath = ThisWorkbook.Path
'Oder Wenn Parameter strPfad nicht leer, dann
'Hinweis: Fehlt die Funktion CheckPath, dann
'den Else-Zweig entfernen
Else
'Zeichen prüfen - nur bei Parameter notwendig
strCheck = CheckPath(strPath, 1)
'Wenn strCheck nicht leer, dann
If strCheck <> "" Then
'Rueckgabewert gleich strCheck setzen
SaveAsName_Date_Time = strCheck
'Funktion verlassen
Exit Function
'Ende Wenn strCheck nicht leer, dann
End If
'Ende Wenn Parameter strPfad leer, dann
End If
'Wenn Parameter strFile leer, dann
If strFile = "" Then
'strFile gleich name von diesem Workbook setzen
strFile = ThisWorkbook.Name
'Oder Wenn Parameter strFile nicht leer, dann
'Hinweis: Fehlt die Funktion CheckFileName, dann
'den Else-Zweig entfernen
Else
'Zeichen prüfen - nur bei Parameter notwendig
strCheck = CheckFileName(strFile, 1)
'Wenn strCheck nicht leer, dann
If strCheck <> "" Then
'Rueckgabewert gleich strCheck setzen
SaveAsName_Date_Time = strCheck
'Funktion verlassen
Exit Function
'Ende Wenn strCheck nicht leer, dann
End If
End If
'Dateiextension an letztem Punkt im Namen abtrennen
strExt = Split(strFile, ".")(Ubound(Split(strFile, ".")))
'ggf. \ rechts ergänzen
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'strFullName gleich Pfad + Dateiname ohne Erweiterung + Datum setzen
strFullName = strPath & Left(strFile, Len(strFile) - Len(strExt) - 1) & strDate
'Wenn Datum und Zeit = True, dann strFullName mit Zeit ergaenzen
If boDT Then strFullName = strFullName & strTime
'Fileextension je nach Version xls oder xlsx
'manuell setzen oder code erweitern -
'automatisch mit Versionspruefung
strFullName = strFullName & "." & strExt
'Bei Fehler zur Fehlerbehandlung gehen
On Error GoTo errorhandler
'Datei strFile unter strFullName speichern
Workbooks(strFile).SaveAs Filename:=strFullName
'Funktion verlassen
Exit Function
'Fehlerbehandlung
errorhandler:
'Rueckgabewert gleich Fehlernummer und Fehlerbeschreibung
SaveAsName_Date_Time = Err.Number & " " & Err.Description
End Function