Printen naar meerdere bestanden: macro probleem plaatsing en naamgeving

[Bliss84]

Zoals door OcatFish gevraagd een nieuwe vraag voor mijn specifiek probleem .
Ik krijg zijn macro uit het topic 'printen naar meerdere bestanden vanuit 1 document' aan de praat om een doc te splitsen en naam te geven van de eerste regel maar heb 2 problemen:


- Hij plaatst hem in de map boven de door mij aangewezen map (in code hieronder heb ik mijn naam vervangen door xx) dus gewoon op mijn desktop en niet in de map 'one pager test' op de desktop
- In de naamgeving plaatst hij voor de naam die het moet zijn (eerste regel document) nog de mapnaam dus 'one pager test filiaal x' (waarbij 'filiaal x' de eigenlijke bestandsnaam zou moeten zijn).

Enig idee hoe ik dit kan oplossen aub?
Is eerste keer dat ik met macro's werk..

Hieronder de macro die ik gebruik (hopelijk heb ik het gebruik van de code tags goed gesnapt ;-))

 Sub Splitter()
 '------------------------------------------------------------------------------------------------------------------
 ' splitter Macro
 ' Macro created by Doug Robbins to save each letter created by a mailmerge as a separate file.
 '------------------------------------------------------------------------------------------------------------------
 Dim Letters As Integer, Counter As Integer
 Dim DocName As String, sRange As String
 Dim Pad As String, sNullen As String
 Dim aRange As Range

 DocName = "Brief "
 Pad = "C:\Users\xx.GROUP\Desktop\one pager test"

 Letters = ActiveDocument.Sections.Count
 Selection.HomeKey Unit:=wdStory
 Counter = 1

 While Counter < Letters
 ActiveDocument.Sections.First.Range.Cut
 Documents.Add
 Selection.Paste
 '-----------------------------------------------------------------------------
 'Naam samenstellen uit 1e alinea van tekst
 '-----------------------------------------------------------------------------
 Set aRange = ActiveDocument.Paragraphs(1).Range
 DocName = aRange.Text
 If Right(DocName, 1) = Chr(13) Or Right(DocName, 1) = Chr(10) Then
 DocName = Left(DocName, Len(DocName) - 1)
 End If
 '-----------------------------------------------------------------------------
 ActiveDocument.Sections(2).PageSetup.SectionStart = wdSectionContinuous
 ActiveDocument.SaveAs FileName:=Pad & DocName & ".doc", FileFormat:=wdFormatDocument, LockComments:=False, _
 Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
 EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, _
 SaveFormsData:=False, SaveAsAOCELetter:=False
 ActiveWindow.Close
 Counter = Counter + 1
 Wend

 End Sub

 

[OctaFish]

De reden dat je document niet goed wordt opgeslagen ligt vermoedelijk in het feit dat de samenstelling van pad+document niet goed is.
Je hebt 2 variabelen: Pad en Docname, en die moeten samen een correcte verwijzing vormen.
Nu heb je de code

ActiveDocument.SaveAs FileName:=Pad & DocName & ".doc"

en die combineert

Pad = "C:\Users\xx.GROUP\Desktop\one pager test"

met

 DocName = aRange.Text

In DocName staat dan bijvoorbeeld: "Groene Zeep Nederland", en dat levert dan samengevoegd deze tekst op: "C:\Users\xx.GROUP\Desktop\one pager testGroene Zeep Nederland".
Dat klopt natuurlijk niet. Dat moet zijn: "C:\Users\xx.GROUP\Desktop\one pager test\Groene Zeep Nederland"
Dat kun je ondervangen door een kleine aanpassing in de variabele Pad:

Pad = "C:\Users\xx.GROUP\Desktop\one pager test\"

En nu wordt de padnaam wél goed samengesteld.

Overigens heb je de padnaam nu hard ingeprogrammeerd, en dat kun je veel beter dynamisch maken als je met meerdere gebruikers wilt werken, want elke gebruiker heeft natuurlijk zijn eigen desktop. Ik heb de code daarom wat aangepast, en nu wordt de lokatie eerst aangemaakt als hij nog niet bestaat, en daarna wordt het bestand opgeslagen.

Sub Splitter()
'------------------------------------------------------------------------------------------------------------------
' splitter Macro
' Macro created by Doug Robbins to save each letter created by a mailmerge as a separate file.
' 20140102 Aangepast door OctaFish om documenten los op te slaan m.b.v. de naam in de 1e alinea.
' Macro gebruikt nu een functie om op te slaan in een aparte map op de desktop van de user.
'------------------------------------------------------------------------------------------------------------------
Dim Letters As Integer, Counter As Integer
Dim DocName As String, sRange As String, Pad As String
Dim aRange As Range

DocName = "Brief "
Pad = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\One Pager Test"
If CreateFolder(Pad) = False 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

Letters = ActiveDocument.Sections.Count
Selection.HomeKey Unit:=wdStory
Counter = 1

While Counter < Letters
    ActiveDocument.Sections.First.Range.Cut
    Documents.Add
    Selection.Paste
    '-----------------------------------------------------------------------------
    'Naam samenstellen uit 1e alinea van tekst
    '-----------------------------------------------------------------------------
    Set aRange = ActiveDocument.Paragraphs(1).Range
    DocName = aRange.text
    If Right(DocName, 1) = Chr(13) Or Right(DocName, 1) = Chr(10) Then
        DocName = Left(DocName, Len(DocName) - 1)
    End If
    '-----------------------------------------------------------------------------
    ActiveDocument.Sections(2).PageSetup.SectionStart = wdSectionContinuous
    ActiveDocument.SaveAs FileName:=Pad & DocName & ".docx", FileFormat:=wdFormatDocument, _
    Password:="", AddToRecentFiles:=True, WritePassword:="", EmbedTrueTypeFonts:=False, _
    SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
    ActiveWindow.Close
    Counter = Counter + 1
Wend

End Sub

Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")

Dim fs As Object
Dim FolderArray
Dim Folder As String, i As Integer, sShare As String

    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    'UNC pad ? Dan 3 "\" veranderen in 3 "@" tekens
    If sPath Like "\\*\*" Then
        sPath = Replace(sPath, "\", "@", 1, 3)
    End If
    FolderArray = Split(sPath, "\")
    'Na het splitsen de "@" tekens weer vervangen door "\" in item 0 van de array.
    FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
    On Error GoTo Hell
    'Door alle posities in de array lopen en de mapstring controleren en/of aanmaken.
    For i = 0 To UBound(FolderArray)
        Folder = Folder & FolderArray(i) & "\"
        If Not fs.FolderExists(Folder) Then
            fs.CreateFolder (Folder)
        End If
    Next
    'Het aanmaken van de map is gelukt; CreateFolder instellen op WAAR.
    CreateFolder = True

Hell:
End Function

 

[Bliss84]

Gewoon één '\' toevoegen deed het dus... Super bedankt (collega's verschoten van mijn vreugdekreet )! Nu die padnaam verander ik nog, het wordt een andere map sowieso, dit was maar om te testen.

 

[OctaFish]

Als je collega's zijn uitgejuicht (zal ondertussen toch wel?) mag je de vraag nog op <Opgelost> zetten

 

[Bliss84]

Zou ok moeten zijn , nogmaals bedankt!