... oder doch lieber luxuriös ;-))
02.11.2003 15:40:24
Ramses
Hallo,
Nun ist aber Schluss ;-)
Sub Save_Workbook_as_Name_Date_and_Time()
'(C) by Ramses
'Speichert die aktuelle Mappe unter dem Namen in B1
'im Pfad aus A1 mit dem Zusatz Datum und Zeit
Dim myFso As Object
Dim myDate As String, myTime As String
Dim SaveString As String, myPath As String
Dim tmpPath As String, strTmp As String
Dim i As Integer, n As Integer, Qe As Integer
'FSO Object für die Folderprüfung
Set myFso = CreateObject("Scripting.FileSystemObject")
'Formatierung nötig um englische Datumsformate mit "/" auszuschliessen
myDate = Format(Date, "dd.mm.yyyy")
'Formatierung nötig, da in "Now" das unerlaubte Zeichen ":" vorkommt
myTime = Format(Now, "hh-mm-ss")
'Zelle woher der Pfad kommen soll
myPath = Range("A1").Value
'Prüfen ob der Pfad existiert
If myFso.folderexists(myPath) = False Then
Qe = MsgBox("Der Pfad bzw. der Ordner existiert nicht !" & vbCrLf & "Soll er erstellt werden?", vbYesNo + vbCritical, "Dateifehler")
If Qe = vbYes Then
'Nicht existierenden Pfad erstellen
n = 1
tmpPath = myPath
Do
i = InStr(n, tmpPath, "\")
If i > 0 Then
strTmp = Left(tmpPath, i)
n = i + 1
Else
strTmp = tmpPath
n = Len(tmpPath)
End If
If Dir(strTmp, vbDirectory) = vbNullString Then
MkDir strTmp
End If
Loop Until i = 0
Else
MsgBox ("Speichervorgang wegen Fehler in Pfadnamen abgebrochen !")
Exit Sub
End If
End If
'Prüfen ob letztes Zeichen ein Backslash ist
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
'Zelle woher der Dateiname kommen soll
SaveString = Range("B1").Value
'Prüfen auf unerlaubte Zeichen im Dateinamen
For i = 1 To Len(SaveString)
Select Case Mid(SaveString, i, 1)
Case "\", "/", ">", "<", ":", "*", "?", "[", "]", "¦"
MsgBox ("Unerlaubtes Zeichen """ & Mid(SaveString, i, 1) & """ an Position " & i & " in " _
& """" & SaveString & """" & vbCrLf _
& vbCrLf & "Speichervorgang wegen Fehler in Dateinamen abgebrochen")
Exit Sub
End Select
Next i
'Speichern
ThisWorkbook.SaveAs Filename:=myPath & SaveString & "_" & myDate & " " & myTime & ".xls"
End Sub
Gruss Rainer