Save to a specific location based on mailmergedatafields

[jasper.nijkamp]

Hey guys
Im in the following situation.

We are using a CRM application from where we can create a letter, fax
etc. (that is, the address, clientname etc. automaticly fills in, and
ive build a MailMerge macro to save the letter on a webdrive (the
content manager of the CRM application)

Because our users don’t have the right to change the Filelocations,
ive tried to creathe a macro that saved the document on a specific
directory based on MailMergeDatafields
Ive put a MsgBox in the macro to check if the Path is correct. This is
the case.
But when I get into the saveAs Box, im not in the right Path.

The macro I use is the following

Sub SamenVoegen()

Dim fFieldText() As String
Dim iCount As Integer
Dim fField As FormField
Dim sWindowMain, sWindowMerge As String
Dim sVestiging As String
Dim sClientgroep As String
Dim sClientnummer As String
Dim sKlantnaam As String
Dim sPath As String

sClientgroep =
ActiveDocument.MailMerge.DataSource.DataFields("Cliëntgroep").Value
sClientnummer =
ActiveDocument.MailMerge.DataSource.DataFields("Cliëntnummer").Value
sVestiging =
ActiveDocument.MailMerge.DataSource.DataFields("Vestiging").Value
sKlantnaam =
ActiveDocument.MailMerge.DataSource.DataFields("klantnaam").Value
sPath = "K:\Clienten\" & sVestiging & "\" & sClientgroep & "\" &
sClientnummer & " - " & sKlantnaam & "\" & "01 - Klantendossier" & "\"

MsgBox sPath

With ActiveDocument
ActiveDocument.SaveAs FileName:="U:\a.dot", FileFormat:=wdFormatDOT

On Error GoTo ErrHandler

sWindowMain = ActiveWindow.Caption
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect
End If

For Each afield In ActiveDocument.FormFields
If afield.Type = wdFieldFormTextInput Then
ReDim Preserve fFieldText(1, iCount + 1)
fFieldText(0, iCount) = afield.Result
fFieldText(1, iCount) = afield.Name
afield.Select
Selection.TypeText "<" & fFieldText(1, iCount) & "PlaceHolder>"
iCount = iCount + 1

End If

Next afield

ActiveDocument.MailMerge.Destination = wdSendToNewDocument
ActiveDocument.MailMerge.Execute

doFindReplace iCount, fField, fFieldText(), sPath

ActiveDocument.Protect Password:="", Noreset:=True, _
Type:=wdAllowOnlyFormFields

sWindowMerge = ActiveWindow.Caption

Windows(sWindowMain).Activate

doFindReplace iCount, fField, fFieldText(), sPath

ActiveDocument.Protect Password:="", Noreset:=True, _
Type:=wdAllowOnlyFormFields

Windows(sWindowMerge).Activate

ErrHandler:

End With
End Sub

Sub doFindReplace(iCount As Integer, fField As FormField, _
fFieldText() As String, sPath As String)

ActiveDocument.Close

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting

With Selection.Find
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

For i = 0 To iCount

Do While .Execute(FindText:="<" & fFieldText(1, i) _
& "PlaceHolder>") = True

Set fField = Selection.FormFields.Add _
(Range:=Selection.Range, Type:=wdFieldFormTextInput)

fField.Result = fFieldText(0, i)
fField.Name = fFieldText(1, i)
Loop

Selection.HomeKey Unit:=wdStory

Next
End With

With ActiveDocument
.Protect Type:=wdAllowOnlyFormFields, Noreset:=True, Password:=""

Dim sBetreft As String

With ActiveDocument
If ActiveDocument.Bookmarks.Exists("Betreft") Then
sBetreft = ActiveDocument.FormFields("Betreft").Result
With Dialogs(wdDialogFileSummaryInfo)
.Execute
End With
End If
End With

Dim ffItem As Word.FormField
Dim lngIndex As Long

With ActiveDocument
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect

For lngIndex = ActiveDocument.Content.FormFields.Count To 1 Step
-1

Set ffItem = ActiveDocument.Content.FormFields(lngIndex)
ffItem.Range.Text = ffItem.Result
Next
End If
End With

With ActiveDocument
.Protect Type:=wdAllowOnlyFormFields, Noreset:=True, Password:=""
End With

With ActiveDocument
With Dialogs(wdDialogFileSaveAs)
.Name = sPath & Format(Date, "yymmdd") & "_brf - " &
sBetreft
.Show
End With
End With

Application.Quit SaveChanges:=No

End With

End Sub

Can anybody help me on this one?

Thanks in advance,
Jasper Nijkamp