' Word Macro to convert SDA 'tagged' codebook to Word-formatted document ' @(#)sdacdbk.txt 1.1.5 09/26/02 (http://sda.berkeley.edu) Option Explicit 'Force explicit declaration of all variables ' ======================= SDACDBK ======================= Sub sdacdbk() Dim response As Integer Dim msg As String msg = "This macro will produce a Word-formatted document based on a " & vbCrLf & _ "'tagged' format text file created by the SDA XCODEBK program." & vbCrLf & _ "If you choose 'OK' to continue you will next be asked to choose " & vbCrLf & _ "a file name and location for saving this new Word document." & vbCrLf & _ "Just select a file name and location as you normally would, then" & vbCrLf & _ "click on 'Save'. (Note that you MUST choose 'Word Document (*.doc)' as the type." & vbCrLf & _ "Also, you CANNOT choose the name of an already-open document.)" & vbCrLf & _ "Various formatting will then be applied to the Word Document (including" & vbCrLf & _ "the creation of a table of contents). A message box will pop up to inform " & vbCrLf & _ "you when the formatting is complete." & vbCrLf & vbCrLf & _ "If you DON'T want to continue, just choose 'Cancel' now." response = MsgBox(msg, vbQuestion + vbOKCancel) If response = vbCancel Then Exit Sub End If Dim originalFileName As String originalFileName = ActiveDocument.Name Dim originalPath As String originalPath = ActiveDocument.Path Dim newSaveDocName As String newSaveDocName = ActiveDocument.Name Dim pos As Integer pos = InStr(newSaveDocName, ".") If pos > 0 Then newSaveDocName = Left(newSaveDocName, pos - 1) newSaveDocName = newSaveDocName & ".doc" End If Dim dial As Dialog Set dial = Dialogs(wdDialogFileSaveAs) Dim saveOK As Boolean Do Until saveOK = True dial.Name = originalPath & Application.PathSeparator & newSaveDocName dial.Format = wdFormatDocument If dial.Display <> -1 Then MsgBox "Macro will now exit (without creating Word document) ..." Exit Sub End If If dial.Format <> wdFormatDocument Then MsgBox "The file type MUST be 'Word document'. Please try again" Else saveOK = True End If Loop dial.Execute With ActiveDocument.PageSetup .LeftMargin = InchesToPoints(1.25) .RightMargin = InchesToPoints(1.25) .TopMargin = InchesToPoints(1#) .BottomMargin = InchesToPoints(1#) End With Dim studyTitle As String studyTitle = GetInfoTagString("", "") Dim fmtString As String fmtString = GetInfoTagString("", "") Dim is1side As Boolean If fmtString = "1side" Then is1side = True End If Dim dateString As String dateString = GetInfoTagString("", "") Dim defaultTitlePage As String defaultTitlePage = GetInfoTagString("", "") Dim isDefaultTitlePage As Boolean If defaultTitlePage = "true" Then isDefaultTitlePage = True Else isDefaultTitlePage = False End If Call GetInfoTagString("", "") ' Just to clean up tags ' --------- Define Var Style ------------------ Dim varStyle As Style Set varStyle = ActiveDocument.Styles.Add(Name:="SdaVar", _ Type:=wdStyleTypeParagraph) With varStyle.Font ' .Bold = True .Name = "Courier New" .Size = 10 End With With varStyle.ParagraphFormat .KeepWithNext = True End With ' --------- Define Varname Style ------------- Dim vnameStyle As Style Set vnameStyle = ActiveDocument.Styles.Add(Name:="SdaVarname", _ Type:=wdStyleTypeParagraph) vnameStyle.BaseStyle = wdStyleHeading3 With vnameStyle.ParagraphFormat.Borders .Enable = True .Shadow = True .DistanceFromTop = 1 .DistanceFromLeft = 4 .DistanceFromBottom = 1 .DistanceFromRight = 4 End With With vnameStyle.Font .Name = "Arial" .Size = 13 .Bold = False End With ' --------- Define Header1 Style -------------- Dim hdr1Style As Style Set hdr1Style = ActiveDocument.Styles.Add(Name:="SdaHeader1", _ Type:=wdStyleTypeParagraph) hdr1Style.BaseStyle = wdStyleHeading1 With hdr1Style.ParagraphFormat.Borders .Enable = True .Shadow = True .DistanceFromTop = 1 .DistanceFromLeft = 4 .DistanceFromBottom = 1 .DistanceFromRight = 4 End With With hdr1Style.ParagraphFormat.Shading .Texture = wdTexture10Percent End With With hdr1Style.ParagraphFormat .Alignment = wdAlignParagraphCenter End With With hdr1Style.Font .Name = "Arial" .Size = 16 .Bold = True .Italic = True End With ' --------- Define Header2 Style ------------------ Dim hdr2Style As Style Set hdr2Style = ActiveDocument.Styles.Add(Name:="SdaHeader2", _ Type:=wdStyleTypeParagraph) hdr2Style.BaseStyle = wdStyleHeading2 With hdr2Style.ParagraphFormat.Borders .Enable = True .Shadow = True .DistanceFromTop = 1 .DistanceFromLeft = 4 .DistanceFromBottom = 1 .DistanceFromRight = 4 End With With hdr2Style.ParagraphFormat.Shading .Texture = wdTexture10Percent End With With hdr2Style.ParagraphFormat .Alignment = wdAlignParagraphCenter End With With hdr2Style.Font .Name = "Arial" .Size = 14 .Bold = False .Italic = False End With ' --------- Define TitlePage Style ----------------- Dim titlepageStyle As Style Set titlepageStyle = ActiveDocument.Styles.Add(Name:="SdaTitlePage", _ Type:=wdStyleTypeParagraph) With titlepageStyle.Font If isDefaultTitlePage Then .Bold = True .Name = "Arial" .Size = 16 Else .Bold = True .Name = "Courier New" .Size = 12 End If End With With titlepageStyle.ParagraphFormat .KeepWithNext = True If isDefaultTitlePage Then .Alignment = wdAlignParagraphCenter End If End With ' --------- Define Intro Style ---------------- Dim introStyle As Style Set introStyle = ActiveDocument.Styles.Add(Name:="SdaIntro", _ Type:=wdStyleTypeParagraph) With introStyle.Font ' .Bold = True .Name = "Courier New" .Size = 10 End With Call CreateSectionWithEmptyTag(ActiveDocument.Range, "", is1side) Call CreateSectionWithEmptyTag(ActiveDocument.Range, "", is1side) Call CreateSectionWithEmptyTag(ActiveDocument.Range, "", is1side) ' --------------------------------------------- Call ApplyStyle(ActiveDocument.Range, "", "", _ titlepageStyle, False, False, is1side) ' --------------------------------------------- Call ApplyStyle(ActiveDocument.Range, "", "", _ introStyle, True, False, is1side) Call ApplyStyle(ActiveDocument.Range, "", "", _ hdr1Style, False, False, is1side) ' --------------------------------------------- Call ApplyStyle(ActiveDocument.Range, "", "", _ introStyle, True, False, is1side) Call ApplyStyle(ActiveDocument.Range, "", "", _ hdr1Style, False, False, is1side) ' --------------------------------------------- Call ApplyStyle(ActiveDocument.Range, "", "", _ varStyle, False, False, is1side) ' --------------------------------------------- Call ApplyStyle(ActiveDocument.Range, "", "", _ vnameStyle, False, True, is1side) ' --------------------------------------------- Call ApplyStyle(ActiveDocument.Range, "", "", _ hdr1Style, True, False, is1side) ' --------------------------------------------- Call ApplyStyle(ActiveDocument.Range, "", "", _ hdr2Style, False, False, is1side) ' Create a table of contents Dim rngToc As Range Set rngToc = ActiveDocument.Range.Duplicate Dim tocTagsFound As Boolean tocTagsFound = FindTagsRange(ActiveDocument.Range, "", "", rngToc) If tocTagsFound Then ActiveDocument.TablesOfContents.Add Range:=rngToc, _ UseFields:=False, UseHeadingStyles:=True, LowerHeadingLevel:=3, _ UpperHeadingLevel:=1 ActiveDocument.TablesOfContents.Format = wdTOCDistinctive Call AddSection(rngToc, is1side) ActiveDocument.TablesOfContents(1).TabLeader = wdTabLeaderLines End If ' Create page headers and footers Call MakeHeadersFooters(studyTitle, is1side, dateString) MsgBox "Formatting is now complete." End Sub '============== CREATESECTIONWITHEMPTYTAG ======================== Private Sub CreateSectionWithEmptyTag(ByVal rngToSrch As Range, _ emptyTag As String, is1side As Boolean) Dim rngEmptyTag As Range ' Set search ranges Set rngEmptyTag = rngToSrch.Duplicate With rngEmptyTag.Find .ClearFormatting .Text = emptyTag .Forward = True .Wrap = wdFindStop .Execute End With ' Exit function if start tag is not found If Not rngEmptyTag.Find.Found Then Exit Sub End If rngEmptyTag.Delete rngEmptyTag.Collapse wdCollapseStart Call AddSection(rngEmptyTag, is1side) End Sub ' ====================== ADDSECTION =========================== Private Sub AddSection(rngTarget As Range, is1side As Boolean) If is1side Then ActiveDocument.Sections.Add _ Range:=rngTarget, Start:=wdSectionNewPage Else ActiveDocument.Sections.Add _ Range:=rngTarget, Start:=wdSectionOddPage End If End Sub ' ====================== APPLYSTYLE =========================== Private Sub ApplyStyle(ByVal rngToSrch As Range, startTag As String, _ endTag As String, passedStyle As Style, _ addPageBreak As Boolean, boldFirstWord As Boolean, is1side As Boolean) Dim rngFound As Range Set rngFound = rngToSrch.Duplicate Dim tagsFound As Boolean tagsFound = True ' For efficiency, create font OUTSIDE of loop Dim newFont As Font Set newFont = passedStyle.Font.Duplicate newFont.Bold = True Do tagsFound = FindTagsRange(rngToSrch, startTag, endTag, rngFound) ' Exit loop if not found If Not tagsFound Then Exit Do ' Apply style to found range rngFound.Style = passedStyle ' Bold first word in range (if requested) If boldFirstWord Then Call SetFirstWordFont(rngFound, newFont) End If ' Create a new hard page break BEFORE the range (if requested) If addPageBreak Then ' Check if this comes immediately after the start of ' a section. If so, DON'T add an (extra) page break. Dim rngCurrentSect As Range Set rngCurrentSect = rngFound.Sections(1).Range rngCurrentSect.End = rngFound.Start Dim parsFromSectStart As Long parsFromSectStart = rngCurrentSect.Paragraphs.Count If parsFromSectStart > 2 Then Dim rngTmp As Range Set rngTmp = ActiveDocument.Range.Duplicate rngTmp.Start = rngFound.Start - 1 rngTmp.Collapse wdCollapseStart rngTmp.InsertAfter (vbCr) rngTmp.InsertBreak (wdPageBreak) End If End If ' Prepare for next search by moving the start position of ' rngToSrch to one char beyond end of rngFound ... rngToSrch.Start = rngFound.End + 1 Loop Until Not tagsFound End Sub ' ==================== SETFIRSTWORDFONT ======================= Private Sub SetFirstWordFont(ByVal pRange As Range, newFont As Font) Dim originalCharCount As Long originalCharCount = pRange.Characters.Count pRange.Collapse wdCollapseStart ' Note: the Expand method doesn't work because an underline ' is treated as an "end-of-word" marker by VB -- but variable ' names can contain underlines. So we have to use the somewhat ' more complex MoveEndUntil method ' pRange.Expand Unit:=wdWord pRange.MoveEndUntil ": ", wdForward ' We never want to move the end of the range past the original ' ending point. So check that now and restore the original end ' if necessary. If pRange.Characters.Count > originalCharCount Then pRange.End = pRange.Start + originalCharCount End If pRange.Font = newFont End Sub ' =================== GETINFOTAGSTRING ========================== Private Function GetInfoTagString(startTag As String, _ endTag As String) As String GetInfoTagString = "" Dim rngInfoTag As Range Set rngInfoTag = ActiveDocument.Range.Duplicate If FindTagsRange(ActiveDocument.Range, startTag, endTag, _ rngInfoTag) Then GetInfoTagString = rngInfoTag.Text rngInfoTag.Delete End If End Function ' ====================== FINDTAGSRANGE ===================== Private Function FindTagsRange(rngToSrch As Range, startTag As String, _ endTag As String, rngFound As Range) As Boolean Dim rngStartTag As Range Dim rngEndTag As Range ' Set search ranges Set rngStartTag = rngToSrch.Duplicate Set rngEndTag = rngToSrch.Duplicate With rngStartTag.Find .ClearFormatting .Text = startTag .Forward = True .Wrap = wdFindStop .Execute End With ' Exit function if start tag is not found If Not rngStartTag.Find.Found Then FindTagsRange = False Exit Function Else rngStartTag.Delete rngStartTag.Collapse wdCollapseStart End If ' Set range for finding end tag rngEndTag.Start = rngStartTag.Start With rngEndTag.Find .ClearFormatting .Text = endTag .Forward = True .Wrap = wdFindStop .Execute End With ' Exit loop if not found If Not rngEndTag.Find.Found Then FindTagsRange = False Exit Function Else rngEndTag.Delete rngEndTag.Collapse wdCollapseStart End If ' Set found range rngFound.Start = rngStartTag.Start rngFound.End = rngEndTag.Start FindTagsRange = True End Function ' =================== MAKEHEADERSFOOTERS ======================= Private Sub MakeHeadersFooters(studyTitle As String, is1side As Boolean, _ dateString As String) Dim fmtOddEven As Boolean If is1side Then fmtOddEven = False Else fmtOddEven = True End If Dim rngSect As Range ' Sections are: 1 = Title page, 2 = Table of contents, ' 3 to last = intros, variables, and appendices ' SECTION 2 (Table of Contents): If fmtOddEven Then ActiveDocument.Sections(2).PageSetup.OddAndEvenPagesHeaderFooter = True ' Odd (primary) page header Call MakeHeader(ActiveDocument.Sections(2).Headers(wdHeaderFooterPrimary), _ True, True, studyTitle) ' Even page header Call MakeHeader(ActiveDocument.Sections(2).Headers(wdHeaderFooterEvenPages), _ False, True, studyTitle) With ActiveDocument.Sections(2).Footers(wdHeaderFooterPrimary) .LinkToPrevious = False .Range.Text = vbTab & dateString ' Center date by first inserting a tab End With With ActiveDocument.Sections(2).Footers(wdHeaderFooterEvenPages) .LinkToPrevious = False .Range.Text = vbTab & dateString ' Center date by first inserting a tab End With Else ' NOT fmtOddEven ' Set header Call MakeHeader(ActiveDocument.Sections(2).Headers(wdHeaderFooterPrimary), _ True, True, studyTitle) ' Set footer With ActiveDocument.Sections(2).Footers(wdHeaderFooterPrimary) .LinkToPrevious = False .Range.Text = vbTab & dateString ' Center date by first inserting a tab End With End If ' SECTION 3 (and remaining codebook sections): If fmtOddEven Then ActiveDocument.Sections(3).PageSetup.OddAndEvenPagesHeaderFooter = True ' Odd (primary) page header Call MakeHeader(ActiveDocument.Sections(3).Headers(wdHeaderFooterPrimary), _ True, False, studyTitle) ' Even page header Call MakeHeader(ActiveDocument.Sections(3).Headers(wdHeaderFooterEvenPages), _ False, False, studyTitle) Else Call MakeHeader(ActiveDocument.Sections(3).Headers(wdHeaderFooterPrimary), _ True, False, studyTitle) End If ' Remove text from section 1 (title page) headers and footers ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Delete ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Delete End Sub ' ====================== MAKEHEADER ============================ Private Sub MakeHeader(thisheader As HeaderFooter, oddPage As Boolean, _ romanStyle As Boolean, studyTitle As String) With thisheader .PageNumbers.RestartNumberingAtSection = True .PageNumbers.StartingNumber = 1 .Range.Bold = True .LinkToPrevious = False End With If romanStyle Then thisheader.PageNumbers.NumberStyle = wdPageNumberStyleLowercaseRoman Else thisheader.PageNumbers.NumberStyle = wdPageNumberStyleArabic End If Dim rngSect As Range Set rngSect = thisheader.Range If oddPage Then rngSect.Text = studyTitle & vbTab & vbTab rngSect.Collapse wdCollapseEnd rngSect.Fields.Add rngSect, wdFieldPage Else ' even page rngSect.Fields.Add rngSect, wdFieldPage rngSect.Collapse wdCollapseEnd rngSect.InsertAfter vbTab & vbTab & studyTitle End If End Sub