word Adres mektup birleştirme ile üretilen sayfaları tek tek pdf yapma

[expercions]

merhaba, yardımcı olursanız cok sevinirim. adres mektup birleştirmeden ürettiğim 110 sayfalık word belgesini pdf olarak tek tek kaydetmek istiyorum. ancak her sayfanın 2. satırı isimler var. bu isimleride dosya ismi olarak vermek istiyorum. ...

isimleri alamadan işlemi şu şekilde yapabiliyorum =>

**************************
Sub SaveAsSeparatePDFs()
'Updated by Extendoffice 20180906
Dim I As Long
Dim xStr As String
Dim xPathStr As Variant
Dim xDictoryStr As String
Dim xFileDlg As FileDialog
Dim xStartPage, xEndPage As Long
Dim xStartPageStr, xEndPageStr As String
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show <> -1 Then
MsgBox "Please chose a valid directory", vbInformation, "Kutools for Word"
Exit Sub
End If
xPathStr = xFileDlg.SelectedItems(1)
xStartPageStr = InputBox("Begin saving PDFs starting with page __? " & vbNewLine & "(ex: 1)", "Kutools for Word")
xEndPageStr = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 7)", "Kutools for Word")
If Not (IsNumeric(xStartPageStr) And IsNumeric(xEndPageStr)) Then
MsgBox "The enterng start page and end page should be number format", vbInformation, "Kutools for Word"
Exit Sub
End If
xStartPage = CInt(xStartPageStr)
xEndPage = CInt(xEndPageStr)
If xStartPage > xEndPage Then
MsgBox "The start page number can't be larger than end page", vbInformation, "Kutools for Word"
Exit Sub
End If
If xEndPage > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Then
xEndPage = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
End If
For I = xStartPage To xEndPage
ActiveDocument.ExportAsFixedFormat xPathStr & "\Page_" & I & ".pdf", _
wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportFromTo, I, I, wdExportDocumentWithMarkup, _
False, False, wdExportCreateHeadingBookmarks, True, False, False
Next
End Sub

 

[muhasebeciyiz]

Her PDF dosyasına o sayfanın 2. satırındaki ismi vermek istiyorsanız, her sayfayı geçici bir belgeye kopyalayıp o sayfanın içeriğinden ismi almanız gerekir.

Sub SavePagesAsPDFWithNames()
    Dim I As Long
    Dim xPathStr As String
    Dim xFileDlg As FileDialog
    Dim xStartPage As Long, xEndPage As Long
    Dim tempDoc As Document
    Dim pageRange As Range
    Dim fileName As String
    Dim paraText As String
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    If xFileDlg.Show <> -1 Then
        MsgBox "Lütfen geçerli bir klasör seçin.", vbInformation
        Exit Sub
    End If
    xPathStr = xFileDlg.SelectedItems(1)
  
    xStartPage = Val(InputBox("Başlangıç sayfa numarası:", "Sayfa Aralığı"))
    xEndPage = Val(InputBox("Bitiş sayfa numarası:", "Sayfa Aralığı"))

    If xStartPage < 1 Or xEndPage < xStartPage Then
        MsgBox "Geçerli bir sayfa aralığı girin.", vbExclamation
        Exit Sub
    End If
    
    For I = xStartPage To xEndPage
        Set tempDoc = Documents.Add
        ActiveDocument.Bookmarks("\Page").Range.Copy
        tempDoc.Content.Paste
        
        If tempDoc.Paragraphs.Count >= 2 Then
            paraText = Trim(tempDoc.Paragraphs(2).Range.Text)
            fileName = Replace(paraText, vbCr, "")
            fileName = Replace(fileName, "\", "-")
            fileName = Replace(fileName, "/", "-")
        Else
            fileName = "Page_" & I
        End If
        
        tempDoc.ExportAsFixedFormat OutputFileName:=xPathStr & "\" & fileName & ".pdf", _
            ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
            OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
            Item:=wdExportDocumentContent, IncludeDocProps:=True, _
            KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, _
            DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False

        tempDoc.Close SaveChanges:=False
    Next I

    MsgBox "İşlem tamamlandı!", vbInformation
End Sub

Her sayfa için geçici bir belge oluşturuluyor.

1. paragraf (genellikle 2. satır) alınarak dosya adı olarak kullanılıyor.

Geçersiz dosya adı karakterleri temizleniyor (\, /, vb.).
PDF dosyaları seçilen klasöre kaydediliyor.
Deneyiniz