Hi all,

I am using the code below to run on events during a Word mailmerge. The code
splits to individual Word and PDF files, it works fine but I only need to
split the documents into individual PDF files then leave one single merged
Word document. Any help is appreciated.

Thanks.

Option Explicit
Public docMergeResult As Document
Public MainDoc As Document
Dim AppClass As New MergeApplication

Public Sub AutoExec()
Set AppClass.app = Word.Application
End Sub

Sub ActivateEvents()
Set AppClass.app = Word.Application
End Sub

Sub DeactivateEvents()
Set AppClass.app = Nothing
End Sub

Sub DeleteResultsDocument()
docMergeResult.Close wdDoNotSaveChanges
End Sub

Code in class module

Option Explicit
Public SettingsFile As String
Public WithEvents app As Word.Application
Public Flag As Boolean, Fieldnum As Long, FFName As String, FldrPath As
String, j As Long, n As Long, Fname As String, Fsname As String, fnames As
Variant, i As Long, k As Long

Private Sub app_MailMergeAfterMerge(ByVal Doc As Document, ByVal DocResult
As Document)
SettingsFile = Options.DefaultFilePath(wdDocumentsPath) &
"\Settings.txt"
Doc.Activate
Dim olds, news As Integer, hf As HeaderFooter, oe As Boolean
Dim MakePDF As Boolean
MakePDF = False
If System.PrivateProfileString(SettingsFile, "MacroSettings", "MakePDF")
= "True" Then
MakePDF = True
Dim printer As String
With Dialogs(wdDialogFilePrintSetup)
printer = .printer
.printer = "Adobe PDF"
.Execute
End With
End If
If Flag = True Then
fnames = Split(Fname, "#")
For i = 0 To UBound(fnames)
For j = i + 1 To UBound(fnames)
If fnames(i) = fnames(j) Then
If Right(Left(fnames(j), InStr(fnames(j), ".") - 1), 1)
= ")" Then
k = Val(Right(Left(fnames(j), InStr(fnames(j),
".") - 2), 1)) + 1
fnames(j) = Left(fnames(j), InStr(fnames(j), ".") -
4) & "(" & k & ").doc"
Else
fnames(j) = Left(fnames(j), InStr(fnames(j), ".") -
1) & "(1).doc"
End If
' MsgBox "The merge cannot be perfomed to separate
documents because" & vbCr & "the mergefield that you have selected to supply
the filenames" & vbCr & "contains identical information in two or more
records."
' Set docMergeResult = Documents(DocResult.Name)
' Application.OnTime Now, "DeleteResultsDocument"
' Application.ScreenUpdating = True
' Exit Sub
End If
Next j
Next i
If Doc.PageSetup.OddAndEvenPagesHeaderFooter = True Then
oe = True
End If
Dim NewDoc As Document, drange As Range, drange2 As Range
Set MainDoc = Documents(Doc.name)
For i = 0 To j - 1
Set drange = DocResult.Range
drange.End = DocResult.Sections(n).Range.End
Set NewDoc = Documents.Add(Visible:=False)
NewDoc.Range.FormattedText = drange.FormattedText
olds = NewDoc.Sections.Count - 1
news = NewDoc.Sections.Count
If oe = True Then
NewDoc.PageSetup.OddAndEvenPagesHeaderFooter = True
End If
If
NewDoc.Sections(olds).PageSetup.DifferentFirstPage HeaderFooter = True Then

NewDoc.Sections(news).PageSetup.DifferentFirstPage HeaderFooter = True
End If
If oe = True Then
NewDoc.PageSetup.OddAndEvenPagesHeaderFooter = True
End If
For Each hf In NewDoc.Sections(news).Headers
hf.LinkToPrevious = True
Next
For Each hf In NewDoc.Sections(news).Footers
hf.LinkToPrevious = True
Next
NewDoc.Sections(NewDoc.Sections.Count).PageSetup.S ectionStart =
wdSectionContinuous
NewDoc.Range.Fields.Update
NewDoc.SaveAs FldrPath & fnames(i)
If MakePDF = True Then
NewDoc.PrintOut Background:=False
End If
NewDoc.Close wdDoNotSaveChanges
Set NewDoc = Nothing
drange.Delete
Next i
Set docMergeResult = Documents(DocResult.name)
Application.OnTime Now, "DeleteResultsDocument"
Application.ScreenUpdating = True
If MakePDF = True Then
With Dialogs(wdDialogFilePrintSetup)
.printer = printer
.Execute
End With
End If
Else
DocResult.Activate
End If

End Sub

Private Sub app_MailMergeAfterRecordMerge(ByVal Doc As Document)
Dim MissingRecord As String
Dim Msg, Style, Title, Response
MissingRecord = ""
If Flag = True Then
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
k = 1
End If
With Doc.MailMerge.DataSource
Fsname = .DataFields(FFName).Value
If Trim(Fsname) = "" Then
For i = 1 To .DataFields.Count
MissingRecord = MissingRecord & .DataFields(i).name & " = "
& .DataFields(i).Value & vbCr
Next i
Msg = "There is no data in the field for filename for the record
containing " & vbCr & vbCr & MissingRecord & vbCr
Msg = Msg & "To enter a filename, click Yes. If you click No,
the document will be named NoNameNumber#"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "Missing Filename"
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
Fsname = InputBox("Enter the filename for the record
containing " & vbCr & vbCr & MissingRecord, "Enter the Filename")
If Trim(Fsname) = "" Then
Fsname = "NoNameNumber" & k
k = k + 1
End If
Else
Fsname = "NoNameNumber" & k
k = k + 1
End If
End If
If UCase(Right(Fsname, 4)) = ".DOC" Then
Fsname = Left(Fsname, Len(Fsname) - 4) & ".doc"
Else
Fsname = Fsname & ".doc"
End If
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
Fname = Fsname
j = 1
Else
Fname = Fname & "#" & Fsname
j = j + 1
End If
End With
End If
End Sub

Private Sub app_MailMergeBeforeRecordMerge(ByVal Doc As Document, Cancel As
Boolean)
SettingsFile = Options.DefaultFilePath(wdDocumentsPath) &
"\Settings.txt"
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
n = Doc.Sections.Count - 1
Flag = False
If Doc.MailMerge.Destination = 0 Then
Dim intVBAnswer As Integer
'Request whether the user wants to create a separate document
for each record.
intVBAnswer = MsgBox("Do you want to create a separate PDF
document for each record?", vbYesNo, "Merge to Document")
If intVBAnswer = vbYes Then
'Display a form containing the mergefields
'for the user to select the field containing the filenames.
Dim oform As frmShowMergeFields
Set oform = New frmShowMergeFields
Dim fld As Word.MailMergeDataField
For Each fld In Doc.MailMerge.DataSource.DataFields
oform.lstMergeFields.AddItem fld.name
Next fld
oform.txtFldrPath.Text =
System.PrivateProfileString(SettingsFile, "MacroSettings", "FldrPath")
oform.Show vbModal
If Trim(System.PrivateProfileString(SettingsFile,
"MacroSettings", "mmfilefield")) "" Then
FFName = System.PrivateProfileString(SettingsFile,
"MacroSettings", "mmfilefield")
Flag = True
Set oform = Nothing
FldrPath =
Trim(System.PrivateProfileString(SettingsFile, "MacroSettings", "FldrPath"))
'Else
'The user pressed Cancel in the Userform
'Flag = False
'Set oform = Nothing
'MsgBox "You have cancelled the process. The merge will
be executed to a single document."
'Exit Sub
End If
End If
End If
End If
End Sub

I haven't reviewed your code but think I can help.

You need to be doing two separate merges of the same document and data. The
first does your pdf files and splits things. The second is to a Word
document.
--
Charles Kenyon

Word New User FAQ & Web Directory: http://addbalance.com/word

Intermediate User's Guide to Microsoft Word (supplemented version of
Microsoft's Legal Users' Guide) http://addbalance.com/usersguide

See also the MVP FAQ: http://word.mvps.org/FAQs/ which is awesome!

My criminal defense site: http://addbalance.com
--------- --------- --------- --------- --------- ---------
This message is posted to a newsgroup. Please post replies
and questions to the newsgroup so that others can learn
from my ignorance and your wisdom.


"Martin" wrote in message
...
Hi all,

I am using the code below to run on events during a Word mailmerge. The
code
splits to individual Word and PDF files, it works fine but I only need to
split the documents into individual PDF files then leave one single merged
Word document. Any help is appreciated.

Thanks.

Option Explicit
Public docMergeResult As Document
Public MainDoc As Document
Dim AppClass As New MergeApplication

Public Sub AutoExec()
Set AppClass.app = Word.Application
End Sub

Sub ActivateEvents()
Set AppClass.app = Word.Application
End Sub

Sub DeactivateEvents()
Set AppClass.app = Nothing
End Sub

Sub DeleteResultsDocument()
docMergeResult.Close wdDoNotSaveChanges
End Sub

Code in class module

Option Explicit
Public SettingsFile As String
Public WithEvents app As Word.Application
Public Flag As Boolean, Fieldnum As Long, FFName As String, FldrPath As
String, j As Long, n As Long, Fname As String, Fsname As String, fnames As
Variant, i As Long, k As Long

Private Sub app_MailMergeAfterMerge(ByVal Doc As Document, ByVal DocResult
As Document)
SettingsFile = Options.DefaultFilePath(wdDocumentsPath) &
"\Settings.txt"
Doc.Activate
Dim olds, news As Integer, hf As HeaderFooter, oe As Boolean
Dim MakePDF As Boolean
MakePDF = False
If System.PrivateProfileString(SettingsFile, "MacroSettings",
"MakePDF")
= "True" Then
MakePDF = True
Dim printer As String
With Dialogs(wdDialogFilePrintSetup)
printer = .printer
.printer = "Adobe PDF"
.Execute
End With
End If
If Flag = True Then
fnames = Split(Fname, "#")
For i = 0 To UBound(fnames)
For j = i + 1 To UBound(fnames)
If fnames(i) = fnames(j) Then
If Right(Left(fnames(j), InStr(fnames(j), ".") - 1), 1)
= ")" Then
k = Val(Right(Left(fnames(j), InStr(fnames(j),
".") - 2), 1)) + 1
fnames(j) = Left(fnames(j), InStr(fnames(j), ".") -
4) & "(" & k & ").doc"
Else
fnames(j) = Left(fnames(j), InStr(fnames(j), ".") -
1) & "(1).doc"
End If
' MsgBox "The merge cannot be perfomed to separate
documents because" & vbCr & "the mergefield that you have selected to
supply
the filenames" & vbCr & "contains identical information in two or more
records."
' Set docMergeResult = Documents(DocResult.Name)
' Application.OnTime Now, "DeleteResultsDocument"
' Application.ScreenUpdating = True
' Exit Sub
End If
Next j
Next i
If Doc.PageSetup.OddAndEvenPagesHeaderFooter = True Then
oe = True
End If
Dim NewDoc As Document, drange As Range, drange2 As Range
Set MainDoc = Documents(Doc.name)
For i = 0 To j - 1
Set drange = DocResult.Range
drange.End = DocResult.Sections(n).Range.End
Set NewDoc = Documents.Add(Visible:=False)
NewDoc.Range.FormattedText = drange.FormattedText
olds = NewDoc.Sections.Count - 1
news = NewDoc.Sections.Count
If oe = True Then
NewDoc.PageSetup.OddAndEvenPagesHeaderFooter = True
End If
If
NewDoc.Sections(olds).PageSetup.DifferentFirstPage HeaderFooter = True Then

NewDoc.Sections(news).PageSetup.DifferentFirstPage HeaderFooter = True
End If
If oe = True Then
NewDoc.PageSetup.OddAndEvenPagesHeaderFooter = True
End If
For Each hf In NewDoc.Sections(news).Headers
hf.LinkToPrevious = True
Next
For Each hf In NewDoc.Sections(news).Footers
hf.LinkToPrevious = True
Next
NewDoc.Sections(NewDoc.Sections.Count).PageSetup.S ectionStart =
wdSectionContinuous
NewDoc.Range.Fields.Update
NewDoc.SaveAs FldrPath & fnames(i)
If MakePDF = True Then
NewDoc.PrintOut Background:=False
End If
NewDoc.Close wdDoNotSaveChanges
Set NewDoc = Nothing
drange.Delete
Next i
Set docMergeResult = Documents(DocResult.name)
Application.OnTime Now, "DeleteResultsDocument"
Application.ScreenUpdating = True
If MakePDF = True Then
With Dialogs(wdDialogFilePrintSetup)
.printer = printer
.Execute
End With
End If
Else
DocResult.Activate
End If

End Sub

Private Sub app_MailMergeAfterRecordMerge(ByVal Doc As Document)
Dim MissingRecord As String
Dim Msg, Style, Title, Response
MissingRecord = ""
If Flag = True Then
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
k = 1
End If
With Doc.MailMerge.DataSource
Fsname = .DataFields(FFName).Value
If Trim(Fsname) = "" Then
For i = 1 To .DataFields.Count
MissingRecord = MissingRecord & .DataFields(i).name & " = "
& .DataFields(i).Value & vbCr
Next i
Msg = "There is no data in the field for filename for the
record
containing " & vbCr & vbCr & MissingRecord & vbCr
Msg = Msg & "To enter a filename, click Yes. If you click No,
the document will be named NoNameNumber#"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "Missing Filename"
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
Fsname = InputBox("Enter the filename for the record
containing " & vbCr & vbCr & MissingRecord, "Enter the Filename")
If Trim(Fsname) = "" Then
Fsname = "NoNameNumber" & k
k = k + 1
End If
Else
Fsname = "NoNameNumber" & k
k = k + 1
End If
End If
If UCase(Right(Fsname, 4)) = ".DOC" Then
Fsname = Left(Fsname, Len(Fsname) - 4) & ".doc"
Else
Fsname = Fsname & ".doc"
End If
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
Fname = Fsname
j = 1
Else
Fname = Fname & "#" & Fsname
j = j + 1
End If
End With
End If
End Sub

Private Sub app_MailMergeBeforeRecordMerge(ByVal Doc As Document, Cancel
As
Boolean)
SettingsFile = Options.DefaultFilePath(wdDocumentsPath) &
"\Settings.txt"
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
n = Doc.Sections.Count - 1
Flag = False
If Doc.MailMerge.Destination = 0 Then
Dim intVBAnswer As Integer
'Request whether the user wants to create a separate document
for each record.
intVBAnswer = MsgBox("Do you want to create a separate PDF
document for each record?", vbYesNo, "Merge to Document")
If intVBAnswer = vbYes Then
'Display a form containing the mergefields
'for the user to select the field containing the filenames.
Dim oform As frmShowMergeFields
Set oform = New frmShowMergeFields
Dim fld As Word.MailMergeDataField
For Each fld In Doc.MailMerge.DataSource.DataFields
oform.lstMergeFields.AddItem fld.name
Next fld
oform.txtFldrPath.Text =
System.PrivateProfileString(SettingsFile, "MacroSettings", "FldrPath")
oform.Show vbModal
If Trim(System.PrivateProfileString(SettingsFile,
"MacroSettings", "mmfilefield")) "" Then
FFName = System.PrivateProfileString(SettingsFile,
"MacroSettings", "mmfilefield")
Flag = True
Set oform = Nothing
FldrPath =
Trim(System.PrivateProfileString(SettingsFile, "MacroSettings",
"FldrPath"))
'Else
'The user pressed Cancel in the Userform
'Flag = False
'Set oform = Nothing
'MsgBox "You have cancelled the process. The merge
will
be executed to a single document."
'Exit Sub
End If
End If
End If
End If
End Sub

See http://www.gmayor.com/individual_merge_letters.htm the add-in there will
merge to separate PDFs. A separate merge to a new document would create the
single merge document.

--

Graham Mayor - Word MVP

My web site www.gmayor.com
Word MVP web site http://word.mvps.org



Martin wrote:
Hi all,

I am using the code below to run on events during a Word mailmerge.
The code splits to individual Word and PDF files, it works fine but I
only need to split the documents into individual PDF files then leave
one single merged Word document. Any help is appreciated.

Thanks.

Option Explicit
Public docMergeResult As Document
Public MainDoc As Document
Dim AppClass As New MergeApplication

Public Sub AutoExec()
Set AppClass.app = Word.Application
End Sub

Sub ActivateEvents()
Set AppClass.app = Word.Application
End Sub

Sub DeactivateEvents()
Set AppClass.app = Nothing
End Sub

Sub DeleteResultsDocument()
docMergeResult.Close wdDoNotSaveChanges
End Sub

Code in class module

Option Explicit
Public SettingsFile As String
Public WithEvents app As Word.Application
Public Flag As Boolean, Fieldnum As Long, FFName As String, FldrPath
As String, j As Long, n As Long, Fname As String, Fsname As String,
fnames As Variant, i As Long, k As Long

Private Sub app_MailMergeAfterMerge(ByVal Doc As Document, ByVal
DocResult As Document)
SettingsFile = Options.DefaultFilePath(wdDocumentsPath) &
"\Settings.txt"
Doc.Activate
Dim olds, news As Integer, hf As HeaderFooter, oe As Boolean
Dim MakePDF As Boolean
MakePDF = False
If System.PrivateProfileString(SettingsFile, "MacroSettings",
"MakePDF") = "True" Then
MakePDF = True
Dim printer As String
With Dialogs(wdDialogFilePrintSetup)
printer = .printer
.printer = "Adobe PDF"
.Execute
End With
End If
If Flag = True Then
fnames = Split(Fname, "#")
For i = 0 To UBound(fnames)
For j = i + 1 To UBound(fnames)
If fnames(i) = fnames(j) Then
If Right(Left(fnames(j), InStr(fnames(j), ".") -
1), 1) = ")" Then
k = Val(Right(Left(fnames(j), InStr(fnames(j),
".") - 2), 1)) + 1
fnames(j) = Left(fnames(j), InStr(fnames(j),
".") - 4) & "(" & k & ").doc"
Else
fnames(j) = Left(fnames(j), InStr(fnames(j),
".") - 1) & "(1).doc"
End If
' MsgBox "The merge cannot be perfomed to separate
documents because" & vbCr & "the mergefield that you have selected to
supply the filenames" & vbCr & "contains identical information in two
or more records."
' Set docMergeResult = Documents(DocResult.Name)
' Application.OnTime Now, "DeleteResultsDocument"
' Application.ScreenUpdating = True
' Exit Sub
End If
Next j
Next i
If Doc.PageSetup.OddAndEvenPagesHeaderFooter = True Then
oe = True
End If
Dim NewDoc As Document, drange As Range, drange2 As Range
Set MainDoc = Documents(Doc.name)
For i = 0 To j - 1
Set drange = DocResult.Range
drange.End = DocResult.Sections(n).Range.End
Set NewDoc = Documents.Add(Visible:=False)
NewDoc.Range.FormattedText = drange.FormattedText
olds = NewDoc.Sections.Count - 1
news = NewDoc.Sections.Count
If oe = True Then
NewDoc.PageSetup.OddAndEvenPagesHeaderFooter = True
End If
If
NewDoc.Sections(olds).PageSetup.DifferentFirstPage HeaderFooter = True
Then

NewDoc.Sections(news).PageSetup.DifferentFirstPage HeaderFooter = True
End If
If oe = True Then
NewDoc.PageSetup.OddAndEvenPagesHeaderFooter = True
End If
For Each hf In NewDoc.Sections(news).Headers
hf.LinkToPrevious = True
Next
For Each hf In NewDoc.Sections(news).Footers
hf.LinkToPrevious = True
Next

NewDoc.Sections(NewDoc.Sections.Count).PageSetup.S ectionStart =
wdSectionContinuous NewDoc.Range.Fields.Update
NewDoc.SaveAs FldrPath & fnames(i)
If MakePDF = True Then
NewDoc.PrintOut Background:=False
End If
NewDoc.Close wdDoNotSaveChanges
Set NewDoc = Nothing
drange.Delete
Next i
Set docMergeResult = Documents(DocResult.name)
Application.OnTime Now, "DeleteResultsDocument"
Application.ScreenUpdating = True
If MakePDF = True Then
With Dialogs(wdDialogFilePrintSetup)
.printer = printer
.Execute
End With
End If
Else
DocResult.Activate
End If

End Sub

Private Sub app_MailMergeAfterRecordMerge(ByVal Doc As Document)
Dim MissingRecord As String
Dim Msg, Style, Title, Response
MissingRecord = ""
If Flag = True Then
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
k = 1
End If
With Doc.MailMerge.DataSource
Fsname = .DataFields(FFName).Value
If Trim(Fsname) = "" Then
For i = 1 To .DataFields.Count
MissingRecord = MissingRecord & .DataFields(i).name &
" = " & .DataFields(i).Value & vbCr
Next i
Msg = "There is no data in the field for filename for the
record containing " & vbCr & vbCr & MissingRecord & vbCr
Msg = Msg & "To enter a filename, click Yes. If you click
No, the document will be named NoNameNumber#"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "Missing Filename"
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
Fsname = InputBox("Enter the filename for the record
containing " & vbCr & vbCr & MissingRecord, "Enter the Filename")
If Trim(Fsname) = "" Then
Fsname = "NoNameNumber" & k
k = k + 1
End If
Else
Fsname = "NoNameNumber" & k
k = k + 1
End If
End If
If UCase(Right(Fsname, 4)) = ".DOC" Then
Fsname = Left(Fsname, Len(Fsname) - 4) & ".doc"
Else
Fsname = Fsname & ".doc"
End If
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
Fname = Fsname
j = 1
Else
Fname = Fname & "#" & Fsname
j = j + 1
End If
End With
End If
End Sub

Private Sub app_MailMergeBeforeRecordMerge(ByVal Doc As Document,
Cancel As Boolean)
SettingsFile = Options.DefaultFilePath(wdDocumentsPath) &
"\Settings.txt"
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
n = Doc.Sections.Count - 1
Flag = False
If Doc.MailMerge.Destination = 0 Then
Dim intVBAnswer As Integer
'Request whether the user wants to create a separate
document for each record.
intVBAnswer = MsgBox("Do you want to create a separate PDF
document for each record?", vbYesNo, "Merge to Document")
If intVBAnswer = vbYes Then
'Display a form containing the mergefields
'for the user to select the field containing the
filenames. Dim oform As frmShowMergeFields
Set oform = New frmShowMergeFields
Dim fld As Word.MailMergeDataField
For Each fld In Doc.MailMerge.DataSource.DataFields
oform.lstMergeFields.AddItem fld.name
Next fld
oform.txtFldrPath.Text =
System.PrivateProfileString(SettingsFile, "MacroSettings", "FldrPath")
oform.Show vbModal
If Trim(System.PrivateProfileString(SettingsFile,
"MacroSettings", "mmfilefield")) "" Then
FFName = System.PrivateProfileString(SettingsFile,
"MacroSettings", "mmfilefield")
Flag = True
Set oform = Nothing
FldrPath =
Trim(System.PrivateProfileString(SettingsFile, "MacroSettings",
"FldrPath")) 'Else
'The user pressed Cancel in the Userform
'Flag = False
'Set oform = Nothing
'MsgBox "You have cancelled the process. The
merge will be executed to a single document."
'Exit Sub
End If
End If
End If
End If
End Sub