Feldnamen als Dateinamen in Word

Sub SaveAs_form()
'
' SaveAs_form Makro
' Makro erstellt am 29/07/2005 von Jörg Schumacher
'
    Dim strBookmark As String
    strBookmark = ActiveDocument.Bookmarks(Text1).Range
    ActiveDocument.SaveAs FileName:=strBookmark
End Sub

Sub SaveAs_form()
'
' SaveAs_form Makro
' Makro erstellt am 29/07/2005 von Jörg Schumacher
'
  Dim strBookmark As String
  strBookmark = ActiveDocument.Bookmarks(Text1).Range
  ActiveDocument.SaveAs FileName:=strBookmark
End Sub

Sub SpeichernUnterNamenVonTextmarke()
  
  Const c_Bookmark = Text1
  
  Dim doc As Document, s_Bookmark As String
  Dim ret As Integer, l_SaveDisplayAlerts As Long
  Dim s_Path As String, s_Filename As String, s_FilenameFull As String
  
  Set doc = ActiveDocument
  
  On Error Resume Next
  
 ->Textmarke lesen
  s_Bookmark = ActiveDocument.Bookmarks(c_Bookmark).Range.Text
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox (Die notwendige Textmarke-> & c_Bookmark &-> ist nicht vorhanden.)
    GoTo AUFRAEUMEN
  End If
  
 ->Textmarke leer
  If s_Bookmark =  Then
    MsgBox (Die Textmarke-> & c_Bookmark &-> ist leer.)
    GoTo AUFRAEUMEN
  End If
  
 ->Ist das Dokument bereits gespeichert ?
  If doc.Saved Then
   ->ja: dann verwende den Pfad des bereits gespeicherten Dokumentes
    s_Path = doc.Path
  Else
   ->nein: dann verwende den Default-Pfad
    s_Path = Options.DefaultFilePath(Path:=wdDocumentsPath)
  End If
  
 ->Filenamen ggf um .doc erweitern
  If LCase(Right(s_Bookmark, 4)) = .doc Then
    s_Filename = s_Bookmark
  Else
    s_Filename = s_Bookmark & .doc
  End If
  
 ->voller Filename
  s_FilenameFull = s_Path & Application.PathSeparator & s_Filename
  
 ->prüfen, ob file bereits vorhanden ist
  If Dir(s_FilenameFull) <>  Then
    
    ret = MsgBox( _
            Es existiert bereits ein file mit dem Namen:  & vbCrLf & _
            s_FilenameFull & vbCrLf & vbCrLf & _
            Soll das bereits vorhanden file überschrieben werden ?, _
            vbCritical + vbDefaultButton1 + vbYesNo)
    
    If ret = vbNo Then GoTo AUFRAEUMEN
    
  End If
  
 ->Dokument speichern 
  l_SaveDisplayAlerts = Application.DisplayAlerts
  Application.DisplayAlerts = wdAlertsNone
  ActiveDocument.SaveAs FileName:=s_FilenameFull
  Application.DisplayAlerts = l_SaveDisplayAlerts
    
  If Err.Number <> 0 Then
    MsgBox ( _
      Das Dokument konnte nicht gespeichert werden. & vbCrLf & _
      Name:-> & s_FilenameFull &->)
    GoTo AUFRAEUMEN
  End If

AUFRAEUMEN:
  On Error GoTo 0
  Set doc = Nothing
End Sub

Const c_Bookmark = Text1

Const c_Bookmark = Kundennummer

Option Explicit
Sub DateiSpeichernUnter()
  If Not x_SpeichernUnterNamenVonTextmarke Then
    
   ->!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   ->Wenn diese Zeile auskommentiert wird,
   ->wird der Speichernunterdialog
   ->im Fehlerfall nicht mehr angeboten
    Dialogs(wdDialogFileSaveAs).Show
  
  End If
End Sub

'****************************************************************************************
Function x_SpeichernUnterNamenVonTextmarke() As Boolean
  
  Const c_Bookmark = Kundennummer
  Const c_TxT_Chef = vbCrLf & vbCrLf & Bitte beim Chef nachfragen!
  
  Dim doc As Document, s_Bookmark As String
  Dim ret As Integer, l_SaveDisplayAlerts As Long
  Dim s_Path As String, s_Filename As String, s_FilenameFull As String
  
  
  x_SpeichernUnterNamenVonTextmarke = False
  
  Set doc = ActiveDocument
  
  On Error Resume Next
  
 ->Textmarke lesen
  s_Bookmark = ActiveDocument.Bookmarks(c_Bookmark).Range.Text
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox ( _
      Die notwendige Textmarke-> & c_Bookmark &-> ist nicht vorhanden. & _
      c_TxT_Chef)
    GoTo AUFRAEUMEN
  End If
  
 ->Textmarken-Inhalt auf Zulässigkeit prüfen
  If Not TextmarkeInhaltPruefen(s_Bookmark) Then
    MsgBox ( _
      Textmarken-Inhalt von Textmarke-> & c_Bookmark &-> ist unzulässig. & _
      vbCrLf & s_Bookmark & c_TxT_Chef)
    GoTo AUFRAEUMEN
  End If
  
 ->Ist das Dokument bereits gespeichert ?
  If doc.Saved Then
   ->ja: dann verwende den Pfad des bereits gespeicherten Dokumentes
    s_Path = doc.Path
  Else
   ->nein: dann verwende den Default-Pfad
    s_Path = Options.DefaultFilePath(Path:=wdDocumentsPath)
  End If
  
 ->Filenamen ggf um .doc erweitern
  If LCase(Right(s_Bookmark, 4)) = .doc Then
    s_Filename = s_Bookmark
  Else
    s_Filename = s_Bookmark & .doc
  End If
  
 ->voller Filename
  s_FilenameFull = s_Path & Application.PathSeparator & s_Filename
  
 ->prüfen, ob file bereits vorhanden ist
  If Dir(s_FilenameFull) <>  Then
    
    ret = MsgBox( _
          Es existiert bereits ein file mit dem Namen:  & vbCrLf & _
          s_FilenameFull & vbCrLf & vbCrLf & _
          Soll das bereits vorhanden file überschrieben werden ? & _
          c_TxT_Chef, _
          vbCritical + vbDefaultButton1 + vbYesNo)
    
    If ret = vbNo Then GoTo AUFRAEUMEN
    
  End If
  
 ->Dokument speichern unter Inhalt der Textmarke
  l_SaveDisplayAlerts = Application.DisplayAlerts
  Application.DisplayAlerts = wdAlertsNone
  ActiveDocument.SaveAs FileName:=s_FilenameFull
  Application.DisplayAlerts = l_SaveDisplayAlerts
    
  If Err.Number <> 0 Then
    MsgBox ( _
      Das Dokument konnte nicht gespeichert werden. & vbCrLf & _
      Name:-> & s_FilenameFull &-> & c_TxT_Chef)
    GoTo AUFRAEUMEN
  End If
  
  x_SpeichernUnterNamenVonTextmarke = True

AUFRAEUMEN:
  On Error GoTo 0
  Set doc = Nothing
End Function

'****************************************************************************************
Private Function TextmarkeInhaltPruefen(s_TM As String) As Boolean
 ->Prüft Inhalt der Textmarke Kundennummer auf
 ->ZZZBZZZZZZ
 ->Z = Ziffer
 ->B = Buchstabe
  
  Dim s As String, x As Long
  
  TextmarkeInhaltPruefen = False
  
 ->Länge prüfen
  If Len(s_TM) <> 10 Then GoTo AUFRAEUMEN
  
  For x = 1 To Len(s_TM)
    s = Mid(s_TM, x, 1)
    Select Case s
      Case A To Z, a To z
        If x <> 4 Then
          MsgBox ( _
            Textmarke->Kundennummer' enthält an der  & _
            x & .ten Stelle ein unzulässiges Zeichen. & vbCrLf & _
           ->Kundennummer':  & s_TM)
            GoTo AUFRAEUMEN
        End If
      Case 0 To 9
        If x = 4 Then
          MsgBox ( _
            Textmarke->Kundennummer' enthält an der  & _
            x & .ten Stelle ein unzulässiges Zeichen. & vbCrLf & _
           ->Kundennummer':  & s_TM)
            GoTo AUFRAEUMEN
        End If
      Case Else
          MsgBox ( _
            Textmarke->Kundennummer' enthält an der  & _
            x & .ten Stelle ein unzulässiges Zeichen. & vbCrLf & _
           ->Kundennummer':  & s_TM)
            GoTo AUFRAEUMEN
    End Select
  Next

  TextmarkeInhaltPruefen = True
AUFRAEUMEN:
End Function

Sub FileSaveAs(x)
 Dim strPath   As String
 Dim strFileName As String
 Dim lngFormat  As Long
 Dim lngRetVal  As Long
 Dim nPos    As Long

 On Error GoTo err_Handler-> Fehler werden hier abgefangen

If x = 1 Then GoTo weiter:
If x = 3 Then GoTo weiter:

  spName = ActiveDocument.FormFields(Kundennummer).Result-> spName ist Variable für speichername
If spName =  Then MsgBox Ihr Feld Kundennummer zum Speichern ist leer!!!) & vbNewLine & der Speichername heißt jetzt >>Kundenname<<: spName = Name_Vorname


 strPath = c:\temp-> Standart Pfad
 strFileName = spName
 lngFormat = wdFormatdot-> Format wie doc, txt, toc...

 If Right$(strPath, 1) <> \ Then  -> prüfung für selbsternannten Pfad
  strPath = strPath & Application.PathSeparator
 End If

 With Application.Dialogs(wdDialogFileSaveAs)-> aufruf der Speichermeldungen
  .Name = strPath & strFileName
  .Format = lngFormat

  lngRetVal = .Display
  If lngRetVal = -1 Then
   strPath = WordBasic.FileNameInfo$(.Name, 5)
   strFileName = WordBasic.FileNameInfo$(.Name, 3)

   If InStr(1, strFileName, .) > 0 Then-> prüfung des Speichernamens + format
    #If VBA6 Then
      nPos = InStrRev(strFileName, .)
    #Else
      nPos = InStrRevVB5(strFileName, .)
    #End If
    strFileName = Left$(strFileName, nPos - 1)
   End If

   If Len(strFileName) > 50 Then  -> prüfung ob zeichenlänge nicht überschritten
    MsgBox Sorry... der Dateiname darf nicht  & _
        länger als 50 Zeichen sein !, _
        vbOKOnly + vbInformation
    GoTo exit_Sub
   End If

   strFileName = strPath & strFileName->speicherroutine
   ActiveDocument.SaveAs FileName:=strFileName, _
      FileFormat:=lngFormat
   If x = 2 Then
   GoTo weiter:
   End If
  Else
   MsgBox Du hast grad->Abbrechen' geklickt !, _
       vbOKOnlyvbInformation
  End If
 End With

exit_Sub:
 On Error GoTo 0
 Exit Sub