Option Explicit On
'Imports Microsoft.Office.Interop.Word

Module Tools
    Private FixMe As String

    Public Sub IsolatePageBreaks()
        Dim rng As Word.Range

        App.ActiveDocument.Paragraphs(1).Range.Select()
        App.Selection.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseStart)

        App.Selection.Find.ClearFormatting()
        App.Selection.Find.Replacement.ClearFormatting()

        With App.Selection.Find
            .Text = "^m"
            .Forward = True
            .Wrap = Word.WdFindWrap.wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With

        While App.Selection.Find.Execute
            rng = App.ActiveDocument.Range(App.Selection.End, App.Selection.End + 1)
            If rng.Text <> Chr(13) Then
                App.Selection.InsertParagraphAfter()
                App.Selection.End = App.Selection.End - 1
            End If

            rng = App.ActiveDocument.Range(App.Selection.Start - 1, App.Selection.Start)
            If rng.Text <> Chr(13) Then
                App.Selection.InsertParagraphBefore()
                App.Selection.Start = App.Selection.Start + 1
            End If
            App.Selection.ParagraphFormat.Style = App.ActiveDocument.Styles("Normal").NameLocal
        End While
    End Sub

    Public Sub PreSearchCleanup()
        Dim para As Word.Paragraph
        Dim vReplace As Object
        Dim vWith As Object
        Dim sTemp As String
        Dim I As Long
        Dim J As Integer
        Dim K As Integer
        Dim bWildCards As Boolean

        On Error Resume Next

        With App.Selection.Find
            .ClearFormatting()
            .Replacement.ClearFormatting()
            .Forward = True
            .Wrap = Word.WdFindWrap.wdFindContinue
            .Format = False
            .MatchCase = True
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With

        With App.ActiveDocument
            'replace page breaks
            If GetNodeValue("//Search/RemovePageBreaks") = "True" Then
                App.Selection.Find.Execute(FindText:="^m", ReplaceWith:="", Replace:=Word.WdReplace.wdReplaceAll)
            End If

            'remove blank paragraphs
            If GetNodeValue("//Search/RemoveBlankPara") = "True" Then
                For I = .Paragraphs.Count To 1 Step -1
                    App.StatusBar = "Remove blank paragraphs " & I
                    If .Paragraphs(I).Range.Text = Chr(13) Then
                        .Paragraphs(I).Range.Delete()
                    End If
                Next I
            End If

            'remove section breaks
            If GetNodeValue("//Search/RemoveSectionBreaks") = "True" Then
                App.Selection.Find.Execute(FindText:="^b", ReplaceWith:="", Replace:=Word.WdReplace.wdReplaceAll)
            End If

            'replace words
            If GetNodeValue("//Search/ReplaceWords") = "True" Then
                If GetNodeValue("//Search/ReplaceWildCards") = "True" Then
                    bWildCards = True
                Else
                    bWildCards = False
                End If
                .Paragraphs(1).Range.Select()
                App.Selection.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseStart)
                App.Selection.Find.Wrap = Word.WdFindWrap.wdFindStop

                vReplace = GetListValues("Replace", "str")
                vWith = GetListValues("Replace", "with")
                For I = 0 To UBound(vReplace)
                    'word will not find paragraphs containing shapes so we have to delete them
                    If InStr(1, vReplace(I), "^p") > 0 Then
                        'strip special codes from search string
                        sTemp = CStr(vReplace(I))
                        J = InStr(sTemp, "^")
                        While J > 0
                            sTemp = Left(sTemp, J - 1) & Mid(sTemp, J + 2)
                            J = InStr(sTemp, "^")
                        End While
                        'strip shapes from any paragraph containing search word
                        .Paragraphs(1).Range.Select()
                        App.Selection.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseStart)
                        App.Selection.Find.Wrap = Word.WdFindWrap.wdFindStop
                        While App.Selection.Find.Execute(FindText:=sTemp) = True
                            For K = App.Selection.Paragraphs(1).Range.ShapeRange.Count To 1 Step -1
                                App.Selection.Paragraphs(1).Range.ShapeRange(K).Delete()
                            Next K
                            'merge format with previous paragraph
                            App.Selection.MoveStart(Unit:=Word.WdUnits.wdParagraph, Count:=-1)
                            App.Selection.ParagraphFormat = App.Selection.Paragraphs(1).Range.ParagraphFormat
                            App.Selection.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseEnd)
                        End While
                    End If
                    'now we can find and replace
                    App.Selection.Find.Wrap = Word.WdFindWrap.wdFindContinue
                    App.Selection.Find.MatchWildcards = bWildCards
                    App.Selection.Find.Execute(FindText:=vReplace(I), ReplaceWith:=vWith(I), Replace:=Word.WdReplace.wdReplaceAll)
                Next I
            End If

        End With

    End Sub

    Public Sub FindSections()
        Dim I As Integer
        Dim J As Integer
        Dim sTemp As String
        Dim sNewTag As String
        Dim CmtType As String
        Dim CurrentSection As VESection
        Dim bFound As Boolean

        GetSections
        IsolatePageBreaks()

        If GetNodeValue("//Search/UseSectionHeaderTags") = "True" Then
            With App.ActiveDocument.Sections
                For I = 1 To .Count
                    sNewTag = ""
                    bFound = False
                    If .Item(I).Range.Comments.Count > 0 Then
                        CmtType = .Item(I).Range.Comments(1).Author
                    Else
                        CmtType = ""
                    End If
                    If CmtType <> "SECTION" Then
                        sTemp = .Item(I).Headers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Text
                        For J = 0 To UBound(VESections)
                            If VESections(J).HeaderTag <> "" And InStr(sTemp, VESections(J).HeaderTag) Then
                                If .Item(I).Range.Paragraphs(1).Range.Information(Word.WdInformation.wdWithInTable) Then
                                    .Item(I).Range.Paragraphs(1).Range.Select()
                                    App.Selection.SplitTable()
                                Else
                                    .Item(I).Range.Paragraphs(1).Range.InsertParagraphBefore()
                                End If
                                .Item(I).Range.Paragraphs(1).Range.Select()
                                App.Selection.ParagraphFormat.Style = App.ActiveDocument.Styles("Normal").NameLocal
                                App.Selection.InsertBefore("SECTION")
                                App.Selection.Font.Italic = True
                                CurrentSection = VESections(J)
                                If Len(CurrentSection.MergeStyle) > 0 Then
                                    If InStr(CurrentSection.MergeStyle, "PageBreak") > 0 Then
                                        App.Selection.MoveEndUntil(Cset:=Chr(12), Count:=Word.WdConstants.wdForward)
                                    Else
                                        App.Selection.End = App.Selection.Bookmarks("\Page").End - 1
                                    End If
                                End If
                                FlagSection(VESections(J))
                                bFound = True
                                Exit For
                            End If
                        Next J
                        If bFound = False Then
                            If I = 1 Then
                                App.ActiveDocument.Paragraphs(1).Range.Select()

                                With App.Selection
                                    If .Comments.Count = 0 Then
                                        App.ActiveDocument.Range.InsertParagraphBefore()
                                        App.ActiveDocument.Paragraphs(1).Range.Select()
                                        .InsertBefore("SECTION")
                                        .Font.Italic = True
                                        FlagSection(VESections(0))
                                    End If
                                End With
                            End If
                            While MoveNext(.Item(I).Range) = True
                                If App.Selection.Comments.Count = 0 Then
                                    If App.Selection.Information(Word.WdInformation.wdWithInTable) = True Then
                                        If GetIdent(App.Selection.Tables(1).Cell(1, 1).Range.Paragraphs(1).Range, sNewTag) = "SECTION" Then
                                            CurrentSection = ThisSection
                                            If CurrentSection.ChangeNumber Then
                                                CurrentSection.number = sNewTag
                                            End If
                                            If Len(CurrentSection.MergeStyle) > 0 Then
                                                If InStr(CurrentSection.MergeStyle, "PageBreak") > 0 Then
                                                    App.Selection.MoveEndUntil(Cset:=Chr(12), Count:=Word.WdConstants.wdForward)
                                                Else
                                                    App.Selection.End = App.Selection.Bookmarks("\Page").End - 1
                                                End If
                                            End If
                                            FlagSection CurrentSection
                                    End If
                                    ElseIf App.Selection.Information(Word.WdInformation.wdInFieldCode) = True Then
                                        'do nothing
                                    ElseIf App.Selection.Information(Word.WdInformation.wdInFieldResult) = True Then
                                        'do nothing
                                    ElseIf GetIdent(App.Selection.Range, sNewTag) = "SECTION" Then
                                        CurrentSection = ThisSection
                                        If CurrentSection.ChangeNumber Then
                                            CurrentSection.number = sNewTag
                                        End If
                                        If Len(CurrentSection.MergeStyle) > 0 Then
                                            If InStr(CurrentSection.MergeStyle, "PageBreak") > 0 Then
                                                App.Selection.MoveEndUntil(Cset:=Chr(12), Count:=Word.WdConstants.wdForward)
                                            Else
                                                App.Selection.End = App.Selection.Bookmarks("\Page").End - 1
                                            End If
                                        End If
                                        FlagSection(CurrentSection)
                                    End If
                                End If
                            End While
                        End If
                    End If
                Next I
            End With
        Else
            App.ActiveDocument.Paragraphs(1).Range.Select()

            With App.Selection
                If .Comments.Count = 0 Then
                    App.ActiveDocument.Range.InsertParagraphBefore()
                    App.ActiveDocument.Paragraphs(1).Range.Select()
                    .InsertBefore("SECTION")
                    .Font.Italic = True
                    FlagSection(VESections(0))
                End If
                While MoveNext() = True
                    If .Comments.Count = 0 Then
                        If .Information(Word.WdInformation.wdWithInTable) = True Then
                            If GetIdent(App.Selection.Tables(1).Cell(1, 1).Range.Paragraphs(1).Range, sNewTag) = "SECTION" Then
                                CurrentSection = ThisSection
                                If CurrentSection.ChangeNumber Then
                                    CurrentSection.number = sNewTag
                                End If
                                If Len(CurrentSection.MergeStyle) > 0 Then
                                    If InStr(CurrentSection.MergeStyle, "PageBreak") > 0 Then
                                        App.Selection.MoveEndUntil(Cset:=Chr(12), Count:=Word.WdConstants.wdForward)
                                    Else
                                        App.Selection.End = App.Selection.Bookmarks("\Page").End - 1
                                    End If
                                End If
                                FlagSection(CurrentSection)
                            End If
                        ElseIf .Information(Word.WdInformation.wdInFieldCode) = True Then
                            'do nothing
                        ElseIf .Information(Word.WdInformation.wdInFieldResult) = True Then
                            'do nothing
                        ElseIf GetIdent(.Range, sNewTag) = "SECTION" Then
                            CurrentSection = ThisSection
                            If CurrentSection.ChangeNumber Then
                                CurrentSection.number = sNewTag
                            End If
                            If Len(CurrentSection.MergeStyle) > 0 Then
                                If InStr(CurrentSection.MergeStyle, "PageBreak") > 0 Then
                                    .MoveEndUntil(Cset:=Chr(12), Count:=Word.WdConstants.wdForward)
                                Else
                                    .End = .Bookmarks("\Page").End - 1
                                End If
                            End If
                            FlagSection(CurrentSection)
                        End If
                    End If
                End While
            End With
            App.ActiveDocument.Paragraphs(1).Range.Select()
        End If
        App.StatusBar = "Find Sections - Done"

    End Sub


    Public Sub ClearDocProperties()
        Dim I As Integer
        Dim sName As String

        With App.ActiveDocument.CustomDocumentProperties
            For I = .Count To 1 Step -1
                sName = .Item(I).name
                'If sName Like "DOC_*" Or sName Like "PSI_*" Then
                If sName Like "PSI_*" Then
                    .Item(I).Delete
                End If
            Next I
        End With
    End Sub

    Public Sub FlagSection(Section As VESection)
        FindTitle(Section)
        InsertComment("SECTION", Section.name & vbCrLf & Section.Style & vbCrLf & Section.Type & vbCrLf & Section.number & vbCrLf & Section.Title & vbCrLf & Section.ID)
    End Sub

    Public Sub FindTitle(ByRef Section As VESection)

        If Section.Title = "" Then
            Select Case LCase(Section.FindTitle)
                Case "afterhyphen"
                    FixMe = App.Selection.Paragraphs(1).Range.Text
                    FixText()

                    If InStr(1, FixMe, Chr(45)) > 0 Then
                        FixMe = Mid(FixMe, InStr(1, FixMe, Chr(45)) + 1)
                        FixMe = Trim(FixMe)
                        Section.Title = FixMe
                    End If
                Case "nextparagraph"
                    FixMe = App.Selection.Paragraphs(1).Next.Range.Text
                    FixText()
                    Section.Title = FixMe
                Case "thisparagraph"
                    FixMe = App.Selection.Paragraphs(1).Range.Text
                    FixText()
                    Section.Title = FixMe
            End Select
        End If
    End Sub

    Private Sub FixText()
        FixMe = Replace(FixMe, Chr(160), " ")
        FixMe = Replace(FixMe, Chr(150), Chr(45))
        FixMe = Replace(FixMe, Chr(30), Chr(45))
        FixMe = Replace(FixMe, Chr(13), "")
        FixMe = Replace(FixMe, Chr(12), "")
        FixMe = Replace(FixMe, Chr(9), " ")
        FixMe = Trim(FixMe)

    End Sub

    Public Sub MergeSections()
        Dim Cmt As Word.Comment
        Dim rng As Word.Range
        Dim I As Integer
        Dim J As Integer
        Dim iCmtCount As Integer
        Dim bFoundFirst As Boolean
        Dim bDone As Boolean
        Dim sID As String
        Dim sIsMerged As String

        'On Error Resume Next
        GetSections
        For I = 1 To UBound(VESections)
            With VESections(I)
                If .MergeStyle <> "" Then
                    bFoundFirst = False
                    While bDone = False
                        bDone = True
                        For J = 1 To App.ActiveDocument.Comments.Count
                            Cmt = App.ActiveDocument.Comments(J)
                            If Cmt.Author = "SECTION" Then
                                With Cmt.Range
                                    sID = LCase(Replace(.Paragraphs(6).Range.Text, Chr(13), ""))
                                    If .Paragraphs.Count > 6 Then
                                        sIsMerged = LCase(Replace(.Paragraphs(7).Range.Text, Chr(13), ""))
                                    Else
                                        sIsMerged = ""
                                    End If
                                End With
                                If CInt(sID) = I And sIsMerged = "" Then
                                    Cmt.Scope.Select()
                                    RemoveComments()

                                    If Len(App.Selection.Range.Text) > 0 Then
                                        'App.Selection.End = App.ActiveDocument.Bookmarks("\Page").End
                                        App.Selection.Cut()
                                        App.DoEvents
                                        If bFoundFirst = False Then
                                            rng = App.ActiveDocument.Content
                                            rng.InsertParagraphAfter()
                                            rng.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseEnd)
                                            rng.Paste()
                                            rng.Paragraphs(1).Range.Select()
                                            FlagSection(VESections(I))
                                            Cmt = App.ActiveDocument.Comments(App.ActiveDocument.Comments.Count)
                                            Cmt.Author = "PARENT SECTION"
                                            'cmt.Range.InsertAfter vbCrLf & "MERGED"
                                            bFoundFirst = True
                                        Else
                                            If InStr(.MergeStyle, "Collate") > 0 Then
                                                rng = App.ActiveDocument.Content
                                                rng.InsertParagraphAfter()
                                                rng.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseEnd)
                                                rng.Paste()
                                            End If
                                        End If
                                    Else
                                        RemoveComments()
                                    End If
                                    bDone = False
                                    Exit For
                                End If
                            End If
                        Next J
                    End While
                End If
            End With
        Next I
        For J = App.ActiveDocument.Comments.Count To 1 Step -1
            Cmt = App.ActiveDocument.Comments(J)
            If Cmt.Author = "PARENT SECTION" Then
                Cmt.Author = "SECTION"
                Exit For
            End If
        Next J
        App.ActiveDocument.Paragraphs(1).Range.Select()
        App.StatusBar = "Merge Sections - Done"
        App.DoEvents

    End Sub

    Private Function GetDefault(ByVal sType As String) As String
        Dim sReturn As String
        Dim I As Integer

        'ensure VESteps have been loaded
        On Error Resume Next
        I = UBound(VESteps)
        If Err.Number <> 0 Then
            GetSteps(ThisSection.FmtFile)
            Err.Clear()
        End If
        On Error GoTo 0

        sReturn = ""
        For I = 0 To UBound(VESteps)
            If InStr(VESteps(I).Deflt, ";" & sType & ";") Then
                sReturn = CStr(I)
                Exit For
            End If
        Next I
        'sReturn = CStr(I)
        GetDefault = sReturn

    End Function

    Public Sub AddCheckoff(ByRef Cmt As Word.Comment, ByVal sCheckoff As String)
        Dim sAuthor As String
        Dim sMsg As String

        sMsg = ""
        sAuthor = Cmt.Author
        If sAuthor Like "STEP*" Then
            With Cmt.Range
                If .Paragraphs.Count > 2 Then
                    sMsg = Replace(.Paragraphs(1).Range.Text, Chr(13), "")
                    sMsg = sMsg & vbCrLf & Replace(.Paragraphs(2).Range.Text, Chr(13), "")
                    sMsg = sMsg & vbCrLf & Replace(.Paragraphs(3).Range.Text, Chr(13), "")
                End If
                If sMsg <> "" Then
                    If sCheckoff <> "" Then
                        sMsg = sMsg & vbCrLf & sCheckoff
                    End If
                    ModifyComment(Cmt, sMsg)
                End If
            End With
        End If
    End Sub

    Public Function FlagStep(Optional sID As String = "") As String
        Dim I As Integer

        'ensure VESteps have been loaded
        On Error Resume Next
        I = UBound(VESteps)
        If Err.Number <> 0 Then
            GetSteps(ThisSection.FmtFile)
            Err.Clear()
        End If
        On Error GoTo 0

        If sID = "" Then
            Select Case ThisIdent
                Case "NUMBER", "BULLET", "DASH", "PARAGRAPH"
                    If ThisLevel = 1 Then
                        sID = GetDefault("HLS" & ThisIdent)
                    Else
                        sID = GetDefault("SUBSTEP" & ThisIdent)
                    End If
                Case Else
                    sID = GetDefault(ThisIdent)
            End Select
        End If
        I = CInt(sID)

        If I <= UBound(VESteps) Then
            With VESteps(I)
                If .Type = "HLS" Then
                    ThisLevel = 1
                    InsertComment("STEP " & ThisLevel, .Menu & vbCrLf & .FmtFile & "(" & I & ")" & vbCrLf & .Type)
                ElseIf .Type = "Substep" Then
                    InsertComment("STEP " & ThisLevel, .Menu & vbCrLf & .FmtFile & "(" & I & ")" & vbCrLf & .Type)
                ElseIf .Type = "Caution" Then
                    InsertComment("CAUTION", .Menu & vbCrLf & .FmtFile & "(" & I & ")" & vbCrLf & .Type)
                ElseIf .Type = "Note" Then
                    InsertComment("NOTE", .Menu & vbCrLf & .FmtFile & "(" & I & ")" & vbCrLf & .Type)
                End If
            End With
        End If

        FlagStep = sID
    End Function

    Public Sub FlagTable(Optional sID As String = "")
        Dim I As Integer
        Dim J As Integer
        Dim rng As Word.Range

        rng = App.Selection.Range

        If rng.Tables.Count > 0 Then

            'ensure VESteps have been loaded
            On Error Resume Next
            I = UBound(VESteps)
            If Err.Number <> 0 Then
                GetSteps(ThisSection.FmtFile)
                Err.Clear()
            End If
            On Error GoTo 0

            If sID = "" Then
                sID = GetDefault("TABLE")
            End If
            I = CInt(sID)

            If I <= UBound(VESteps) Then
                'RemoveComments
                For J = 1 To rng.Tables.Count
                    rng.Tables(J).Select()

                    With VESteps(I)
                        InsertComment("TABLE", .Menu & vbCrLf & .FmtFile & "(" & sID & ")" & vbCrLf & .Type)
                    End With
                Next J
            End If
        End If

    End Sub

    Public Sub FlagFigure(Optional sID As String = "")
        Dim I As Integer
        Dim rng As Word.Range
        Dim shp As Word.Shape

        rng = App.Selection.Range

        If rng.ShapeRange.Count > 0 Then

            'ensure VESteps have been loaded
            On Error Resume Next
            I = UBound(VESteps)
            If Err.Number <> 0 Then
                GetSteps(ThisSection.FmtFile)
                Err.Clear()
            End If
            On Error GoTo 0

            If sID = "" Then
                sID = GetDefault("FIGURE")
            End If
            I = CInt(sID)

            If I <= UBound(VESteps) Then
                'RemoveComments
                For Each shp In rng.ShapeRange
                    If shp.Type = Office.MsoShapeType.msoPicture Then
                        'this is a picture so flag it as a FIGURE
                        If shp.WrapFormat.Type <> Word.WdWrapType.wdWrapInline Then
                            shp.WrapFormat.Type = Word.WdWrapType.wdWrapInline
                            App.Selection.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseEnd)
                            App.Selection.Paragraphs(1).Format.Alignment = Word.WdParagraphAlignment.wdAlignParagraphCenter
                        End If
                        shp.Select()

                        With VESteps(I)
                            InsertComment("FIGURE", .Menu & vbCrLf & .FmtFile & "(" & sID & ")" & vbCrLf & .Type)
                        End With
                    End If
                Next shp
            End If
        End If

    End Sub


    Public Sub FindShapes()
        Dim shp As Word.Shape
        Dim rng As Word.Range
        Dim tbl As Word.Table
        'Dim iType As Integer
        Dim sHeader As String
        Dim I As Integer

        App.ActiveDocument.Paragraphs(1).Range.Select()
        App.StatusBar = "Find Shapes"

        GetSectionData
        GetSectionRanges

        For I = 0 To UBound(sSecType)
            If UCase(sSecType(I)) = "PROMS" Then
                rng = App.ActiveDocument.Range(lSecStart(I), lSecEnd(I))
                For Each shp In rng.ShapeRange
                    Select Case shp.Type
                        Case Office.MsoShapeType.msoPicture
                            'this is a picture so flag it as a FIGURE
                            If shp.WrapFormat.Type <> Word.WdWrapType.wdWrapInline Then
                                shp.WrapFormat.Type = Word.WdWrapType.wdWrapInline
                                App.Selection.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseEnd)
                                App.Selection.Paragraphs(1).Format.Alignment = Word.WdParagraphAlignment.wdAlignParagraphCenter
                            End If
                            shp.Select()
                            FlagFigure()
                        Case Office.MsoShapeType.msoTextBox
                            'this is a box full of text so see if it is a note/caution or something else we know about
                            sHeader = NameFromShape(shp)
                            If AddColor(sHeader) = True Then
                                'this is a valid item, so convert to a table
                                If shp.WrapFormat.Type <> Word.WdWrapType.wdWrapInline Then
                                    shp.WrapFormat.Type = Word.WdWrapType.wdWrapInline
                                    App.Selection.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseEnd)
                                    App.Selection.Paragraphs(1).Format.Alignment = Word.WdParagraphAlignment.wdAlignParagraphCenter
                                End If
                                shp.TextFrame.TextRange.Copy()
                                shp.Select()
                                App.Selection.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseEnd)
                                tbl = App.ActiveDocument.Tables.Add(App.Selection.Range, 1, 1)
                                tbl.Cell(1, 1).Range.Paste()

                                With tbl.Borders(Word.WdBorderType.wdBorderTop)
                                    .LineStyle = Options.DefaultBorderLineStyle
                                    .LineWidth = Options.DefaultBorderLineWidth
                                    .Color = Options.DefaultBorderColor
                                End With
                                With tbl.Borders(Word.WdBorderType.wdBorderLeft)
                                    .LineStyle = Options.DefaultBorderLineStyle
                                    .LineWidth = Options.DefaultBorderLineWidth
                                    .Color = Options.DefaultBorderColor
                                End With
                                With tbl.Borders(Word.WdBorderType.wdBorderBottom)
                                    .LineStyle = Options.DefaultBorderLineStyle
                                    .LineWidth = Options.DefaultBorderLineWidth
                                    .Color = Options.DefaultBorderColor
                                End With
                                With tbl.Borders(Word.WdBorderType.wdBorderRight)
                                    .LineStyle = Options.DefaultBorderLineStyle
                                    .LineWidth = Options.DefaultBorderLineWidth
                                    .Color = Options.DefaultBorderColor
                                End With
                                shp.Delete()
                            End If
                    End Select
                Next shp
            End If
        Next I

        App.ActiveDocument.Paragraphs(1).Range.Select()
        App.StatusBar = "Find Shapes - Done"

    End Sub

    Public Sub FindStuff()
        'Dim rng As Word.Range
        Dim Cmt As Word.Comment
        Dim sID As String

        App.ActiveDocument.Paragraphs(1).Range.Select()
        App.StatusBar = "Find Other Stuff"

        GetSections
        ThisSection = VESections(0)
        While MoveNext() = True
            If App.Selection.Comments.Count > 0 Then
                Cmt = App.Selection.Comments(1)
                If Cmt.Author = "SECTION" Then
                    sID = LCase(GetCmtValue(Cmt, "ID"))
                    If IsNumeric(sID) Then
                        ThisSection = VESections(CInt(sID))
                    End If
                End If
            ElseIf ThisSection.Type = "PROMS" Then
                If App.Selection.Comments.Count = 0 Then
                    WhatIsThis()
                End If
            Else
                Cmt = MoveToNextComment("SECTION")
                If Not Cmt Is Nothing Then
                    sID = LCase(GetCmtValue(Cmt, "ID"))
                    If IsNumeric(sID) Then
                        ThisSection = VESections(CInt(sID))
                    End If
                Else
                    Exit Sub
                End If
            End If
        End While

        App.ActiveDocument.Paragraphs(1).Range.Select()
        App.StatusBar = "Find Other Stuff - Done"

    End Sub

    Public Sub FindSteps()
        Dim rng As Word.Range
        Dim C As Word.Cell
        Dim tbl As Word.Table
        'Dim fld As Word.Field
        ' Dim sText As String
        Dim sIdent As String
        Dim sLevel As String
        'Dim sID As String
        'Dim sType As String
        Dim FirstIdent(9) As String
        Dim FirstLevel(9) As String
        Dim FirstID(9) As String
        Dim I As Integer
        Dim J As Integer
        Dim K As Integer
        Dim bDone As Boolean
        Static LastMargin As Single
        Static LastLevel As Integer

        GetSections
        GetSectionData

        App.ActiveDocument.Paragraphs(1).Range.Select()
        App.StatusBar = "Find Steps"

        For J = 0 To UBound(sSecType)
            If UCase(sSecType(J)) = "PROMS" Then
                ThisSection = VESections(iSecID(J))
                GetSectionRanges
                rng = App.ActiveDocument.Range(lSecStart(J), lSecEnd(J))
                LastMargin = rng.Paragraphs(1).Range.ParagraphFormat.LeftIndent
                If ThisSection.ColumnMode = "2" Then
                    For K = 1 To rng.Tables.Count
                        tbl = rng.Tables(K)
                        With tbl.Range
                            For Each C In .Cells
                                C.Range.Select()
                                App.Selection.Collapse(Direction:=Word.WdCollapseDirection.wdCollapseStart)
                                For I = 1 To 9
                                    bDone = True
                                    App.StatusBar = "Find Steps - Level " & I
                                    LastLevel = 0
                                    FirstIdent(I) = ""
                                    FirstLevel(I) = ""
                                    While MoveNextCellPara(C) = True
                                        If App.Selection.Comments.Count > 0 Then
                                            If App.Selection.Comments(1).Author = "STEP " & CStr(I - 1) Then
                                                'previous level found so reset data for this level
                                                LastMargin = App.Selection.Paragraphs(1).Range.ParagraphFormat.LeftIndent
                                                LastLevel = I - 1
                                                FirstIdent(I) = ""
                                                FirstLevel(I) = ""
                                            End If
                                        Else
                                            sIdent = GetIdent(App.Selection.Range)
                                            Select Case sIdent
                                                Case "IGNORE"
                                                    InsertComment("IGNORE")
                                                Case "NUMBER", "BULLET", "DASH", "PARAGRAPH"
                                                    sLevel = GetLevelStep(App.Selection.Range, LastMargin, LastLevel, I)
                                                    If FirstIdent(I) = "" Then
                                                        FirstIdent(I) = sIdent
                                                        FirstLevel(I) = sLevel
                                                        ThisLevel = I
                                                        ThisIdent = sIdent
                                                        FirstID(I) = FlagStep()
                                                    ElseIf sIdent = FirstIdent(I) And sLevel = FirstLevel(I) Then
                                                        FlagStep(FirstID(I))
                                                    End If
                                                    bDone = False
                                            End Select
                                        End If
                                    End While
                                    If bDone = True Then
                                        Exit For
                                    End If
                                Next I
                            Next C
                        End With
                    Next K
                Else
                    For I = 1 To 9
                        bDone = True
                        App.StatusBar = "Find Steps - Level " & I
                        LastLevel = 0
                        FirstIdent(I) = ""
                        FirstLevel(I) = ""
                        rng.Paragraphs(1).Range.Select()

                        While MoveNext() = True And (App.Selection.Start < lSecEnd(J))
                            If App.Selection.Comments.Count > 0 Then
                                If App.Selection.Comments(1).Author = "STEP " & CStr(I - 1) Then
                                    'previous level found so reset data for this level
                                    LastMargin = App.Selection.Paragraphs(1).Range.ParagraphFormat.LeftIndent
                                    LastLevel = I - 1
                                    FirstIdent(I) = ""
                                    FirstLevel(I) = ""
                                End If
                            Else
                                If App.Selection.Information(Word.WdInformation.wdWithInTable) = True Then
                                    'do nothing
                                ElseIf App.Selection.Information(word.WdInformation.wdInFieldCode) = True Then
                                    'do nothing
                                ElseIf App.Selection.Information(word.WdInformation.wdInFieldResult) = True Then
                                    'do nothing
                                Else
                                    sIdent = GetIdent(App.Selection.Range)
                                    Select Case sIdent
                                        Case "IGNORE"
                                            InsertComment("IGNORE")
                                        Case "NUMBER", "BULLET", "DASH", "PARAGRAPH"
                                            sLevel = GetLevelStep(App.Selection.Range, LastMargin, LastLevel)
                                            If FirstIdent(I) = "" Then
                                                FirstIdent(I) = sIdent
                                                FirstLevel(I) = sLevel
                                                ThisLevel = I
                                                ThisIdent = sIdent
                                                FirstID(I) = FlagStep()
                                            ElseIf sIdent = FirstIdent(I) And sLevel = FirstLevel(I) Then
                                                FlagStep(FirstID(I))
                                            End If
                                            bDone = False
                                    End Select
                                End If
                            End If
                        End While
                        If bDone = True Then
                            Exit For
                        End If
                    Next I
                End If
            End If
        Next J

        App.ActiveDocument.Paragraphs(1).Range.Select()
        App.StatusBar = "Find Steps - Done"
    End Sub


    Public Sub FindItems(Optional App.SelectionOnly As Boolean = False)
        Dim rng As Word.Range
        Dim rngText As Word.Range
        'Dim para As Word.Paragraph
        Dim sParaText As String
        Dim sIdent As String
        Dim sSep As String
        Dim iLevel As Integer
        Dim bDone As Boolean
        Dim iPara As Integer
        Dim TheEnd As Long


        If App.SelectionOnly = True Then
            'limit search to the end of current selection
            TheEnd = App.Selection.Paragraphs(App.Selection.Paragraphs.Count).Range.End
            App.Selection.Paragraphs(1).Range.Select
        Else
            'search to the end of the document
            TheEnd = App.ActiveDocument.Paragraphs(App.ActiveDocument.Paragraphs.Count).Range.End
            App.ActiveDocument.Paragraphs(1).Range.Select
        End If

        With App.Selection
            .Collapse(Direction:=Word.WdCollapseDirection.wdCollapseStart)

            bDone = False

            While bDone = False
                'move past table
                .Collapse(Direction:=Word.WdCollapseDirection.wdCollapseEnd)
                .MoveStart(unit:=Word.WdUnits.wdCharacter, Count:=1)
                .Paragraphs(1).Range.Select

                rng = .Range
                rng.End = TheEnd
                bDone = True
                iPara = 1
                Do While iPara <= rng.Paragraphs.Count
                    rngText = rng.Paragraphs(iPara).Range
                    rngText.End = rngText.End - 1
                    rngText.Select()
                    sParaText = CleanText(.text)
                    If .Information(Word.WdInformation.wdWithInTable) = True Then
                        If .Tables(1).rows.Count = 1 And .Tables(1).Columns.Count = 1 Then
                            'Note/Caution/Warning
                            NoteFromTable(rngText.Tables(1))
                            rngText.Tables(1).Select()
                            bDone = False
                            Exit Do
                        Else
                            'imbedded table has been found
                            rngText.Tables(1).Select()
                            'InsertComment "TABLE"
                            FlagTable()
                            bDone = False
                            Exit Do
                        End If
                    ElseIf rngText.Information(Word.WdInformation.wdInFieldCode) = True Then
                        'do nothing
                    ElseIf rngText.Information(Word.WdInformation.wdInFieldResult) = True Then
                        'do nothing
                    ElseIf sParaText <> "" Then
                        sIdent = GetIdent(rng.Paragraphs(iPara).Range)
                        If sIdent <> "" Then
                            'do not automatically flag unnumbered paragraphs
                            'iLevel = GetLevel(rng.Paragraphs(iPara).Range)
                            If iPara < rng.Paragraphs.Count Then
                                sSep = GetSep(rng.Paragraphs(iPara + 1).Range)
                            Else
                                sSep = ""
                            End If
                            rng.Paragraphs(iPara).Range.Select()
                            'InsertComment "STEP " & iLevel & " " & sSep, sIdent
                            ThisLevel = iLevel
                            FlagStep()
                        End If
                    End If
                    iPara = iPara + 1
                Loop
            End While
        End With

    End Sub

    Public Function GetIdent(ByVal para As Word.Range, Optional ByRef sNewTag As String = "") As String
        Dim sTag As String
        Dim sIdent As String
        Dim sParaText As String
        Dim I As Integer

        sNewTag = ""
        sParaText = CleanText(para.Text)
        If CanIgnore(sParaText) = True Then
            sIdent = "IGNORE"
        Else

            With para
                sTag = .ListFormat.ListString
                If sTag = "" Then
                    'not automatic numbering, so find the step number
                    For I = 1 To Len(sParaText)
                        If InStr(" " & Chr(9) & Chr(11) & Chr(13), Mid(.Text, I, 1)) > 0 Then
                            'searh up to the first space, tab, line feed or paragraph
                            Exit For
                        End If
                        sTag = sTag & Mid(.Text, I, 1)
                    Next I
                End If
            End With

            sTag = Replace(sTag, "[", "")
            sTag = Replace(sTag, "]", "")

            On Error Resume Next
            I = UBound(VESections)
            If Err.Number <> 0 Then
                GetSections
                Err.Clear()
            End If
            On Error GoTo 0

            If InStr(1, sParaText, "Operational") > 0 Then
                sParaText = sParaText
            End If

            For I = 0 To UBound(VESections)
                If sTag <> "" Then
                    If VESections(I).number <> "" Then
                        If sTag = VESections(I).number Then
                            'tag matches a section number setting
                            If sParaText = VESections(I).Title Then
                                'section title matches paragraph text
                                sIdent = "SECTION"
                                ThisSection = VESections(I)
                                Exit For
                            End If
                        End If
                    End If
                End If
            Next I
            If sIdent = "" Then
                For I = 0 To UBound(VESections)
                    If sTag <> "" Then
                        If VESections(I).number <> "" Then
                            If sTag Like VESections(I).number & "*" Then
                                'tag matches a section number setting
                                If sParaText Like VESections(I).Title & "*" Then
                                    'section title matches paragraph text
                                    sIdent = "SECTION"
                                    ThisSection = VESections(I)
                                    Exit For
                                End If
                            End If
                        End If
                    End If
                Next I
            End If
            If sIdent = "" Then
                For I = 0 To UBound(VESections)
                    If sTag <> "" Then
                        If VESections(I).number <> "" Then
                            If sTag Like VESections(I).number & "*" Then
                                If RegExMatch(sParaText, VESections(I).Pattern) = True Then
                                    sIdent = "SECTION"
                                    ThisSection = VESections(I)
                                    Exit For
                                End If
                            End If
                        End If
                    End If
                Next I
            End If
            If sIdent = "" Then
                For I = 0 To UBound(VESections)
                    If sTag <> "" Then
                        If VESections(I).number = "" Then
                            If RegExMatch(sTag, VESections(I).Pattern) = True Then
                                sIdent = "SECTION"
                                ThisSection = VESections(I)
                                Exit For
                            End If
                        End If
                    End If
                Next I
            End If
            If sIdent = "" Then
                If Len(sTag) > 0 Then
                    If sTag = "-" Then
                        sIdent = "DASH"
                    ElseIf sTag Like "[!A-Za-z0-9]" Then
                        sIdent = "BULLET"
                    ElseIf UCase(sTag) = "NOTE" Then
                        sIdent = "NOTE"
                    ElseIf UCase(sTag) = "CAUTION" Then
                        sIdent = "CAUTION"
                    ElseIf UCase(sTag) = "WARNING" Then
                        sIdent = "WARNING"
                    ElseIf InStr(sTag, ".") + InStr(sTag, ")") = 0 Then
                        sIdent = "PARAGRAPH"
                    Else
                        sIdent = "NUMBER"
                    End If
                End If
            ElseIf sIdent = "SECTION" Then
                If ThisSection.ChangeNumber Then
                    sNewTag = sTag
                End If
            End If
        End If

        GetIdent = sIdent

    End Function

    Public Function GetIdentOLD(ByVal para As Word.Range, Optional ByRef sNewTag As String = "") As String
        Dim sTag As String
        Dim sIdent As String
        Dim sParaText As String
        Dim I As Integer

        sNewTag = ""
        sParaText = CleanText(para.Text)
        If CanIgnore(sParaText) = True Then
            sIdent = "IGNORE"
        Else
            With para
                sTag = .ListFormat.ListString
                If sTag = "" Then
                    'not automatic numbering, so find the step number
                    For I = 1 To Len(sParaText)
                        If InStr(" " & Chr(9) & Chr(11) & Chr(13), Mid(.Text, I, 1)) > 0 Then
                            'searh up to the first space, tab, line feed or paragraph
                            Exit For
                        End If
                        sTag = sTag & Mid(.Text, I, 1)
                    Next I
                End If
            End With

            sTag = Replace(sTag, "[", "")
            sTag = Replace(sTag, "]", "")

            On Error Resume Next
            I = UBound(VESections)
            If Err.Number <> 0 Then
                GetSections
                Err.Clear()
            End If
            On Error GoTo 0

            For I = 0 To UBound(VESections)
                If RegExMatch(sTag & sParaText, VESections(I).Pattern) = True Then
                    sIdent = "SECTION"
                    ThisSection = VESections(I)
                    Exit For
                ElseIf RegExMatch(sTag, VESections(I).Pattern) = True Then
                    sIdent = "SECTION"
                    ThisSection = VESections(I)
                    ThisSection.number = sTag
                    Exit For
                ElseIf VESections(I).number <> "" Then
                    If sTag = VESections(I).number Then
                        'tag matches a section number setting
                        If VESections(I).Title = "" Then
                            sIdent = "SECTION"
                            ThisSection = VESections(I)
                            Exit For
                        Else
                            'If InStr(para.Text, VESections(I).Title) > 0 Then
                            If sParaText Like VESections(I).Title & "*" Then
                                'section title is found in the paragraph text
                                sIdent = "SECTION"
                                ThisSection = VESections(I)
                                Exit For
                            End If
                        End If
                    End If
                ElseIf VESections(I).Title = "" Then
                    'untitled section such as Attachment
                    If VESections(I).number <> "" Then
                        If sTag = VESections(I).number Then
                            sIdent = "SECTION"
                            ThisSection = VESections(I)
                            Exit For
                        End If
                    End If
                ElseIf VESections(I).number = "" Then
                    'section has no number
                    If VESections(I).Title <> "" Then
                        'and section has title
                        'If InStr(para.Text, VESections(I).Title) > 0 Then
                        If sParaText Like VESections(I).Title & "*" Then
                            'section title is found in the paragraph text
                            sIdent = "SECTION"
                            ThisSection = VESections(I)
                            Exit For
                        End If
                    End If
                End If

            Next I

            If sIdent = "" Then
                If Len(sTag) > 0 Then
                    If sTag = "-" Then
                        sIdent = "DASH"
                    ElseIf sTag Like "[!A-Za-z0-9]" Then
                        sIdent = "BULLET"
                    ElseIf UCase(sTag) = "NOTE" Then
                        sIdent = "NOTE"
                    ElseIf UCase(sTag) = "CAUTION" Then
                        sIdent = "CAUTION"
                    ElseIf UCase(sTag) = "WARNING" Then
                        sIdent = "WARNING"
                    ElseIf InStr(sTag, ".") + InStr(sTag, ")") = 0 Then
                        sIdent = "PARAGRAPH"
                    Else
                        sIdent = "NUMBER"
                    End If
                End If
            ElseIf sIdent = "SECTION" Then
                If ThisSection.number = "" Then
                    sNewTag = sTag
                End If
            End If
        End If

        GetIdentOLD = sIdent

    End Function

    Private Function CanIgnore(ByVal sText As String) As Boolean
        Dim bReturn As Boolean
        Dim I As Integer

        bReturn = False

        For I = 0 To UBound(IgnoreMe)
            If IgnoreMe(I) <> "" Then
                If RegExMatch(sText, IgnoreMe(I)) = True Then
                    bReturn = True
                    Exit For
                End If
            End If
        Next I

        CanIgnore = bReturn
    End Function

    Public Sub GetSection()
        Dim R1 As Word.Range
        Dim R2 As Word.Range
        Dim sID As String

        'Exit Sub

        R1 = GetComment(App.Selection.Range)
        If Not R1 Is Nothing Then
            If R1.Comments(1).Author = "SECTION" Then
                sID = R1.Paragraphs(R1.Paragraphs.Count).Range.Text
            End If
        End If

        If sID = "" Then
            If App.Selection.Information(Word.WdInformation.wdInCommentPane) = True Then
                R1 = App.Selection.Range.Comments(1).Scope
            Else
                R1 = App.ActiveDocument.Range(App.Selection.Start, App.Selection.End)
            End If

            R2 = R1.GoTo(What:=Word.WdGoToItem.wdGoToComment, Which:=Word.WdGoToDirection.wdGoToPrevious, Name:="SECTION")
            R1 = GetComment(R2)
            If Not R1 Is Nothing Then
                sID = R1.Paragraphs(R1.Paragraphs.Count).Range.Text
            End If
        End If

        If sID <> ThisSection.ID Then
            If IsNumeric(sID) Then
                ThisSection = VESections(CInt(sID))
            End If
        End If
    End Sub
    Private Function GetLevelStep(ByVal para As Word.Range, ByRef LastMargin As Single, ByRef LastLevel As Integer, Optional StartAt As Integer = 0) As Integer
        Dim sTag As String
        Dim dL As Integer   'change in level
        Dim iLevel As Integer
        Dim sngMargin As Single

        sngMargin = para.ParagraphFormat.LeftIndent
        iLevel = GetLevelByDef(para, StartAt)

        If iLevel = 0 Then
            With para
                sTag = .ListFormat.ListString
                If sTag = "" Then
                    sTag = .Words(1).Text
                End If

                If sTag Like "*.0" Then
                    dL = 1
                ElseIf sTag Like "*#" Then
                    dL = Len(sTag) - Len(Replace(sTag, ".", ""))
                    dL = dL + Len(sTag) - Len(Replace(sTag, ")", ""))
                    dL = dL - LastLevel
                    'If dL < -1 Then dL = -1
                    If dL > 1 Then dL = 1
                Else
                    'iLevel = .ListFormat.ListLevelNumber
                    If sngMargin > LastMargin Then
                        dL = 1
                    ElseIf sngMargin < LastMargin Then
                        dL = -1
                    Else
                        dL = 0
                    End If
                End If
            End With
            iLevel = LastLevel + dL
        Else
            iLevel = iLevel - ThisSection.StepOffset
        End If

        LastMargin = sngMargin
        LastLevel = iLevel

        GetLevelStep = iLevel

    End Function

    Private Function GetLevelPara(ByVal para As Word.Range, ByRef LastMargin As Single, ByRef LastLevel As Integer) As Integer
        Dim dL As Integer   'change in level
        Dim iLevel As Integer
        Dim sngMargin As Single

        sngMargin = para.ParagraphFormat.LeftIndent

        If sngMargin > LastMargin Then
            dL = 1
        ElseIf sngMargin < LastMargin Then
            dL = -1
        Else
            dL = 0
        End If

        LastMargin = sngMargin

        iLevel = LastLevel + dL
        LastLevel = iLevel


        LastMargin = sngMargin
        LastLevel = iLevel

        GetLevelPara = iLevel

    End Function

    Public Function RegExMatch(ByVal myString As String, ByVal myPattern As String) As Boolean
        Dim bReturn As Boolean
        Dim oRE As RegExp

        On Error Resume Next

        bReturn = False
        If myPattern <> "" Then
            oRE = New RegExp
            oRE.IgnoreCase = False
            oRE.Global = False
            oRE.Pattern = myPattern

            bReturn = oRE.Test(myString)
        End If

        RegExMatch = bReturn

    End Function

    Private Function GetLevelByDef(ByVal para As Word.Range, ByVal StartAt As Integer) As Integer
        Dim sTemp As String
        Dim I As Integer
        Dim J As Integer
        Dim iReturn As Integer

        iReturn = 0

        'On Error Resume Next

        sTemp = para.ListFormat.ListString
        If sTemp = "" Then
            sTemp = para.Text
        Else
            sTemp = sTemp & Chr(9) & para.Text
        End If

        With ThisSection.StepStyle
            J = UBound(.LevelDefs)
            For I = StartAt To UBound(.LevelDefs)
                If RegExMatch(sTemp, .LevelDefs(I).Def) = True Then
                    iReturn = .LevelDefs(I).Level
                    Exit For
                End If
            Next I
        End With

        GetLevelByDef = iReturn

    End Function

    Private Function GetSep(ByVal para As Word.Range) As String
        Dim sSep As String
        Dim sTextAfter As String
        Dim sTextBefore As String
        Dim I As Integer

        If para.Previous(Unit:=Word.WdUnits.wdParagraph, Count:=1).Words.Count < 3 Then
            sTextBefore = para.Previous(Unit:=Word.WdUnits.wdParagraph, Count:=1).Text
            sTextBefore = Replace(sTextBefore, Chr(9), "")
            sTextBefore = Replace(sTextBefore, Chr(11), "")
            sTextBefore = Replace(sTextBefore, Chr(13), "")
        Else
            sTextBefore = ""
        End If
        If para.Next(Unit:=Word.WdUnits.wdParagraph, Count:=1).Words.Count < 3 Then
            sTextAfter = para.Next(Unit:=Word.WdUnits.wdParagraph, Count:=1).Text
            sTextAfter = Replace(sTextAfter, Chr(9), "")
            sTextAfter = Replace(sTextAfter, Chr(11), "")
            sTextAfter = Replace(sTextAfter, Chr(13), "")
        Else
            sTextAfter = ""
        End If

        sSep = ""
        GetSeparators
        For I = 0 To UBound(Separators)
            If Separators(I) <> "" Then
                If (sTextBefore Like "*" & Separators(I) & "*") Or (sTextAfter Like "*" & Separators(I) & "*") Then
                    sSep = Separators(I)
                    Exit For
                End If
            End If
        Next I

        GetSep = sSep

    End Function

    Public Function MoveNext(Optional SearchRange As Word.Range) As Boolean
        Dim bReturn As Boolean
        Dim rng As Word.Range

        If SearchRange Is Nothing Then
            SearchRange = App.ActiveDocument.Content
        End If

        With App.Selection
            'move out of comment into main story
            If .Information(wdInCommentPane) Then
                .Comments(1).Scope.Select()
            End If

            'save location of original selection
            rng = .Range.Duplicate

            If .End < SearchRange.End Then
                If .Information(wdWithInTable) = True Then
                    .Collapse Direction:=wdCollapseEnd
                .Expand Unit:=wdParagraph
            Else
                    '.Collapse Direction:=wdCollapseStart
                    '.Move unit:=wdParagraph, Count:=1
                    .Collapse Direction:=wdCollapseEnd
                .Move Unit:=wdCharacter, Count:=1
                .Expand Unit:=wdParagraph
            End If

                'don't get stuck in a field code, such as TOC
                If .Information(wdInFieldCode) = True Or .Information(wdInFieldResult) = True Then
                    While .Information(wdInFieldCode) = True Or .Information(wdInFieldResult) = True
                        .Move Unit:=wdParagraph, Count:=1
                End While
                    .Collapse Direction:=wdCollapseStart
                .Expand Unit:=wdParagraph
            End If

                If .Information(wdWithInTable) = True Then
                    .Expand Unit:=wdTable
            Else
                    .Expand Unit:=wdParagraph
                'skip over blank paragraphs
                    Do While (.Range.Text = Chr(13)) And (.End < App.ActiveDocument.Content.End)
                        If .Move(Unit:=wdParagraph, Count:=1) = 0 Then
                            Exit Do
                        End If
                        .Expand Unit:=wdParagraph
                Loop
                    Do While (.Range.Characters(1) = Chr(12)) And (.Start < .End)
                        .Start = .Start + 1
                    Loop

                End If
                If rng.Start = .Start And rng.End = .End Then
                    'new selection is same as old selection
                    bReturn = False
                Else
                    'something new has been selected
                    bReturn = True
                End If
            Else
                bReturn = False
            End If

            ActiveWindow.ScrollIntoView.Range
            DoEvents
        End With

        MoveNext = bReturn

    End Function

    Public Function MoveNextCellPara(ByRef C As Cell) As Boolean
        Dim bReturn As Boolean
        Dim rng As Range

        If Not C Is Nothing Then
            With App.Selection
                'save location of original selection
                rng = .Range.Duplicate

                If .End < C.Range.End Then
                    '.Collapse Direction:=wdCollapseStart
                    '.Move unit:=wdParagraph, Count:=1
                    .Collapse Direction:=wdCollapseEnd
                .Move Unit:=wdCharacter, Count:=1
                .Expand Unit:=wdParagraph

                'skip over blank paragraphs
                    Do While (.Range.Text = vbCr) And (.End < C.Range.End)
                        If .Move(Unit:=wdParagraph, Count:=1) = 0 Then
                            Exit Do
                        End If
                    Loop
                    Do While (.Range.Characters(1) = Chr(12)) And (.Start < .End)
                        .Start = .Start + 1
                    Loop

                    'move back from end of cell marker
                    Do While .Paragraphs.Count > 1 And (.Start < .End)
                        .End = .End - 1
                    Loop

                    'move start past any field codes
                    Do While (.Range.Characters(1).Information(wdInFieldCode) = True Or .Range.Characters(1).Information(wdInFieldResult) = True) And (.Start < .End)
                        .Start = .Start + 1
                    Loop

                    If rng.Start = .Start And rng.End = .End Then
                        'new selection is same as old selection
                        bReturn = False
                    Else
                        'something new has been selected
                        bReturn = True
                    End If
                Else
                    bReturn = False
                End If

                ActiveWindow.ScrollIntoView.Range
                DoEvents
            End With
        Else
            bReturn = False
        End If

        MoveNextCellPara = bReturn

    End Function

    Public Function MovePrevious(Optional SelectCmt As Boolean = False) As Boolean
        Dim bReturn As Boolean
        Dim rng As Range

        With App.Selection
            rng = .Range.Duplicate
            If .Information(wdInCommentPane) Then
                .Comments(1).Scope.Select()
            End If
            If .Start > App.ActiveDocument.Content.Start Then
                .Collapse Direction:=wdCollapseStart
            .Move Unit:=wdParagraph, Count:=-1
            .Expand Unit:=wdParagraph
            While .Information(wdWithInTable) = False And .Range.Text = Chr(13)
                    .Move Unit:=wdParagraph, Count:=-2
                .Expand Unit:=wdParagraph
            End While
                If .Information(wdWithInTable) = True Then
                    .Expand Unit:=wdTable
            End If
            End If
            If rng.Start = .Start And rng.End = .End Then
                bReturn = False
            Else
                bReturn = True
            End If
            ActiveWindow.ScrollIntoView.Range
        End With
        If SelectCmt Then
            GoToComment()
        End If
        MovePrevious = bReturn

    End Function

    Public Sub WhatIsThis()
        Dim sParaText As String
        Dim sIdent As String
        Static LastMargin As Single
        Static LastLevel As Integer

        With App.Selection
            If .Information(wdWithInTable) = True Then
                If .Tables(1).Rows.Count = 1 And .Tables(1).Columns.Count = 1 Then
                    'Note/Caution/Warning
                    NoteFromTable.Tables(1)
                Else
                    'imbedded table has been found
                    'InsertComment "TABLE"
                    FlagTable()
                End If
            ElseIf .Information(wdFrameIsSelected) = True Then
                FlagFigure()
            ElseIf .Information(wdInFieldCode) = True Then
                'do nothing
            ElseIf .Information(wdInFieldResult) = True Then
                'do nothing
            Else
                'sParaText = CleanText(.Text)
                'If (sParaText <> "") Then
                sIdent = GetIdent(.Range)
                Select Case sIdent
                    Case "IGNORE"
                        InsertComment "IGNORE"
                    Case "NOTE", "CAUTION"
                        ThisIdent = sIdent
                        FlagStep()
                End Select
                'End If
            End If
        End With

    End Sub

    Private Function NameFromShape(ByVal shp As Shape) As String
        'Mark a text box shape as a Note/Caution/Warning
        Dim sReturn As String   'Note/Caution/Warning/Hold

        With shp.TextFrame.TextRange
            sReturn = CleanText(.Paragraphs(1).Range.Text)
            If InStr(sReturn, " ") > 0 Then
                sReturn = Left(sReturn, InStr(sReturn, " ") - 1)
            End If
            sReturn = UCase(sReturn)
            If Right(sReturn, 1) = "S" Then
                sReturn = Left(sReturn, Len(sReturn) - 1)
            End If
        End With

        NameFromShape = sReturn

    End Function

    Private Sub NoteFromTable(ByVal tbl As Table)
        'Mark text within a Word table (tbl) as a Note/Caution/Warning/Hold
        Dim sHeader As String   'Note/Caution/Warning/Hold
        Dim sID As String
        Dim rng As Range
        Dim LeftMargin As Single
        Dim iStart As Long
        Dim iEnd As Long
        Dim I As Integer

        With tbl.Range
            If .Paragraphs.Count > 1 Then
                sHeader = CleanText(.Paragraphs(1).Range.Text)
                sHeader = Replace(sHeader, " ", "")
                sHeader = UCase(sHeader)

                If Right(sHeader, 1) = "S" Then
                    sHeader = Left(sHeader, Len(sHeader) - 1)
                End If
                sID = GetDefault(sHeader)
                If sID <> "" Then

                    .Select()
                    RemoveComments()

                    LeftMargin = .Paragraphs(2).Range.ParagraphFormat.LeftIndent

                    .Paragraphs(2).Range.Select()
                    App.Selection.MoveEndWhile Cset:=Chr(13) & Chr(7), Count:=wdBackward
                App.Selection.Start = .Paragraphs(2).Range.Start

                    For I = 3 To .Paragraphs.Count - 1
                        If Len(.Paragraphs(I).Range.Text) > 2 Then
                            'this para has text

                            If .Paragraphs(I).Range.ParagraphFormat.LeftIndent > LeftMargin Then
                                'substep of note found so include it in previous selection
                                iStart = App.Selection.Start
                                App.Selection.End = .Paragraphs(I).Range.End
                                App.Selection.MoveEndWhile Cset:=Chr(13) & Chr(7), Count:=wdBackward
                            App.Selection.Start = iStart
                            Else
                                'new note found, so save the previous note
                                If Len(App.Selection.Text) > 1 Then
                                    FlagStep sID
                            End If
                                'select the new note
                                .Paragraphs(I).Range.Select()
                                App.Selection.MoveEndWhile Cset:=Chr(13) & Chr(7), Count:=wdBackward
                            App.Selection.Start = .Paragraphs(I).Range.Start
                            End If
                        Else
                            'blank paragraph found, so save previous note
                            If Len(App.Selection.Text) > 1 Then
                                FlagStep sID
                        End If
                            If I < .Paragraphs.Count Then
                                'move selection to start of next paragraph
                                App.Selection.Start = .Paragraphs(I + 1).Range.Start
                                App.Selection.End = App.Selection.Start
                            End If
                        End If
                    Next I
                    If Len(App.Selection.Text) > 1 Then
                        FlagStep sID
                End If
                End If
            End If
        End With

        tbl.Select()

    End Sub


    Private Function ConvertTableDef(ByVal tbl As Table) As String
        'Converts a Word table (tbl) to an XML string
        Dim sReturn As String   'string returned from this function
        Dim sTemp As String     'string used for temporary storage
        Dim sXML As String      'XML string being created
        Dim iRow As Integer     'active index into table rows collection
        Dim iCol As Integer     'active index into table columns collection
        Dim I As Integer        'counter

        Dim cw As Single        'temporary value of cell width
        Dim w As Single         'temporary value of cell width
        Dim Wcol() As Single    'width of each column in table
        Dim Wcell() As Integer  'width of each cell in table
        Dim spanC() As Integer  'column span
        Dim spanR() As Integer  'row span
        Dim MergeCount As Integer   'count of merged cells

        'ignore errors if any cell is undefined
        On Error Resume Next

        'size valriables to match table row and column dimensions
        ReDim Wcol(tbl.Columns.Count)
        ReDim Wcell(tbl.Rows.Count, tbl.Columns.Count)
        ReDim spanC(tbl.Rows.Count, tbl.Columns.Count)
        ReDim spanR(tbl.Rows.Count, tbl.Columns.Count)


        For iCol = 1 To tbl.Columns.Count
            Wcol(iCol) = tbl.Columns.Width
            For iRow = 1 To tbl.Rows.Count
                'start with a width of zero
                w = 0
                'if cell is undefined this next line will error but w will remain equal to zero
                w = tbl.Cell(iRow, iCol).Width

                'convert points to pixels
                Wcell(iRow, iCol) = Int((w * 8) / 6)

                cw = Wcol(iCol)
                cw = tbl.Cell(iRow, iCol).Width

                'convert points to pixels
                cw = Int((cw * 8) / 6)

                If Wcol(iCol) > 0 Then
                    If cw < Wcol(iCol) Then
                        Wcol(iCol) = cw
                    End If
                Else
                    Wcol(iCol) = cw
                End If
            Next iRow
        Next iCol

        'roll up column spans
        For iRow = 1 To tbl.Rows.Count
            MergeCount = 1
            For iCol = tbl.Columns.Count To 1 Step -1
                If Wcell(iRow, iCol) > 0 Then
                    'this is a valid cell
                    If Wcell(iRow, iCol) - Wcol(iCol) > 0 Then
                        'this cell spans more than one column so set its span to mergecount
                        spanC(iRow, iCol) = MergeCount
                    End If
                    While MergeCount > 1
                        'flag merged cells cells so they are not merged vertically
                        MergeCount = MergeCount - 1
                        spanC(iRow, iCol + MergeCount) = 1
                    End While
                    spanC(iRow, iCol) = 1
                    MergeCount = 1
                Else
                    'cell is undefined so add it to mergecount
                    MergeCount = MergeCount + 1
                    'flag this cell as capable of vertical merging
                    spanC(iRow, iCol) = 0
                End If
            Next iCol
        Next iRow

        'roll up row spans
        For iCol = 1 To tbl.Columns.Count
            MergeCount = 1
            For iRow = tbl.Rows.Count To 1 Step -1
                If spanC(iRow, iCol) = 0 Then
                    'cell is undefined and not merged horizontally so add it to mergecount
                    MergeCount = MergeCount + 1
                Else
                    'cell is valid so set its span
                    spanR(iRow, iCol) = MergeCount
                    MergeCount = 1
                End If
            Next iRow
        Next iCol

        'build xml for this table
        sXML = "<table>"
        For iRow = 1 To tbl.Rows.Count
            sXML = sXML & "<tr>"
            For iCol = 1 To tbl.Columns.Count
                With tbl.Cell(iRow, iCol)
                    If Wcell(iRow, iCol) <> 0 Then
                        sXML = sXML & "<td"
                        If spanR(iRow, iCol) > 1 Then
                            sXML = sXML & " rowspan=" & Chr(34) & spanR(iRow, iCol) & Chr(34)
                        ElseIf spanC(iRow, iCol) > 1 Then
                            sXML = sXML & " colspan=" & Chr(34) & spanC(iRow, iCol) & Chr(34)
                        ElseIf Wcol(iCol) > 0 Then
                            sXML = sXML & " width=" & Chr(34) & Wcol(iCol) & Chr(34)
                            Wcol(iCol) = Wcol(iCol) * -1
                        End If
                        sXML = sXML & ">"

                        For I = 1 To .Range.Paragraphs.Count
                            sTemp = .Range.Paragraphs(I).Range.Text
                            sTemp = CleanText(sTemp)
                            If sTemp <> "" Then
                                sXML = sXML & "<p>" & sTemp & "</p>"
                            End If
                        Next I
                        sXML = sXML & "</td>"
                    End If
                End With
            Next iCol
            sXML = sXML & "</tr>"
        Next iRow
        sXML = sXML & "</table>"

        sReturn = sXML

        ConvertTableDef = sReturn
    End Function

    Private Function CleanText(ByVal sText As String, Optional MarkLineFeed As Boolean = False) As String
        Dim sReturn As String

        sReturn = sText

        sReturn = Replace(sReturn, Chr(7), "@")     'tab
        sReturn = Replace(sReturn, Chr(13), "@")    'paragraph mark

        'check mark in parenthesis
        sReturn = Replace(sReturn, "(" & ChrW(-4016) & ")", "(&#x2713)")
        'hard hyphen to regular hyphen
        sReturn = Replace(sReturn, Chr(30), Chr(45))
        'line feed
        sReturn = Replace(sReturn, Chr(12), "")
        sReturn = Replace(sReturn, Chr(11), "")
        'hard space
        sReturn = Replace(sReturn, Chr(160), " ")

        'strip off signature lines
        sReturn = Replace(sReturn, vbTab & "Initials", "")
        sReturn = Replace(sReturn, "Initials", "")
        sReturn = Replace(sReturn, vbTab & "Initial", "")
        sReturn = Replace(sReturn, "Initial", "")
        sReturn = Replace(sReturn, vbTab & "_", "")
        sReturn = Replace(sReturn, "_", "")

        'always remove markers at end of text
        While Right(sReturn, 1) = "@"
            sReturn = Left(sReturn, Len(sReturn) - 1)
        End While

        'if desired flag internal markers with forward slash
        If MarkLineFeed = True Then
            sReturn = Replace(sReturn, "@", " / ")
        Else
            sReturn = Replace(sReturn, "@", " ")
        End If

        'remove surrounding spaces
        sReturn = Trim(sReturn)

        CleanText = sReturn
    End Function

    Public Sub MarkCheckoff(sTag As String)
        With App.Selection
            .Text = ""
            .Expand Unit:=wdParagraph
        .End = .End - 1
            .Collapse Direction:=wdCollapseEnd
        .Text = "<" & sTag & ">"
        End With
    End Sub

    Public Sub ReplaceCheckoff(sTag As String)
        Dim sMsg As String
        Dim sFind As String

        With App.Selection
            sFind = .Text
            MarkCheckoff sTag
        If .Tables.Count + .InlineShapes.Count + .Frames.Count = 0 Then
                If sFind <> "" Then
                    App.Selection.Find.ClearFormatting()
                    App.Selection.Find.Replacement.ClearFormatting()

                    With App.Selection.Find
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Format = False
                        .MatchCase = False
                        .MatchWholeWord = False
                        .MatchWildcards = False
                        .MatchSoundsLike = False
                        .MatchAllWordForms = False
                    End With
                    While App.Selection.Find.Execute(FindText:=sFind) = True
                        MarkCheckoff sTag
                End While
                End If
            End If
        End With

    End Sub

    Public Sub SaveCheckoff(sFmtFile As String, sID As String)
        'SAVE CHECKOFF AS BUILDING BLOCK ENTRY
        Dim tmp As Template
        Dim sNames As String
        Dim sNewName As String
        Dim sCategory As String
        Dim bbE As BuildingBlock
        Dim I As Integer

        With App.Selection
            If .Tables.Count + .InlineShapes.Count = 0 Then
                sCategory = "CO_" & sFmtFile & "(" & sID & ")"

                On Error Resume Next
                tmp = ThisDocument.AttachedTemplate
                With tmp.BuildingBlockEntries
                    For I = 1 To .Count
                        If .Item(I).Type = wdTypeAutoText Then
                            If .Item(I).Category = sCategory Then
                                sNames = sNames & ";" & .Item(I).Name & ";"
                                If .Item(I).Value = App.Selection.FormattedText Then
                                    Exit Sub
                                End If
                            End If
                        End If
                    Next I
                End With

                I = 65  'start with capital A
                sNewName = sCategory & "." & Chr(I)
                While InStr(sNames, ";" & sNewName & ";") > 0
                    I = I + 1
                    sNewName = sCategory & "." & Chr(I)
                End While

                tmp.BuildingBlockEntries.Add Name:=sNewName, Type:=wdTypeAutoText, Category:=sCategory, Range:= .Range
        End If
        End With

    End Sub

    Public Sub SearchCheckoff(sFmtFile As String, Optional sID As String = "")
        'NOT TESTED, ONLY FINDS TEXT NOT SHAPES
        Dim tmp As Template
        Dim sNames As String
        Dim sCategory As String
        Dim bbE As BuildingBlock
        Dim I As Integer

        sCategory = "CO_" & sFmtFile & "("
        If sID <> "" Then
            sCategory = sCategory & sID & ")"
        End If
        sCategory = sCategory & "*"

        tmp = ThisDocument.AttachedTemplate
        With tmp.BuildingBlockEntries
            For I = 1 To .Count
                If .Item(I).Type = wdTypeAutoText Then
                    If .Item(I).Category Like sCategory Then
                        App.Selection.Find.ClearFormatting()
                        App.Selection.Find.Replacement.ClearFormatting()

                        With App.Selection.Find
                            .Text = tmp.BuildingBlockEntries(I).value
                            .Replacement.Text = "<" & tmp.BuildingBlockEntries(I).Category & "." & tmp.BuildingBlockEntries(I).name
                            .Forward = True
                            .Wrap = wdFindContinue
                            .Format = False
                            .MatchCase = False
                            .MatchWholeWord = False
                            .MatchWildcards = False
                            .MatchSoundsLike = False
                            .MatchAllWordForms = False
                        End With
                        App.Selection.Find.Execute Replace:=Word.WdReplace.wdReplaceAll
                End If
                End If
            Next I
        End With

    End Sub

End Module