I have written the VBA code below to automate splitting and mail-merged letter into individual letters and naming each by whatever the first sentence in each newly created document is.
My problem is that at some point during the split process the font of the entire document is changed from "Ariel" to "Times New Roman"
If required i can send a "test file" to you if you would like - but i do not want to post it generally on the web as it includes company letterhead etc.
Any help would be appreciated.
Here is the code:
[vba]
Sub SplitandSave()
Dim x As Long
Dim Sections As Long
Dim Doc As Document
Dim MyName As String
On Error GoTo doh
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Doc = ActiveDocument
Sections = Doc.Sections.Count
For x = Sections - 1 To 1 Step -1
Doc.Sections(x).Range.Copy
Documents.Add
With ActiveDocument
.Range.Paste
With .Sentences(1).TextRetrievalMode
.IncludeHiddenText = False
.IncludeFieldCodes = False
MyName = .Parent.Text
MyName = Replace(MyName, Chr(9), "")
MyName = Replace(MyName, Chr(10), "")
MyName = Replace(MyName, Chr(11), "")
MyName = Replace(MyName, Chr(12), "")
MyName = Replace(MyName, Chr(13), "")
MyName = Replace(MyName, Chr(14), "")
MyName = Replace(MyName, Chr(30), "")
MyName = Replace(MyName, Chr(160), "")
MyName = Replace(MyName, "\", "")
MyName = Replace(MyName, "/", "")
CleanString (MyName)
MyName = MyName & ".doc"
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^b"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(4.2)
.BottomMargin = CentimetersToPoints(1)
.LeftMargin = CentimetersToPoints(1.8)
.RightMargin = CentimetersToPoints(1.8)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.25)
.FooterDistance = CentimetersToPoints(1)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
'the following three lines were meant to eliminate blank pages at end of Doc but just end up deleting whole doc
'To be looked at later
'Selection.GoTo 1, -1
'Selection.Bookmarks("\Page").Range.Delete
'Selection.Paragraphs.Last.Range.Delete
.SaveAs FileName:=MyName
ActiveDocument.Close False
End With
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
doh:
MsgBox "Please retry splitting the letters - IF problems persist please speak to Richard Hill"
End Sub
[/vba]