VBA - Format document for web publishing

Option Explicit

Public Sub start_tla()

    Dim formatted As Boolean        ' Whether or not the document is already formatted for publishing
    Dim document_title As String    ' The title of the current document

    ' Set up the error handling
    On Error GoTo error

    Application.ScreenUpdating = False

    ' Show the 'Please wait' form
    TLA_formatting.Show False

    ' Move the cursor to the beginning of the document
    Selection.GoTo wdGoToBookmark, , , "\StartOfDoc"

    ' Check to see if the document has already been formatted for publishing
    formatted = check_if_formatted
    If formatted = True Then GoTo finish

    ' Remove any empty paragraphs
    Call remove_empty_paragraphs

    ' Format the tile
    document_title = get_title

    ' Format the paragraphs
    Call format_paragraphs

    ' Set the document properties
    Call set_document_properties(document_title)

    ' Set the zoom to 100%
    ActiveWindow.ActivePane.View.Zoom.Percentage = 100

    ' Save the document
    If ActiveDocument.Path = vbNullString Then
        Application.Dialogs(wdDialogFileSaveAs).Show
    Else
        ActiveDocument.Save
    End If

    ' Reset the error handling
    On Error GoTo 0

error:
    If Err.Number <> 0 Then

        Dim error_msg As String

        error_msg = "An error occured while trying to format this document. Please undo any changes and try again"
        error_msg = error_msg & vbCrLf & vbCrLf & "Error number: " & Err.Number
        error_msg = error_msg & vbCrLf & "Error number: " & Err.Description

        MsgBox error_msg, vbOKOnly, "An error has occured"

    End If

finish:

    ' Hide the 'Please wait' form
    TLA_formatting.Hide

    ' If the doucment has alredy been formatted for publishing, show a message box to tell the user
    If formatted = True Then MsgBox "This document has already been formatted for publishing", vbOKOnly, "Document Ready For Publishing"

    Application.ScreenUpdating = True

End Sub

'**
 ' Checks to see if a document has already been formatted for publishing
 '*
Function check_if_formatted()

    check_if_formatted = (ActiveDocument.BuiltInDocumentProperties("Content status").Value = "ready")

End Function

'**
 ' Removes any paragraphs that are empty in the document
 '*
Function remove_empty_paragraphs(Optional trim_string As Boolean = True)

    Dim para As Paragraph

    For Each para In ActiveDocument.Paragraphs

        ' Trim the text
        'If trim_string = True Then
            'para.Range.Text = trim(para.Range.Text)
        'End If

        ' Check if the length of the paragraph is 1 - if so, it can be deleted
        If Len(para.Range.Text) = 1 Then
            para.Range.Delete
        End If

    Next

End Function

'**
 ' Formats the title correctly
 '*
Function get_title() As String

    Dim para As Paragraph

    ' Set para as the first paragraph (The title)
    Set para = ActiveDocument.Paragraphs.First

    ' Set 'Heading 1' to the desired format
    Call set_heading_1

    ' Format the paragraph to 'Heading 1'
    para.Format.Style = ActiveDocument.Styles("Heading 1")

    get_title = para.Range.Text

End Function

'**
 ' Adds the '<br />' code in between paragraphs
 '*
Function format_paragraphs()

    Dim para As Paragraph           ' A paragraph object used for looping through paragraphs
    Dim temp_range As Range         ' The temporty range of the paragraph that is being looped (so the ending '</li>' is placed in the correct place)
    Dim is_list_item As Boolean     ' Whether or not a paragraph is part of a list
    Dim was_list_item As Boolean    ' Whether or not the previous paragraph was a list item
    Dim open_list As String         ' The open tag to insert before the paragraph(if it is the first item in a list)
    Dim close_list As String        ' The close tag to insert after the paragraph (if it is the last item in a list)
    Dim i As Integer                ' Dummy for looping and counting

    i = 0

    ' Set 'Normal' to the desired format
    Call set_normal

    ' Loop through all paragraphs
    For Each para In ActiveDocument.Paragraphs

        ' Checks whether or not the previous item was a list item (so that a '</ul>' can be inserted, instead of a '<br />')
        If is_list_item = True Then
            was_list_item = True
        Else
            was_list_item = False
        End If

        ' Set 'is_list_item' to false at the beginning of each itteration
        is_list_item = False

        Select Case para.Range.ListFormat.ListType

            Case WdListType.wdListBullet, _
                WdListType.wdListPictureBullet:

                is_list_item = True
                Set temp_range = ActiveDocument.Range(para.Range.Start, para.Range.End - 1)
                temp_range.InsertBefore "<li>"
                temp_range.InsertAfter "</li>"
                open_list = "<ul>"
                close_list = "</ul>"

            Case WdListType.wdListSimpleNumbering, _
                WdListType.wdListListNumOnly, _
                WdListType.wdListMixedNumbering, _
                WdListType.wdListOutlineNumbering:

                is_list_item = True
                Set temp_range = ActiveDocument.Range(para.Range.Start, para.Range.End - 1)
                temp_range.InsertBefore "<li>"
                temp_range.InsertAfter "</li>"
                open_list = "<ol>"
                close_list = "</ol>"

        End Select

        ' Format the paragraph to 'Normal' (if it is not the title)
        If para.Format.Style <> "Heading 1" Then
            para.Format.Style = ActiveDocument.Styles("Normal")
        End If

        ' Add '<br />' and then a carridge return before the paragraph
        If i > 1 And is_list_item = False And was_list_item = False Then ' Skip the title (picked up as a parapraph) and the first paragraph, as well as lists

            ' Add '<br />' and then a carridge return before the paragraph
            para.Range.InsertBefore "<br />" & vbCrLf

        End If

        ' Check to see if the paragraph is the first or last item in a list
        If is_list_item = True And was_list_item = False Then ' Add a list opening tag if the previous item was not a list, but the current one is
            para.Range.InsertBefore open_list & vbCrLf
        ElseIf is_list_item = False And was_list_item = True Then ' Add a list ending tag if the previous item was a list, but not the current
            para.Range.InsertBefore close_list & vbCrLf
        End If

        i = i + 1

    Next

    ' Add a carridge return after the title
    Set para = ActiveDocument.Paragraphs.First
    para.Range.InsertAfter vbCrLf

End Function

'**
 ' Sets the 'Heading 1' style for this document
 '*
Function set_document_properties(Optional document_title As String = "TLA Artilce")

    ' Set the 'Built In' properties
    ActiveDocument.BuiltInDocumentProperties("Title").Value = document_title
    ActiveDocument.BuiltInDocumentProperties("Subject").Value = "TLA Article"
    ActiveDocument.BuiltInDocumentProperties("Author").Value = "The Legal Alliance"
    ActiveDocument.BuiltInDocumentProperties("Company").Value = "Dyne Drewett Solicitors Limited"
    ActiveDocument.BuiltInDocumentProperties("Category").Value = "TLA-article"
    ActiveDocument.BuiltInDocumentProperties("Keywords").Value = "TLA, auto-formatted"
    ActiveDocument.BuiltInDocumentProperties("Content status").Value = "ready"

    ' Declare variable for adding 'Custom' properties
    Dim custom_properties(0, 2) As String   ' The custom properties to add to this document
    Dim custom_value As String              ' The current value of the custom property
    Dim this_name As String                 ' The name of the current custom property that is being looped
    Dim this_value As String                ' The value to set for the current custom property that is being looped
    Dim this_type As String                 ' The type of the data to set for the current custom property that is being looped
    Dim i As Integer                        ' Dummy for looping and counting

    ' Set constants for arrays
    Const property_name = 0
    Const property_value = 1
    Const property_type = 2

    ' Set Custom property names and values
    custom_properties(0, property_name) = "Date completed"
    custom_properties(0, property_value) = Day(Date) & "/" & Month(Date) & "/" & Year(Date)
    custom_properties(0, property_type) = msoPropertyTypeDate

    ' Loop through all of the custom properties
    For i = 0 To UBound(custom_properties)

        ' Set the name and required value for this custom property
        this_name = custom_properties(i, property_name)
        this_value = custom_properties(i, property_value)
        this_type = custom_properties(i, property_type)

        ' Check to see if the custom property exists
        On Error Resume Next
        custom_value = ActiveDocument.CustomDocumentProperties(this_name)
        If Err.Number <> 0 Then custom_value = "null"
        On Error GoTo 0

        ' Polpulate the custom property
        If custom_value = "" Or custom_value = "null" Then ' Create the custom property
            ActiveDocument.CustomDocumentProperties.Add _
                Name:=this_name, _
                LinkToContent:=False, _
                Value:=this_value, _
                Type:=this_type
        Else ' Overwrite the custom property
           ActiveDocument.CustomDocumentProperties("Date completed").Value = this_value
        End If

    Next

End Function

'**
 ' Sets the 'Heading 1' style for this document
 '*
Function set_heading_1()

    With ActiveDocument.Styles("Heading 1").Font
        .Name = "+Headings"
        .Size = 14
        .Bold = True
        .Italic = False
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Scaling = 100
        .Kerning = 16
        .Animation = wdAnimationNone
    End With
    With ActiveDocument.Styles("Heading 1").ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceMultiple
        .LineSpacing = LinesToPoints(1.15)
        .Alignment = wdAlignParagraphLeft
        .WidowControl = True
        .KeepWithNext = True
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False
        .Hyphenation = True
        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevel1
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .MirrorIndents = False
        .TextboxTightWrap = wdTightNone
    End With
    ActiveDocument.Styles("Heading 1").NoSpaceBetweenParagraphsOfSameStyle = False
    With ActiveDocument.Styles("Heading 1")
        .AutomaticallyUpdate = True
        .BaseStyle = "Normal"
        .NextParagraphStyle = "Normal"
    End With

End Function

'**
 ' Sets the 'Normal' style for this document
 '*
Function set_normal()

    With ActiveDocument.Styles("Normal").Font
        .Name = "+Body"
        .Size = 11
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Scaling = 100
        .Kerning = 0
        .Animation = wdAnimationNone
    End With
    With ActiveDocument.Styles("Normal").ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceMultiple
        .LineSpacing = LinesToPoints(1.15)
        .Alignment = wdAlignParagraphLeft
        .WidowControl = True
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False
        .Hyphenation = True
        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevelBodyText
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .MirrorIndents = False
        .TextboxTightWrap = wdTightNone
    End With
    ActiveDocument.Styles("Normal").NoSpaceBetweenParagraphsOfSameStyle = False
    With ActiveDocument.Styles("Normal")
        .AutomaticallyUpdate = True
        .BaseStyle = ""
        .NextParagraphStyle = "Normal"
    End With

End Function