I Have been using a VBA code to individually save all letters separately from a mail merge into a designated folder. It has always worked previously howver with the document I am trying to do it for now it is onyl saving the first document and then coming up with an error stating:
run-time error '5825' object has been deleted
When I go to debug it highlights the line near the bottom reading 'DocResult.Close False'
How can I fix this?
Tried changing this to True or deleting line entirely but does not fix problem. Each document is quite large so takes approx 30 seconds to save
Dim WithEvents wdapp As Application
Dim bCustomProcessing As Boolean
Private Sub Document_Open()
Set wdapp = Application
bCustomProcessing = False
ThisDocument.MailMerge.DataSource.ActiveRecord = 1
ThisDocument.MailMerge.ShowWizard 1
With ActiveDocument.MailMerge
If .MainDocumentType = wdFormLetters Then
.ShowSendToCustom = "Custom Letter Processing"
End If
End With
End Sub
Private Sub wdapp_MailMergeWizardSendToCustom(ByVal Doc As Document)
bCustomProcessing = True
Doc.MailMerge.Destination = wdSendToNewDocument
With Doc.MailMerge
For rec = 1 To .DataSource.RecordCount
.DataSource.ActiveRecord = rec
.DataSource.FirstRecord = rec
.DataSource.LastRecord = rec
.Execute
Next
End With
MsgBox "Merge Finished"
End Sub
Private Sub wdapp_MailMergeAfterMerge(ByVal Doc As Document, ByVal DocResult As Document)
If bCustomProcessing = True Then
With Doc.MailMerge.DataSource.DataFields
sFirmFileName = .Item(44).Value ' First Column of the data - CHANGE
End With
DocResult.SaveAs "xxx\" & sFirmFileName & ".doc", wdFormatDocument
' Path and File Name to save. can use other formats like wdFormatPDF too
DocResult.Close False
End If
End Sub
You have to set your object as nothing like this :
Set DocResult = nothing
Related
I made a collection which stores multiple instances of a report being opened with different filters.
If I try to close the most recently opened report, it is removed from the collection but does not close.
All other reports are both removed from the collection and closed.
How can I close the last report?
Private Sub CloseButton_Click()
Dim i As Integer
Dim rptcol As New collection
Set rptcol = ReportCollectionModule.rptCollection
For i = 1 To rptcol.Count
If Me.Hwnd = rptcol.Item(i).Hwnd Then
Exit For
End If
Next
DoCmd.Close acReport, rptcol.Item(i).Caption, acSaveNo
rptcol.Remove i
Set ReportCollectionModule.rptCollection = rptcol
End Sub
The ReportCollectionModule is a basic setter and getter.
Option Compare Database
Private myRptCollection As New collection
Public Property Get rptCollection() As collection
Set rptCollection = myRptCollection
End Property
Public Property Set rptCollection(thiscollection As collection)
Set myRptCollection = thiscollection
End Property
The reports are added to the collection as follows:
Private Sub ID_Click()
Dim rpt As Report
Dim rptcol As New collection
Set rptcol = ReportCollectionModule.rptCollection
Set rpt = New Report_ProductTable
rpt.RecordSource = "Product Table"
rpt.Filter = "[ID]= " & Me![ID]
rpt.Visible = True
rpt.Caption = DLookup("[ProductName]", "Product Table", "[ID] = " & Me![ID])
rpt.Requery
rptcol.Add rpt, CStr(rpt.Hwnd)
Set ReportCollectionModule.rptCollection = rptcol
Product_Name.SetFocus
ID.Visible = False
End Sub
The line DoCmd.Close acReport, rptcol.Item(i).Caption, acSaveNo will probably not work as you intented because the Docmd.Close object, objectName will close the object by it's name not by it's caption/title.
If you close the report by it's Name using docmd.close object, object name, the first instance that Access can find in the memory is closed until no more to close.
ReportCollectionModule.rptCollection.Remove report.Hwnd should close the instance you specify. Please post how you are managing/adding forms, you may have a flaw there.
Instead of using a class, make rptCollection as a public object/dictionary and just use rptCollection.remove hwnd
This is what I am using. It closes all forms but the one which it is calling from:
Private Sub CloseAllForms()
Dim lngLoop As Long
On Error Resume Next
For lngLoop = (Forms.Count - 1) To 1 Step -1
If Me.Name <> Forms(lngLoop).Name Then
DoCmd.Close acForm, Forms(lngLoop).Name
End If
Next lngLoop
End Sub
You can do the same for reports:
Private Sub CloseAllReports()
Dim lngLoop As Long
On Error Resume Next
For lngLoop = (Reports.Count - 1) To 1 Step -1
If Me.Name <> Reports(lngLoop).Name Then
DoCmd.Close acReport, Reports(lngLoop).Name
End If
Next lngLoop
End Sub
I'm brand spanking new to VBA. But I've programmed a bit in SAS, just a bit in Assembler (mainframe and PC), Word Perfect (macros), a bit in Java, HTML, other stuff. What I do is, when I have a problem and I think I can program it, I look for code on the internet and adjust it to fit my needs. I have read a little bit of VBA programming. What I'm trying to do is make a macro to save a bunch of Outlook e-mail messages with PDFMAKER. I've come up with the below, so far. When I step the program, pmkr2 gets assigned type "ObjectPDFMaker" and stng gets assigned type "ISettings". So far, so good. Then I try to set stng and can't do it. I get the error "Method or data member not found." If I get rid of Set it highlights .ISettings and I get the same error. I go into F2 and the AdobePDFMakerforOffice library is there, and the class ISettings is there, but I can't seem to set stng. I'm wa-a-a-ay frustrated. Please help.
Sub ConvertToPDFWithLinks()
Dim pmkr2 As Object
Set pmkr2 = Application.COMAddIns.Item(6).Object ' Assign object reference.
Dim pdfname As String
pdfname = "C:\stuff\stuff\tester.pdf"
Dim stng As AdobePDFMakerForOffice.ISettings
Set stng = AdobePDFMakerForOffice.ISettings
stng.AddBookmarks = True
stng.AddLinks = True
stng.AddTags = True
stng.ConvertAllPages = True
stng.CreateFootnoteLinks = True
stng.CreateXrefLinks = True
stng.OutputPDFFileName = pdfname
stng.PromptForPDFFilename = False
stng.ShouldShowProgressDialog = True
stng.ViewPDFFile = False
pmkr.GetCurrentConversionSettings stng
pmkr2.CreatePDFEx stng, 0
Set pmkr2 = Nothing ' Discontinue association.
End Sub
I updated your code a little. See if this has any affect:
Sub ConvertToPDFWithLinks()
Dim pmkr2 As AdobePDFMakerForOffice.PDFMaker
'Set pmkr2 = Application.COMAddIns.Item(6).Object ' Assign object reference.
Set pmkr2 = Nothing
For Each a In Application.COMAddIns
If InStr(UCase(a.Description), "PDFMAKER") > 0 Then
Set pmkr2 = a.Object
Exit For
End If
Next
If pmkr2 Is Nothing Then
MsgBox "Cannot Find PDFMaker add-in", vbOKOnly, ""
Exit Sub
End If
Dim pdfname As String
pdfname = "C:\stuff\stuff\tester.pdf"
Dim stng As AdobePDFMakerForOffice.ISettings
pmkr2.GetCurrentConversionSettings stng
stng.AddBookmarks = True
stng.AddLinks = True
stng.AddTags = True
stng.ConvertAllPages = True
stng.CreateFootnoteLinks = True
stng.CreateXrefLinks = True
stng.OutputPDFFileName = pdfname
stng.PromptForPDFFilename = False
stng.ShouldShowProgressDialog = True
stng.ViewPDFFile = False
pmkr2.CreatePDFEx stng, 0
Set pmkr2 = Nothing ' Discontinue association.
End Sub
The main changes were in how the addin is obtained and in how stng is created.
I have a problem very similar to this
However the answer there is not very clear, and I tried recreating the commandbutton in question, and it did not work.
Basically I have various sections within the template and for each section I have two buttons
[Add sub-section] - (CommandButton1, CommandButton11, CommandButton111)
[Done] - (CommandButton2, CommandButton21, CommandButton211)
Everything works fine in the template.
But if I create a new doc by either double clicking on the dotm or right clicking->new and then try using the buttons, they all run well, until I try one of the [Done] buttons. At the first attempt it works, post which no code works what so ever. Here's the code
Private Sub CommandButton1_Click()
Dim objTemplate As Template
Dim objBB As BuildingBlock
' Set the template to store the building block
Set objTemplate = ActiveDocument.AttachedTemplate
' Access the building block through the type and category
Set objBB = objTemplate.BuildingBlockTypes(wdTypeCustom5) _
.Categories("General").BuildingBlocks("Experience")
' Insert the building block into the document replacing any selected text.
Selection.MoveUp Unit:=wdLine, Count:=1
objBB.Insert Selection.Range
End Sub
Private Sub CommandButton11_Click()
Dim objTemplate As Template
Dim objBB As BuildingBlock
' Set the template to store the building block
Set objTemplate = ActiveDocument.AttachedTemplate
' Access the building block through the type and category
Set objBB = objTemplate.BuildingBlockTypes(wdTypeCustom5) _
.Categories("General").BuildingBlocks("Experience")
' Insert the building block into the document replacing any selected text.
Selection.MoveUp Unit:=wdLine, Count:=1
objBB.Insert Selection.Range
End Sub
Private Sub CommandButton111_Click()
Dim objTemplate As Template
Dim objBB As BuildingBlock
' Set the template to store the building block
Set objTemplate = ActiveDocument.AttachedTemplate
' Access the building block through the type and category
Set objBB = objTemplate.BuildingBlockTypes(wdTypeCustom5) _
.Categories("General").BuildingBlocks("Education")
' Insert the building block into the document replacing any selected text.
Selection.MoveUp Unit:=wdLine, Count:=1
objBB.Insert Selection.Range
End Sub
Private Sub CommandButton2_Click()
On Error Resume Next
Err.Clear
Dim i As Integer
i = ActiveDocument.InlineShapes.Count
Do While (i > 0)
If ActiveDocument.InlineShapes(i).OLEFormat.ClassType = "Forms.CommandButton.1" Then
If ActiveDocument.InlineShapes(i).OLEFormat.Object.Name = "CommandButton1" _
Or ActiveDocument.InlineShapes(i).OLEFormat.Object.Name = "CommandButton2" Then
If Err.Number = 0 Then
ActiveDocument.InlineShapes(i).Delete
End If
Err.Clear
End If
End If
i = i - 1
Loop
End Sub
Private Sub CommandButton21_Click()
On Error Resume Next
Err.Clear
Dim i As Integer
i = ActiveDocument.InlineShapes.Count
Do While (i > 0)
If ActiveDocument.InlineShapes(i).OLEFormat.ClassType = "Forms.CommandButton.1" Then
If ActiveDocument.InlineShapes(i).OLEFormat.Object.Name = "CommandButton11" _
Or ActiveDocument.InlineShapes(i).OLEFormat.Object.Name = "CommandButton21" Then
If Err.Number = 0 Then
ActiveDocument.InlineShapes(i).Delete
End If
Err.Clear
End If
End If
i = i - 1
Loop
End Sub
Private Sub CommandButton211_Click()
On Error Resume Next
Err.Clear
Dim i As Integer
i = ActiveDocument.InlineShapes.Count
Do While (i > 0)
If ActiveDocument.InlineShapes(i).OLEFormat.ClassType = "Forms.CommandButton.1" Then
If ActiveDocument.InlineShapes(i).OLEFormat.Object.Name = "CommandButton111" _
Or ActiveDocument.InlineShapes(i).OLEFormat.Object.Name = "CommandButton211" Then
If Err.Number = 0 Then
ActiveDocument.InlineShapes(i).Delete
End If
Err.Clear
End If
End If
i = i - 1
Loop
I'm new to VBA and built this by putting together various snippets from various sources ( I know it may not be all that neat, but had to start somewhere). The [Done] code (commandbutton2,21,211) came from this question I had asked earlier, just to give you some context.
In the editor I have three projects
Normal
Microsoft Word Objects
ThisDocument - [Empty]
Document1
Microsoft Word Objects
ThisDocument - [Empty]
References
Reference to Template Project
Template
Microsoft Word Objects
ThisDocument - [Got all the code]
I tried manually copying all of the code in "template" project into the "document1" project and then saving it as a docm. This fixed the problem, however I can't settle for this as [Add sub-section] basically adds a building block stored in the original template(which wont be available if I were to mail the docm to someone).
I'm open to any solution as long as at the end of it I have a file that can be mailed to someone and they could add sections at the click of a button
When using On Error Resume Next to manage an anticipated problem it's best to limit its scope as much as possible, or you run the risk of masking other errors in your code.
For example, you can remove it from your posted code by creating an "IsButton()" function something like this:
Function Isbutton(s) As Boolean
Dim f As String
On Error Resume Next
f = s.OLEFormat.ClassType
On Error GoTo 0
Isbutton = (f = "Forms.CommandButton.1")
End Function
Factoring out the repeated code it reduces to something like this:
Private Sub CommandButton1_Click()
InsertSection
End Sub
Private Sub CommandButton11_Click()
InsertSection
End Sub
Private Sub CommandButton111_Click()
InsertSection
End Sub
Sub InsertSection()
Dim objTemplate As Template
Dim objBB As BuildingBlock
Set objTemplate = ActiveDocument.AttachedTemplate
Set objBB = objTemplate.BuildingBlockTypes(wdTypeCustom5) _
.Categories("General").BuildingBlocks("Experience")
Selection.MoveUp Unit:=wdLine, Count:=1
objBB.Insert Selection.Range
End Sub
Private Sub CommandButton2_Click()
DeleteButtons "CommandButton1", "CommandButton2"
End Sub
Private Sub CommandButton21_Click()
DeleteButtons "CommandButton11", "CommandButton21"
End Sub
Private Sub CommandButton211_Click()
DeleteButtons "CommandButton111", "CommandButton211"
End Sub
Private Sub DeleteButtons(Name1 As String, Name2 As String)
Dim i As Integer, s As InlineShape, nm As String
i = ActiveDocument.InlineShapes.Count
Do While (i > 0)
Set s = ActiveDocument.InlineShapes(i)
If Isbutton(s) Then
nm = s.OLEFormat.Object.Name
Debug.Print i, nm '<<<EDIT
If nm = Name1 Or nm = Name2 Then s.Delete
End If
i = i - 1
Loop
End Sub
I am generating a set of labels using Word 2007, controlled via VBA from IBM Notes.
The document generates fine but after the generation the Tabs, ribbons and Menus are not responsive. I can click in the generated document but clicking on any of the top controls has no effect (icons do not press in, etc).
As a workaround I can click on another window, fiddle there, and then the ribbon for that particular document reacts. I am assuming that it has something to do with a focus problem.
After the code is finished, I am setting the Word Application.Visible to True, ScreenUpdating to True. I am calling a 'Close' to close all open files, but still, it's to no avail.
The code is being called by an IBM Notes Database in Lotusscript.
Have you encountered this before? It's very puzzling, and a no-go for my customers.
Andrew
Main Function:
Dim p As New LabelSourceFile
Call p.GenerateFileForSelectedDocuments()
Call p.ExtractWordTemplateFromConfig()
Dim w As New WordExport
w.setSelectedTemplateFullFile(p.FilePathToTemplate)
Print "file path to template: " + p.FilePathToTemplate
Call w.InitializeWordDocument()
Dim finaldoc As Variant
set finaldoc = w.MailMergeWithThisFile(p.getDataFileStreamFileName())
Call w.ReplaceCRWithCarriageReturns(finaldoc)
finaldoc.Activate 'gives focus back to document I've just generated
Set finaldoc = Nothing
'p.DeleteVorlage
'Kill p.FilePathToDataFile
Call w.ReleaseToUser()
This function initializes my document:
Public Function InitializeWordDocument As Integer
'Initialize a Word Document Object
' If m_strSelectedTemplateFullFile = "" an empty document is created
InitializeWordDocument = False
'On Error Goto ErrorHdl
m_objWordApplication.DisplayAlerts = wdAlertsnone
If Not m_objWordApplication Is Nothing Then
If m_strSelectedTemplateFullFile <> "" Then
Set m_objWordDoc = m_objWordApplication.Documents.Add( m_strSelectedTemplateFullFile )
InitializeWordDocument = True
Else
Set m_objWordDoc = m_objWordApplication.Documents.Add()
End If
Set m_objCurrentRange = m_objWordDoc.Range(0,0)
End If
m_objWordApplication.DisplayAlerts = wdAlertsAll
Exit Function
ErrorHdl:
InitializeWordDocument = False
Exit Function
End Function
This function is actually doing the merging:
'/*************************************************************************************
' * Function MailMergeWithThisFile
' * #param datafilename the data file
' * #return the final merged word document
' * #author Andrew Magerman/Magerman/NotesNet
' * #version Dec 18, 2013
' *************************************************************************************/
Function MailMergeWithThisFile (datafilename As String) As variant
On Error GoTo ErrorHandler
'If I don't block the popups, there is an annoying pop-up that appears.
m_objWordApplication.DisplayAlerts = wdAlertsnone
With me.m_objWordDoc.MailMerge
.MainDocumentType = wdFormLetters
Call .OpenDataSource(datafilename, wdOpenFormatText, false)
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute(False)
End With
'I need to set this here, immediately after the generation of the destination, merged document because the later
'actions of closing change the active document.
Set MailMergeWithThisFile = m_objWordApplication.ActiveDocument
Call m_objWordDoc.Close(False)
m_objWordApplication.DisplayAlerts = wdAlertsAll
Exit Function
ErrorHandler:
Call logError
Exit Function
End Function
By brainlessly commenting out lines until I got an answer, here is my workaround:
Always create a new instance (CreateObject) and forget about the GetObject.
If anyone has a good explanation for this, I'd be happy to hear it. For the moment I am just going to use the workaround.
'Initialize the Word Object
Set m_objWordApplication = Nothing
'I create always a new Word instance because that avoids me having focus issues.
' Set m_objWordApplication = GetObject("","word.application")
' If m_objWordApplication Is Nothing Then
Set m_objWordApplication = CreateObject("word.application")
' End If
I have a bunch of mail merge templates setup, when I merge the documents I want to split the results into separate files each one with a name based on the merge field “FileNumber”.
The code I have currently is:
Sub splitter()
' Based on a macro by Doug Robbins to save each letter created by a mailmerge as a separate file.
' With help from http://www.productivitytalk.com/forums/topic/3927-visual-basic-question-for-merge-fields/
Dim i As Integer
Dim Source As Document
Dim Target As Document
Dim Letter As Range
Dim oField As Field
Dim FileNum As String
Set Source = ActiveDocument
For i = 1 To Source.Sections.Count
Set Letter = Source.Sections(i).Range
Letter.End = Letter.End - 1
For Each oField In Letter.Fields
If oField.Type = wdFieldMergeField Then
If InStr(oField.Code.Text, "FileNumber") > 0 Then
'get the result and store it the FileNum variable
FileNum = oField.Result
End If
End If
Next oField
Set Target = Documents.Add
Target.Range = Letter
Target.SaveAs FileName:="C:\Temp\Letter" & FileNum
Target.Close
Next i
End Sub
The problem is if I “Merge to new document” then the “FileNumber” field no longer exists so it can’t pick that up but if I just go to “Preview Results” and run the macro it only saves the currently previewed record and not the rest of the letters.
I’m assuming I need to change the code to something like
For i = 1 To Source.MergedRecord.Count
Set Letter = Source.MergedRecord(i).Range
but I can't work out the correct syntax.
I am aware of http://www.gmayor.com/individual_merge_letters.htm but I don't want the dialog boxes I just want a one click button.
In the Mail merge template document, paste the following macro code in "ThisDocument" module:
Dim WithEvents wdapp As Application
Dim bCustomProcessing As Boolean
Private Sub Document_Open()
Set wdapp = Application
bCustomProcessing = False
ThisDocument.MailMerge.DataSource.ActiveRecord = 1
ThisDocument.MailMerge.ShowWizard 1
With ActiveDocument.MailMerge
If .MainDocumentType = wdFormLetters Then
.ShowSendToCustom = "Custom Letter Processing"
End If
End With
End Sub
Private Sub wdapp_MailMergeWizardSendToCustom(ByVal Doc As Document)
bCustomProcessing = True
Doc.MailMerge.Destination = wdSendToNewDocument
With Doc.MailMerge
For rec = 1 To .DataSource.RecordCount
.DataSource.ActiveRecord = rec
.DataSource.FirstRecord = rec
.DataSource.LastRecord = rec
.Execute
Next
End With
MsgBox "Merge Finished"
End Sub
Private Sub wdapp_MailMergeAfterMerge(ByVal Doc As Document, ByVal DocResult As Document)
If bCustomProcessing = True Then
With Doc.MailMerge.DataSource.DataFields
sFirmFileName = .Item(1).Value ' First Column of the data - CHANGE
End With
DocResult.SaveAs "c:\path\" & sFirmFileName & ".docx", wdFormatXMLDocument
' Path and File Name to save. can use other formats like wdFormatPDF too
DocResult.Close False
End If
End Sub
Remember to update the column number to use for file names, and the path to save the generated files.
After writing this code, save and close the merge template doc. Re-open the file and this time you will be prompted with the Merge wizard. Proceed as required for the Letter, and at the last step, select "Custom Letter Processing" option instead of finishing merge. This will save the separate merged docs in specified folder.
Please remember that this code can be heavy on the processor.
There is a simple solution not involving splitting the resulting document:
Prepare the merge and staying in the template document.Record a macro as you merge one record, then save and close the resulting file, eventuallye advance to the next record.
See the generated macro below. I have added very little code just to extract the filename from a field in the datasource (which is accessible in the template document).
Assign the macro to a shortcut key or implement a loop in VBA. Observe that the fieldnames are casesensitive.
Regards,
Søren
Sub flet1()
'
' flet1 Makro
' 1) Merges active record and saves the resulting document named by the datafield FileName"
' 2) Closes the resulting document, and (assuming that we return to the template)
' 3) advances to the next record in the datasource
'
'Søren Francis 6/7-2013
Dim DokName As String 'ADDED CODE
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
.LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
' Remember the wanted documentname
DokName = .DataFields("FileName").Value ' ADDED CODE
End With
' Merge the active record
.Execute Pause:=False
End With
' Save then resulting document. NOTICE MODIFIED filename
ActiveDocument.SaveAs2 FileName:="C:\Temp\" + DokName + ".docx", FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False, CompatibilityMode:=14
' Close the resulting document
ActiveWindow.Close
' Now, back in the template document, advance to next record
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
End Sub
Thanks for that roryspop,
I ended up swapping the for loop with
Set Source = ActiveDocument
'The for loop was "To ActiveDocument.MailMerge.DataSource.RecordCount" but for
'some reason RecordCount returned -1 every time, so I set ActiveRecord
'to wdLastRecord and then use that in the for loop.
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdLastRecord
For i = 1 To ActiveDocument.MailMerge.DataSource.ActiveRecord
ActiveDocument.MailMerge.DataSource.ActiveRecord = i
Set Letter = Source.Range
For Each oField In Letter.Fields
The rest of the code is the same, it's not very neat and I'm sure there must be a better way of doing things but it works.
The accepted solution did not work for me. I am using Word 2010. I managed to get a solution working and would like to share it here, so others can benefit from it:
'purpose: save each letter generated after mail merge in a separate file
' with the file name equal to first line of the letter.
'
'1. Before you run a mail merge make sure that in the main document you will
' end your letter with a Section Break (this can be found under
' Page Layout/Breaks/Section Break Next Page)
'2. Furthermore the first line of your letter contains the proposed file name
' and put an enter after it. Make the font of the filename white, to make it
' is invisible to the receiver of the letter. You can also include a folder
' name if you like.
'3. Run the mail merge as usual. A file which contains all the letters is
' generated.
'4. Add this module to the generated mail merge file. Use Alt-F11 to go to the
' visual basic user interface, right click in the left pane on the generated
' file and click on Import File and import this file
'5. save the generate file with all the letters as ‘Word Macro Enabled doc
' (*.docm)’.
'6. close the file.
'7. open the file again, click allow content when a warning about macro's is
' shown.
'8. execute the macro with the name SaveRecsAsFiles
Sub SaveRecsAsFiles()
' Convert all sections to Subdocs
AllSectionsToSubDoc ActiveDocument
'Save each Subdoc as a separate file
SaveAllSubDocs ActiveDocument
End Sub
Private Sub AllSectionsToSubDoc(ByRef doc As Word.Document)
Dim secCounter As Long
Dim NrSecs As Long
NrSecs = doc.Sections.Count
'Start from the end because creating
'Subdocs inserts additional sections
For secCounter = NrSecs - 1 To 1 Step -1
doc.Subdocuments.AddFromRange _
doc.Sections(secCounter).Range
Next secCounter
End Sub
Private Sub SaveAllSubDocs(ByRef doc As Word.Document)
Dim subdoc As Word.Subdocument
Dim newdoc As Word.Document
Dim docCounter As Long
Dim strContent As String, strFileName As String
docCounter = 1
'Must be in MasterView to work with
'Subdocs as separate files
doc.ActiveWindow.View = wdMasterView
For Each subdoc In doc.Subdocuments
Set newdoc = subdoc.Open
'retrieve file name from first line of letter.
strContent = newdoc.Range.Text
strFileName = Mid(strContent, 1, InStr(strContent, Chr(13)) - 1)
'Remove NextPage section breaks
'originating from mailmerge
RemoveAllSectionBreaks newdoc
With newdoc
.SaveAs FileName:=strFileName
.Close
End With
docCounter = docCounter + 1
Next subdoc
End Sub
Private Sub RemoveAllSectionBreaks(doc As Word.Document)
With doc.Range.Find
.ClearFormatting
.Text = "^b"
With .Replacement
.ClearFormatting
.Text = ""
End With
.Execute Replace:=wdReplaceAll
End With
End Sub
Part of the code I copied from here