samenvoef van word naar pdf

Status
Niet open voor verdere reacties.
R

Rudolf61

Nieuwe gebruiker
Lid geworden
31 mrt 2020
Berichten
2
het is mij middels deze code gelukt om een mailing afzonderlijk en met een unieke naam als verschillende pdf te bewaren.

Code: 
Sub SplitterPDF()
'------------------------------------------------------------------------------------------------------------------
' splitter Macro
' Created by snb, adapted by Octafish
'------------------------------------------------------------------------------------------------------------------
Dim DocName As String, Pad As String
Dim aDoc As Document, iT As Section

    If Dir(CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\Brieven\", vbDirectory) & "" = "" Then
        Pad = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\Brieven\"
        If CreateFolder(Pad) = "Mislukt" Then
            MsgBox "Het pad kon niet worden aangemaakt; check de gegevens."
            Exit Sub
        End If
    Else
        Pad = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\Brieven\"
    End If
    If Not Right(Pad, 1) = Application.PathSeparator Then Pad = Pad & Application.PathSeparator
    
    Set aDoc = ActiveDocument
    Selection.HomeKey Unit:=wdStory
    For Each iT In aDoc.Sections
        If iT.Index = aDoc.Sections.Last.Index Then Exit For
        '==========================================================================================================
        ' Variant met naam
        ''DocName = Replace(iT.Range.Paragraphs(4).Range.Text, vbCr, "")
        ''Select Case Left(DocName, 7)
        ''    Case Is = "mevrouw", "de heer"
        ''        DocName = Split(DocName, " ")(UBound(Split(DocName, " ")))
        ''End Select
        '----------------------------------------------------------------------------------------------------------
        ' Variant met rekeningnummer
        DocName = Replace(Replace(iT.Range.Paragraphs(1).Range.Text, vbCr, ""), Chr(12), "")
        '==========================================================================================================
        DocName = DocName & " Factuur, 2020 " & ".pdf"
        If iT.Index = aDoc.Sections.Last.Index Then Exit For
        aDoc.Range(iT.Range.Start, iT.Range.End - 1).ExportAsFixedFormat Pad & DocName, 17
    Next

End Sub


End Sub

waarvoor mijn hartelijk dank maar mijn word template bestaat uit een brief met een header met logo en een footer met adres. Het is een beetje raar dat ik dit in het word dacument wel zie maar als ik de macro uitvoer in de pdf'd die daar uit voort komen het logo en de adresdetails niet meer laat zien.

Iemand een suggestie
 
Kom ik toch weer terug bij mijn oorspronkelijke macro. Geen idee of dit werkt, want ik heb uiteraard geen zin om eerst een voorbeeld te maken dat werkt. Dus dat mag je zelf uitzoeken :)

Code: 
Sub Splitter_HF()
'------------------------------------------------------------------------------------------------------------------
' splitter Macro
' Macro created by Doug Robbins.
' 20140102 Aangepast door OctaFish.
'------------------------------------------------------------------------------------------------------------------
Dim Letters As Integer, Counter As Integer
Dim DocName As String, newDoc As Document, sRange As String, Pad As String
Dim aRange As Range

    DocName = "Brief "
    Pad = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\Brieven\"
    If CreateFolder(Pad) = "Mislukt" Then
        MsgBox "Het pad kon niet worden aangemaakt; check de gegevens."
        Exit Sub
    End If
    If Not Right(Pad, 1) = Application.PathSeparator Then Pad = Pad & Application.PathSeparator
    
    Set aDoc = ActiveDocument
    Letters = aDoc.Sections.Count
    Selection.HomeKey Unit:=wdStory
    Counter = 1
    
    While Counter < Letters
        aDoc.Sections.First.Range.Cut
        Set newDoc = Documents.Add
        Selection.Paste
        '-----------------------------------------------------------------------------
        'Naam samenstellen uit 1e alinea van tekst
        '-----------------------------------------------------------------------------
        Set aRange = aDoc.Paragraphs(1).Range
        DocName = Replace(Replace(aRange.Text, vbCr, ""), Chr(12), "")
        DocName = DocName & " Factuur, 2020 " & ".pdf"
        aDoc.Sections(1).Headers(1).Range.Copy
        newDoc.Sections(1).Headers(1).Range.Paste
        aDoc.Sections(1).Footers(1).Range.Copy
        newDoc.Sections(1).Footers(1).Range.Paste
        If Right(DocName, 1) = Chr(13) Or Right(DocName, 1) = Chr(10) Then
            DocName = Left(DocName, Len(DocName) - 1)
        End If
        '-----------------------------------------------------------------------------
        With newDoc
            .Sections(2).PageSetup.SectionStart = wdSectionContinuous
            ''.Convert
            .SaveAs FileName:=Pad & DocName & ".docx", FileFormat:=wdFormatDocumentDefault
            ActiveWindow.Close
            Counter = Counter + 1
        End With
    Wend

End Sub
 
