Mecro voor verzendlijsten

Sub Verzendlijst()
'
' Verzendlijst Macro
'
'
Naam = InputBox("Bestandsnaam? ", "Naam")
    Application.Move Left:=1420, Top:=41
    Application.Resize Width:=1145, Height:=985
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
            .LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
        End With
        .Execute Pause:=False
    End With
    ChangeFileOpenDirectory _
        "C:\Users\Gebruiker\Google Drive\Safe Construct\SC Werven\21000"
    ActiveDocument.SaveAs2 FileName:=Naam, FileFormat:= _
        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False, CompatibilityMode:=15
End Sub

Sub Verzendlijst()
Dim Naam As String, Map As String
    Map = ZoekMap("C:\Users\Gebruiker\Google Drive\Safe Construct\SC Werven\21000\")
    With ActiveDocument.MailMerge
        With .DataSource
            .FirstRecord = .ActiveRecord
            .LastRecord = .ActiveRecord
            Naam = .DataFields("FAC").Value & ".docx"
        End With
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        .Execute Pause:=False
        ActiveDocument.SaveAs2 FileName:=Map & "\" & Naam, FileFormat:=wdFormatXMLDocument, CompatibilityMode:=15
    End With
End Sub

Private Function ZoekMap(Optional Startmap As String) As String
'*********************************************************************************
' Early binding: Microsoft Office 11.0 Object Library of later
Dim fDialog As Office.FileDialog
'*********************************************************************************
' Late binding: gebruik objecten
''Dim fDialog As Object
'*********************************************************************************
Dim varFile As Variant
Dim i As Integer

    '******************************************************************************
    'Opzetten File Dialog met Early Binding.
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    '******************************************************************************
    'Opzetten File Dialog met Late Binding.
    'Set fDialog = Application.FileDialog(4)
    '******************************************************************************
    With fDialog
        '**************************************************************************
        'Pas dit aan voor map met afbeeldingen
        .InitialFileName = IIf(Startmap = "", ActiveDocument.Path & "\", Startmap)
        '**************************************************************************
        .AllowMultiSelect = False
        .Title = "Kies een map.."
        '**************************************************************************
        'Toon het scherm, als methode False teruggeeft is er geen map gekozen.
        '**************************************************************************
        If .Show = True Then
            ZoekMap = .SelectedItems(1)
        Else
            ZoekMap = "Geen map geselecteerd."
        End If
    End With
End Function