Option Explicit
'*****************************************************************
Public Sub SpeichernAls_3OrdnerZurAuswahl()
->Der Makro speichert das aktive Dokument in 3 zur Auswahl
->stehenden Odrnern (s_Ordner1 ... 3, bitte anpassen )
->
->Nach erfolgreichem Speichern wird abgefragt, ob das
->ursprüngliche Document gelöscht werden soll.
->ja: Löschen des ursprünglichen Documents
'*****************************************************************
Const s_Ordner1 As String = c:\Ordner1
Const s_Ordner2 As String = c:\Ordner2
Const s_Ordner3 As String = c:\Ordner3
Dim s_DateiName As String, s_FullName As String
Dim doc As Document, s_tmp As String, s_Eingabe As String
Dim b_Dateiname_ok As Boolean, s_Dateiname2 As String
Dim x As Long, s_letter As String, ret As Integer
Set doc = ActiveDocument
->Dateinamen feststellen
s_DateiName = doc.Name
->vollen Namen mit Pfad feststellen
s_FullName = doc.FullName
->Speicherziel abfragen
s_Eingabe =
Do->solange die Eingabe nicht , 1, 2 oder 3
s_Eingabe = InputBox( _
Bitte wählen Sie die Nummer für den Speicherort aus: & vbLf & _
1 für Odner1 & s_Ordner1 & vbLf & _
2 für Odner1 & s_Ordner2 & vbLf & _
3 für Odner1 & s_Ordner3 & vbLf & _
keine Eingabe -> Abbruch, _
Auswahl des Speicherortes)
Loop While (s_Eingabe <> ) And (s_Eingabe <> 1) And _
(s_Eingabe <> 2) And (s_Eingabe <> 3)
->SpeicherString zusammenstellen
Select Case s_Eingabe
Case 1: s_tmp = s_Ordner1
Case 2: s_tmp = s_Ordner2
Case 3: s_tmp = s_Ordner3
Case Else: GoTo EndeBearbeitung->keine Eingabe -> Abbruch ?
End Select
b_Dateiname_ok = False
s_Dateiname2 = s_DateiName
Do
s_Dateiname2 = InputBox( _
Unter welchem Namen soll die Datei gespeichert werden?, _
Eingabe des Dateinamens, s_Dateiname2)
If s_Dateiname2 = Then
ret = MsgBox(Wollen Sie wirklich abbrechen?, _
vbQuestion + vbYesNo + vbDefaultButton2)
If ret = vbYes Then
GoTo EndeBearbeitung
Else
s_Dateiname2 = s_DateiName
End If
Else
->mindestens 5 Zeichen
If Len(s_Dateiname2) > 5 Then
->Dateityp wie die der Ursprungsdatei ?
If Right(s_Dateiname2, 4) = Right(s_DateiName, 4) Then
For x = 1 To Len(s_Dateiname2) - 4
s_letter = Mid(s_Dateiname2, x, 1)
If Not ZeichenFuerDateiNamenZulaessig(s_tmp) Then
MsgBox (' & s_letter &-> ist unzulässig in einem Dateinamen :-()
b_Dateiname_ok = False
Else
b_Dateiname_ok = True
End If
Next
Else
MsgBox (Dateityp entspricht nicht dem der Ausgangsdatei :-()
End If
Else
s_Dateiname2 = s_DateiName
End If
End If
Loop While (b_Dateiname_ok = False)
->an ausgewähltem Ort speichern
On Error GoTo SpeicherFehler
doc.SaveAs s_tmp & \ & s_Dateiname2
On Error GoTo 0
->Datei schliessen
doc.Close SaveChanges:=False
If vbYes = MsgBox( _
Soll die Ursprüngliche Datei gelöscht werden?, _
vbQuestion + vbDefaultButton2 + vbYesNo) Then
Kill s_FullName->ursprüngliche Datei löschen
End If
GoTo EndeBearbeitung
SpeicherFehler:
MsgBox (Es trat ein Fehler beim Speichern auf)
EndeBearbeitung:
Set doc = Nothing
End Sub
Function ZeichenFuerDateiNamenZulaessig(str As String) As Boolean
Select Case str
Case a To z, A To Z, 0 To 9, ä, Ä, ö, Ö, ü, Ü, ß
ZeichenFuerDateiNamenZulaessig = True
Case !, §, $, %, &, (, ), =, {, [, ], }, +, ~
ZeichenFuerDateiNamenZulaessig = True
Case #, ;, _, -, ., ,, @,
ZeichenFuerDateiNamenZulaessig = True
Case Else
ZeichenFuerDateiNamenZulaessig = False
End Select
End Function