Het verbaast mij niets, als je slechts gedeelten van een bestand als PDF opslaat dat dan andere delen daar niet bijzitten.
Ik vind de benadering van de macro ook niet erg slim.
Je kunt in Word de mailmerge per pagina laten plaatsvinden.
 
@octafisch, De macro die ik van je in mijn vraag had gepost werkt heel goed. Hij bewaard iedere brief van de mailing met het eerste veld uit de brief( klantnummer) van de mailing met vervolgens de tekst zoals die wordt bepaald in de macro. Het enige probleem is dat hij dus de header en footer niet meeneemt. Hierdoor wordt het de brief wordt zonder letterhead en voettekst.

@snb, ik kan de mailing ook splitsen met acrobat DC, maar dan voegt hij er alleen een nummer toe aan de brief waardoor ik deze niet meer herken, In het eerste voor beeld bestaat de naam uit een klantennummer gevolgd door de tekst.

Het gaat mij dus om het feit dat het briefhoofd en adresdetails niet worden meegenomen in de aparte pdf's terwijl dit wel in de word mailing staat.
 
rcmb zei:
Het gaat mij dus om het feit dat het briefhoofd en adresdetails niet worden meegenomen in de aparte pdf's terwijl dit wel in de word mailing staat.
Klik om te vergroten...
Ik snap dat je eerste macro prima werkt, maar dus niet voor de kop- en voettekst. En dat gaat-ie op deze manier dus ook nooit doen, omdat de opzet nu eenmaal uitgaat van een ander soort document (zonder kop- en voettekst). Daarom heb ik dus de oorspronkelijke macro aangepast, zodat ie het (hopelijk) wél doet. Tja, als jij daar niks mee wilt, dan ben ik natuurlijk ook uitgekakt. Gelukkig is er nog voor 10 jaar wc-papier :D.
 
Hij deed het recent nog wel, maar heb een nieuwe laptop. ik ga kijken wat ik met de macro kan bereiken. Hoop dat je wel hebt gehamsterd ...... 10 jaar ? :)
 
Beste Octafisch, ik heb je code gebruikt maar moest wel een regel weghalen omdat ik daar iedere keer een compileerfout in kreeg, wellicht zorgt die ook voor het probleem wat ik nu tegenkom.
De documenten worden nu wel met header en footer maar niet als pdf, maar als word document bewaard. Weliswaar met in de naam een extensie pdf. "211 Factuur, Q2 2020 .pdf"
Hij slaat de laatste brief op maar zonder het nummer in de eerste regel en als de macro klaar is, is de brief ook weg. Dit laatste vind ik niet zo jammer maar niet erg.
Ik kan het format van de brief ook niet krijgen zoals ik dat wil. Alleen als ik bij de hele mailing de indeling de "regelafstand na" voor op 0 zet, klopt het redelijk maar de brief bestaat dan toch nog wel uit 2 paginas. Terwijl de brief in word wel 1 pagina is.
Code: 
Sub Splitter_HF()
'------------------------------------------------------------------------------------------------------------------
' splitter Macro
' Macro created by Doug Robbins.
' 20140102 Aangepast door OctaFish.
'------------------------------------------------------------------------------------------------------------------
Dim Letters As Integer, Counter As Integer
Dim DocName As String, newDoc As Document, sRange As String, Pad As String
Dim aRange As Range

    DocName = "Brief "
    Pad = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\Brieven\"
    
    If Not Right(Pad, 1) = Application.PathSeparator Then Pad = Pad & Application.PathSeparator
    
    Set aDoc = ActiveDocument
    Letters = aDoc.Sections.Count
    Selection.HomeKey Unit:=wdStory
    Counter = 1
    
    While Counter < Letters
        aDoc.Sections.First.Range.Cut
        Set newDoc = Documents.Add
        Selection.Paste
        '-----------------------------------------------------------------------------
        'Naam samenstellen uit 1e alinea van tekst
        '-----------------------------------------------------------------------------
        Set aRange = aDoc.Paragraphs(1).Range
        DocName = Replace(Replace(aRange.Text, vbCr, ""), Chr(12), "")
        DocName = DocName & " Factuur, Q2 2020 " & ".pdf"
        aDoc.Sections(1).Headers(1).Range.Copy
        newDoc.Sections(1).Headers(1).Range.Paste
        aDoc.Sections(1).Footers(1).Range.Copy
        newDoc.Sections(1).Footers(1).Range.Paste
        If Right(DocName, 1) = Chr(13) Or Right(DocName, 1) = Chr(10) Then
            DocName = Left(DocName, Len(DocName) - 1)
        End If
        '-----------------------------------------------------------------------------
        With newDoc
            .Sections(2).PageSetup.SectionStart = wdSectionContinuous
            ''.Convert
            .SaveAs FileName:=Pad & DocName & ".docx", FileFormat:=wdFormatDocumentDefault
            ActiveWindow.Close
            Counter = Counter + 1
        End With
    Wend

End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan