J
j.nijkamp
Ive been using a macro to perform a mailmerge in wordxp. We're
planning to go to office 2007, so im testing that version at the
moment. However, the macro in word xp doesnt work for 2007, hope any1
can help me.
This is the macro
Sub SamenVoegen()
Dim fFieldText() As String
Dim iCount As Integer
Dim fField As FormField
Dim sWindowMain, sWindowMerge As String
With ActiveDocument
ChangeFileOpenDirectory "K:\Clienten"
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()
ActiveDocument.Protect Password:="", Noreset:=True, _
Type:=wdAllowOnlyFormFields
sWindowMerge = ActiveWindow.Caption
Windows(sWindowMain).Activate
doFindReplace iCount, fField, fFieldText()
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)
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 sDatum As String
Dim sBetreft As String
With ActiveDocument
If ActiveDocument.Bookmarks.Exists("Datum") Then
sDatum = ActiveDocument.FormFields("Datum").Result
With Dialogs(wdDialogFileSummaryInfo)
.Execute
End With
End If
End With
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
ChangeFileOpenDirectory "K:\Clienten"
With Dialogs(wdDialogFileSaveAs)
.Name = Format(Date, "yymmdd") & " - " & sBetreft
.Show
End With
End With
ActiveDocument.Close
End With
ActiveDocument.Close
End Sub
Thanks in advance,
Jasper
planning to go to office 2007, so im testing that version at the
moment. However, the macro in word xp doesnt work for 2007, hope any1
can help me.
This is the macro
Sub SamenVoegen()
Dim fFieldText() As String
Dim iCount As Integer
Dim fField As FormField
Dim sWindowMain, sWindowMerge As String
With ActiveDocument
ChangeFileOpenDirectory "K:\Clienten"
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()
ActiveDocument.Protect Password:="", Noreset:=True, _
Type:=wdAllowOnlyFormFields
sWindowMerge = ActiveWindow.Caption
Windows(sWindowMain).Activate
doFindReplace iCount, fField, fFieldText()
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)
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 sDatum As String
Dim sBetreft As String
With ActiveDocument
If ActiveDocument.Bookmarks.Exists("Datum") Then
sDatum = ActiveDocument.FormFields("Datum").Result
With Dialogs(wdDialogFileSummaryInfo)
.Execute
End With
End If
End With
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
ChangeFileOpenDirectory "K:\Clienten"
With Dialogs(wdDialogFileSaveAs)
.Name = Format(Date, "yymmdd") & " - " & sBetreft
.Show
End With
End With
ActiveDocument.Close
End With
ActiveDocument.Close
End Sub
Thanks in advance,
Jasper