I am working with the following VBA code for Word which extracts each section of the document as a separate document.
It is sourced from: http://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
In the code the filename for each extracted document is based on the first paragraph of the respective section. In the documents our employees are wanting to run this code in the first paragraph of each of the sections is the document title which is all well and good but those titles are in uppercase.
My problem is that when the VBA runs the filenames generated are in uppercase. I need only the first letter of each word to be capitalized in the filenames.
The document titles being in uppercase is an accepted form at my employer so I can't change those. I have been able to alter the original VBA code to make the filenames all lowercase by changing the definition of StrTxt to LCase(.Text): StrTxt= LCase(.Text). This is better because then the employee only needs to retype the first letter of each word in the file name as uppercase. But it would be ideal to have it automatically output in proper case.
Sub SplitMergedDocument()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Const StrNoChr As String = """*./\:?|"
j = InputBox("How many Section breaks are there per record?", "Split By Sections", 1)
With ActiveDocument
**'Process each Section**
For i = 1 To .Sections.Count - 1 Step j
With .Sections(i)
**'Get the 1st paragraph**
Set Rng = .Range.Paragraphs(1).Range
With Rng
**'Contract the range to exclude the final paragraph break**
.MoveEnd wdCharacter, -1
StrTxt = .Text
For k = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
Next
End With
**'Construct the destination file path & name**
StrTxt = ActiveDocument.Path & Application.PathSeparator & StrTxt
**'Get the whole Section**
Set Rng = .Range
With Rng
If j > 1 Then .MoveEnd wdSection, j - 1
**'Contract the range to exclude the Section break**
.MoveEnd wdCharacter, -1
**'Copy the range**
.Copy
End With
End With
**'Create the output document**
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
With Doc
' Paste contents into the output document, preserving the formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Delete trailing paragraph breaks & page breaks at the end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
' Replicate the headers & footers
For Each HdFt In Rng.Sections(j).Headers
.Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In Rng.Sections(j).Footers
.Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close the output document
.SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=StrTxt & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub
