Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement