Sub Speichern_ohneTTfonts() 
'speichert das active doc in denselben ordner ohne eingebettete TTfonts 
    Dim strPath As String 
    Dim strName As String 
    Dim strZusatz As String 
    Dim intPos As Integer 
    Dim strExt As String 
    strPath = ActiveDocument.Path & Application.PathSeparator  '!!!path fehlt falls doc noch gar nicht gespeichert ist 
    strName = ActiveDocument.Name 
    strZusatz = "_ohneTTfonts"        'wird dem Dateinamen angehängt 
    intPos = InStrRev(strName, ".")   'zum Trennen von Dateiname und Extension 
    strExt = "." & Right(strName, Len(strName) - intPos) 
    strName = Left(strName, intPos - 1) 'Dokumentname ohne Extension 
     
    With ActiveDocument 
       If .EmbedTrueTypeFonts Then     'falls TTfonts im Doc eingebettet 
          .EmbedTrueTypeFonts = False  'TT-status auf NICHT einbetten setzen 
          strName = strName & strZusatz & strExt  'neuen Dateinamen zusammensetzen 
          .SaveAs FileName:=strPath & strName 
          MsgBox ("Das Dokument wurde ohne eingebettete TT-Fonts gespeichert als:" & vbCr & vbCr _ 
                  & strName & vbCr & vbCr & "im Ordner:" & vbCr & vbCr & strPath) 
       Else 
          MsgBox ("Das Dokument ist bereits ohne eingebettete TT-Fonts gespeichert," & vbCr _ 
                  & "deshalb erfolgte kein zusätzliches Speichern.") 
       End If 
    End With 
End Sub