'   Word Macro to convert SDA 'tagged' codebook to Word-formatted document
'   @(#)sdacdbk.txt  1.1.6   06/19/20 (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("<sda_studytitle>", "</sda_studytitle>")

Dim fmtString As String
fmtString = GetInfoTagString("<sda_format>", "</sda_format>")
Dim is1side As Boolean
If fmtString = "1side" Then
    is1side = True
End If

Dim dateString As String
dateString = GetInfoTagString("<sda_date>", "</sda_date>")

Dim defaultTitlePage As String
defaultTitlePage = GetInfoTagString("<sda_defaulttitlepage>", "</sda_defaulttitlepage>")
Dim isDefaultTitlePage As Boolean
If defaultTitlePage = "true" Then
    isDefaultTitlePage = True
Else
    isDefaultTitlePage = False
End If

Call GetInfoTagString("<sda_options>", "</sda_options>")   ' 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, "<sda_sectIntroductions/>", is1side)
Call CreateSectionWithEmptyTag(ActiveDocument.Range, "<sda_sectVariables/>", is1side)
Call CreateSectionWithEmptyTag(ActiveDocument.Range, "<sda_sectAppendices/>", is1side)

' ---------------------------------------------
Call ApplyStyle(ActiveDocument.Range, "<sda_titlepage>", "</sda_titlepage>", _
        titlepageStyle, False, False, is1side)
' ---------------------------------------------
Call ApplyStyle(ActiveDocument.Range, "<sda_intro>", "</sda_intro>", _
        introStyle, True, False, is1side)
Call ApplyStyle(ActiveDocument.Range, "<sda_introheader>", "</sda_introheader>", _
        hdr1Style, False, False, is1side)
' ---------------------------------------------
Call ApplyStyle(ActiveDocument.Range, "<sda_appdx>", "</sda_appdx>", _
        introStyle, True, False, is1side)
Call ApplyStyle(ActiveDocument.Range, "<sda_appdxheader>", "</sda_appdxheader>", _
        hdr1Style, False, False, is1side)
' ---------------------------------------------
Call ApplyStyle(ActiveDocument.Range, "<sda_var>", "</sda_var>", _
        varStyle, False, False, is1side)
' ---------------------------------------------
Call ApplyStyle(ActiveDocument.Range, "<sda_vname>", "</sda_vname>", _
        vnameStyle, False, True, is1side)
' ---------------------------------------------
Call ApplyStyle(ActiveDocument.Range, "<sda_hdr1>", "</sda_hdr1>", _
        hdr1Style, True, False, is1side)
' ---------------------------------------------
Call ApplyStyle(ActiveDocument.Range, "<sda_hdr2>", "</sda_hdr2>", _
        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, "<sda_toc>", "</sda_toc>", 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
            ' Commented out following line of code because recent versions of
            ' Word give a run-time error 6028: The range cannot be deleted
            ' 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