Fehler in Makro zum Speichern von Teilen aus Worddatei als PDF

[RolandR88]

Hallo Leute,
ich habe eine Marko, die Teile aus meiner Word-Datei in separate *.PDF-Dateien speichert.
Der Dateiname wird immer aus dem Beginn der Abschnitte genommen, wo eine "ID" steht.
Zum Beispiel:
AbschnittsID:HeuteistSonntag
Ziel: Ein PDF mit allen Seiten bis zur nächsten ID mit Dateinamen "HeuteistSonntag.pdf"

Findet jemand den Fehler? Er findet den Suchstring im Dokument nicht... irgend ein Fehler und ich schaue wohl immer drüber.
Danke im Voraus!

Sub SpeichernAlsPDF()
Dim aktuellesDoc As Document
Set aktuellesDoc = ActiveDocument
Dim aktuelleSeite As Range
Set aktuelleSeite = Selection.Range
Dim suchString As String
suchString = "AbschnittsID:"
Dim startID As Integer
startID = InStr(aktuelleSeite, suchString)
If startID = 0 Then
MsgBox "ID nicht gefunden."
Exit Sub
End If
startID = startID + Len(suchString)
Dim endeID As Integer
endeID = InStr(startID, aktuelleSeite, " ")
If endeID = 0 Then
endeID = Len(aktuelleSeite) - startID + 1
Else
endeID = endeID - startID
End If
Dim idText As String
idText = Mid(aktuelleSeite, startID, endeID)
idText = Replace(idText, "/", "_") 'Optional: Entfernen aller Schrägstriche aus dem Dateinamen
Dim dateiName As String
dateiName = idText & ".pdf"
aktuelleSeite.ExportAsFixedFormat OutputFileName:=dateiName, ExportFormat:=wdExportFormatPDF
End Sub

 

[Daloop]

Wenn Du

Set aktuelleSeite = Selection.Range

durch

Set aktuelleSeite = aktuellesDoc.Range

ersetzt, sollte es funktionieren. Ansonsten müsstest Du den zu durchsuchenden Text erst markieren (Selection)."

 

[RolandR88]

Danke @Daloop das funktioniert, nun bekomme ich nur noch den Hinweis „Dateiname ungültig“. Meine IDs sind aber nur normale alphanumerische Strings mit 12 Zeichen.

 

[Daloop]

Sub SpeichernAlsPDF()
On Error GoTo Err

    marker = "AbschnittsID:"
    startpos = InStr(1, Range.Text, marker)
   
    Do While startpos > 0
   
        nextPos = InStr(startpos + 1, Range.Text, marker)
        If nextPos = 0 Then nextPos = Len(Range.Text)
       
        Dim rng As Range
        Set rng = Range(startpos - 1, nextPos - 1)
       
        fname = Range(rng.Start + Len(marker), rng.Start + Len(marker) + 11).Text & ".pdf"
        rng.ExportAsFixedFormat OutputFileName:=fname, ExportFormat:=wdExportFormatPDF
       
        startpos = InStr(startpos + 1, Range.Text, marker)
    Loop
   
Err:
If Err > 0 Then
    MsgBox "Fehler " & Err.Number & vbCrLf & Err.Description
End If
End Sub

 

[RolandR88]

Danke Vielmals, aber ich bekomme nur "Fehler 424 - Objekt erforderlich"
Der Beginn jedes neuen Abschnittes ist genau so wie im Code definiert

AbschnittsID:A0035923068ZZZ8534

 

[Daloop]

Du hast die Sub in ein Modul kopiert, oder? Und die IDs sind auch immer 18 Zeichen lang und nicht 12? Dann muss der Code folgendermaßen aussehen:

Sub SpeichernAlsPDF()
On Error GoTo Err
  
    Dim doc As Document
    Set doc = ActiveDocument
  
    marker = "AbschnittsID:"
    startpos = InStr(1, doc.Range.Text, marker)
  
    Do
        nextPos = InStr(startpos + 1, doc.Range.Text, marker)
        If nextPos = 0 Then nextPos = Len(doc.Range.Text)
      
        Dim rng As Range
        Set rng = doc.Range(startpos - 1, nextPos - 1)
      
        fname = doc.Range(rng.Start + Len(marker), rng.Start + Len(marker) + 18).Text & ".pdf"
        rng.ExportAsFixedFormat OutputFileName:=fname, ExportFormat:=wdExportFormatPDF
      
        startpos = InStr(startpos + 1, doc.Range.Text, marker)
    Loop While startpos > 0
  
Err:
If Err > 0 Then
    MsgBox "Fehler " & Err.Number & vbCrLf & Err.Description
End If
End Sub

Den Pfad zum Speichern der PDFs kannst Du sicher selbst anpassen, sonst landen die Dateien unter Eigene Dateien/Dokumente.

 

[RolandR88]

Danke @Daloop Jetzt funktioniert die Makro (wieder) wobei du in Wahrheit eine Neue für mich geschrieben hast. Tausend Dank (: