Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.word.mailmerge.fields
|
|||
|
|||
Word mailmerge to PDF macro
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 |
#2
Posted to microsoft.public.word.mailmerge.fields
|
|||
|
|||
Word mailmerge to PDF macro
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 |
#3
Posted to microsoft.public.word.mailmerge.fields
|
|||
|
|||
Word mailmerge to PDF macro
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 |
Reply |
Thread Tools | |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Word should allow to 'divide' page by 3 or 4, not just 2 | Page Layout | |||
How can Word display full path of a file in the title bar? | Microsoft Word Help | |||
Does Word have a QuickCorrect/Quick Word option like WordPerfect? | New Users | |||
In Word, how do I surpress headers and footers on page 2 | Microsoft Word Help | |||
Macros - Keyboard Commands | Microsoft Word Help |