Word 2007 VBA Macro to Create PDFs for a Manual
This is a macro that reads a (Microsoft) Word 2007 document which uses INCLUDETEXT fields to draw in content from other documents and exports the content as a PDF, including a table of contents and index.
There are three administrator types or roles - System, Partner, and Limited. For each chapter, an INCLUDETEXT field includes the content for that role, for example:
{INCLUDETEXT "{BaseDir}//Overview//{AdminRole}.docx"}
The document for each role has the appropriate content. In most cases, the directory has a Common.docx file that has the text for all roles, and those authorized to view it include the file like so:
{INCLUDETEXT "{BaseDir}//Overview//Common.docx"}
Unauthorized users would have an empty .docx file, or one with a limited version of content.
The way the macro works is to first extract the value of BaseDir, which allows an absolute path to be used, but modified without updating all the files. Relative paths just didn’t work well.
The document also uses some bookmarks, which the macro uses to reference different sections. One bookmark includes all the content from both the chapters and appendices. The chapters are enclosed in a bookmark called ‘Chapter’, and the appendices are enclosed in a bookmark called ‘Appendix’. These bookmarks are used to create the footers, since the chapters are numeric and the appendices are alphabetic. If content for the chapter is included for the role, a section break is inserted. This ensures that the chapter and page numbers are consequetive, even if chapters are omitted.
Option Base 1
Option Explicit
Global AdminTypes
Sub Init()
AdminTypes = Array("System", "Partner", "Limited")
End Sub
Sub CreatePDFs()
Dim C, D, I, L, N, T, F, BaseDir, FieldCount
Dim BaseDirFieldItemIndex, AdminTypeFieldItemIndex, CurrentYearFieldItemIndex
Dim rngTemp As Range, rngField As Range
Dim fldPtr As Field
Dim J, JL, JU, arrBookmarks(2) As String
Dim Selection As Range
Dim Footer As Range
Dim S As String, LastFooterType As String
Init
I = 1
AdminTypeFieldItemIndex = 0
BaseDirFieldItemIndex = 0
FieldCount = ActiveDocument.Fields.Count()
For I = 1 To FieldCount
T = ActiveDocument.Fields.Item(I).Code.Text
If (InStr(1, T, "BaseDir", vbTextCompare) <> 0) Then
BaseDirFieldItemIndex = I
End If
If (InStr(1, T, "AdminType", vbTextCompare) <> 0) Then
AdminTypeFieldItemIndex = I
End If
If (InStr(1, T, "CurrentYear", vbTextCompare) <> 0) Then
CurrentYearFieldItemIndex = I
End If
If AdminTypeFieldItemIndex <> 0 And BaseDirFieldItemIndex <> 0 And CurrentYearFieldItemIndex <> 0 Then Exit For
Next
' Set the current year for the copyright date
Set rngTemp = ActiveDocument.Fields.Item(CurrentYearFieldItemIndex).Code
rngTemp.Text = " SET CurrentYear " + Chr(34) + Str$(DatePart("yyyy", Date)) + Chr(34) + " "
' Set the base directory for INCLUDETEXT tags
ActiveDocument.Fields.Item(BaseDirFieldItemIndex).Update
D = ActiveDocument.Fields.Item(BaseDirFieldItemIndex).Result()
Set rngTemp = ActiveDocument.Fields.Item(BaseDirFieldItemIndex).Code
rngTemp.Text = " SET BaseDir " + Chr(34) + D + Chr(34) + " "
D = D + Chr(92)
' Setup the loop boundaries for the roles
I = LBound(AdminTypes)
L = UBound(AdminTypes)
' Set up the sections that will be processed
arrBookmarks(1) = "Chapter"
arrBookmarks(2) = "Appendix"
JL = LBound(arrBookmarks)
JU = UBound(arrBookmarks)
LastFooterType = ""
' Loop through all the admin types or roles
For N = I To L
' Set the role for this document
Set rngTemp = ActiveDocument.Fields.Item(AdminTypeFieldItemIndex).Code
rngTemp.Text = " SET AdminType """ + AdminTypes(N) + """ "
ActiveDocument.Fields.Item(AdminTypeFieldItemIndex).Update
' Update all the fields for this role
Set rngTemp = ActiveDocument.Bookmarks("ChapterBlockStart").Range
rngTemp.Select
rngTemp.Fields.Update
' Loop through the sections that will be processed.
' Each included file is checked to see if content was included
' Files that have content are followed by a section break, empty files are not
For J = JL To JU
Set rngTemp = ActiveDocument.Bookmarks(arrBookmarks(J)).Range
rngTemp.Select
For Each fldPtr In rngTemp.Fields
' Loop through all the field in this section or group of included files
T = fldPtr.Type
' If this field is an INCLUDETEXT
If (T = wdFieldIncludeText) Then
T = Trim(fldPtr.Result())
' If the included text is not empty
If (T <> "") And (Asc(T) <> 13) Then
Set rngField = ActiveDocument.Range
rngField.Find.Text = fldPtr.Code
' Search the document for the tag. This ensures included tags do not add section breaks
rngField.Find.Execute
If rngField.Find.Found Then
' Select the tag
rngField.Select
' Advance the range to the end of the field
rngField.MoveEnd wdCharacter, 2
rngField.Collapse wdCollapseEnd
' Page numbering starts at 1 for all sections
rngField.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.StartingNumber = 1
rngField.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection = True
If LastFooterType = arrBookmarks(J) Then
rngField.Sections(1).Footers(wdHeaderFooterPrimary).LinkToPrevious = True
Else
rngField.Sections(1).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
' Create new footer
Set Footer = rngField.Sections(1).Footers(wdHeaderFooterPrimary).Range
Footer.Select
' Clear any existing text
Footer.Delete
' Set up the table
Footer.Tables.Add Range:=Footer, NumRows:=1, _
NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
With Footer.Tables(1)
.Borders.Enable = False
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = False
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = False
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = False
.ApplyStyleColumnBands = False
End With
' Left column
Set Selection = Footer.Tables(1).Cell(1, 1).Range
Selection.Select
Selection.Collapse wdCollapseStart
Selection.Text = "Mobiso " + AdminTypes(N) + " Administrator's Guide"
' Right column
Selection.Start = Footer.Tables(1).Cell(1, 2).Range.Start
Selection.Select
Selection.Collapse wdCollapseStart
Selection.Text = arrBookmarks(J) + " <field> - <page>"
Selection.Find.Text = "<field>"
If Selection.Find.Execute Then
Selection.Select
S = "SEQ Chapter \c"
If arrBookmarks(J) = "Appendix" Then
S = S + " \* ALPHABETIC"
Else
S = S + " \* ARABIC"
End If
Selection.Fields.Add Range:=Selection, Type:=wdFieldEmpty, Text:=S, PreserveFormatting:=False
End If
Selection.Find.Text = "<page>"
If Selection.Find.Execute Then
Selection.Select
Selection.Fields.Add Range:=Selection, Type:=wdFieldEmpty, Text:="PAGE", PreserveFormatting:=False
End If
Footer.Tables(1).Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
LastFooterType = arrBookmarks(J)
End If
' Insert the section break
rngField.InsertBreak wdSectionBreakNextPage
End If
End If
End If
Next fldPtr
Next J
Set rngTemp = ActiveDocument.Bookmarks("Appendix").Range
rngTemp.Select
rngTemp.Find.Execute FindText:="^b", ReplaceWith:="", Replace:=wdReplaceOne, Forward:=False
' Update table of contents and index
ActiveDocument.TablesOfContents.Item(1).Update
ActiveDocument.Indexes.Item(1).Update
'MsgBox "Exporting " + AdminTypes(N) + " manual to PDF (" + D + AdminTypes(N) + ".pdf)"
ActiveDocument.ExportAsFixedFormat D + AdminTypes(N) + ".pdf", wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportAllDocument
' Remove the inserted section breaks
For J = JL To JU
Set rngTemp = ActiveDocument.Bookmarks(arrBookmarks(J)).Range
rngTemp.Find.Execute FindText:="^b", ReplaceWith:="", Replace:=wdReplaceAll
Next J
' Helpful if you want to build one PDF, then check it
'If (MsgBox("Built " + AdminTypes(N) + " PDF", vbOKCancel, "Continue?") = vbCancel) Then Exit For
Next
MsgBox "Done - Updated PDFs are in " + D
End Sub
This code has good examples of the following with VBA:
- Set a FIELD tag
- Delete a section break
- Export a Word document
- Create a footer
- Create a table
- Insert a section break
This post courtesy of http://mobiso.com
Print article | This entry was posted by elvis on 06/07/11 at 07:27:00 pm . Follow any responses to this post through RSS 2.0. |