Word: Some formatting macros

Fixing up Tables

This is a macro that formats all the tables in a document to be a standard style called "Table Grid", and also fixes the table margins to be the full width of the page.

Sub FixTableWidth()

For Each tbl In Selection.Tables

tbl.AutoFitBehavior (wdAutoFitWindow)

tbl.AutoFitBehavior (wdAutoFitContent)

tbl.AutoFitBehavior (wdAutoFitWindow)

Convert automatic numbering to text

Sometimes you want to just copy the text as is, without the automatic numbering changing. Here's a macro that converts all the automatic numbering into text. I based it from the comments here: http://forums.cnet.com/7723-6129_102-279799/how-to-convert-automatic-numbering-to-normal-text-in-word/

Sub Auto_Format_convert_list_numbers()

Selection.Range.ListFormat.ConvertNumbersToText

End Sub

Extract all acronyms

This comes from thedoctools.com. I usually use 2 uppercase characters instead of the 3 so that's the only modification I've made.

Sub ExtractACRONYMSToNewDocument()

'=========================

'Macro created 2008 by Lene Fredborg, DocTools - www.thedoctools.com

'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.

'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.

'=========================

'The macro creates a new document,

'finds all words consisting of 2 or more uppercase letters

'in the active document and inserts the words

'in column 1 of a 3-column table in the new document

'Each acronym is added only once

'Use column 2 for definitions

'Page number of first occurrence is added by the macro in column 3

'Minor adjustments are made to the styles used

'You may need to change the style settings and table layout to fit your needs

'=========================

Dim oDoc_Source As Document

Dim oDoc_Target As Document

Dim strListSep As String

Dim strAcronym As String

Dim oTable As Table

Dim oRange As Range

Dim n As Long

Dim strAllFound As String

Dim Title As String

Dim Msg As String

Title = "Extract Acronyms to New Document"

'Show msg - stop if user does not click Yes

Msg = "This macro finds all words consisting of 2 or more " & _

"uppercase letters and extracts the words to a table " & _

"in a new document where you can add definitions." & vbCr & vbCr & _

"Do you want to continue?"

If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then

Exit Sub

End If

Application.ScreenUpdating = False

'Find the list separator from international settings

'May be a comma or semicolon depending on the country

strListSep = Application.International(wdListSeparator)

'Start a string to be used for storing names of acronyms found

strAllFound = "#"

Set oDoc_Source = ActiveDocument

'Create new document for acronyms

Set oDoc_Target = Documents.Add

With oDoc_Target

'Make sure document is empty

.Range = ""

'Insert info in header - change date format as you wish

.PageSetup.TopMargin = CentimetersToPoints(3)

.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _

"Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _

"Created by: " & Application.UserName & vbCr & _

"Creation date: " & Format(Date, "MMMM d, yyyy")

'Adjust the Normal style and Header style

With .Styles(wdStyleNormal)

.Font.Name = "Arial"

.Font.Size = 10

.ParagraphFormat.LeftIndent = 0

.ParagraphFormat.SpaceAfter = 6

End With

With .Styles(wdStyleHeader)

.Font.Size = 8

.ParagraphFormat.SpaceAfter = 0

End With

'Insert a table with room for acronym and definition

Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)

With oTable

'Format the table a bit

'Insert headings

.Range.Style = wdStyleNormal

.AllowAutoFit = False

.Cell(1, 1).Range.Text = "Acronym"

.Cell(1, 2).Range.Text = "Definition"

.Cell(1, 3).Range.Text = "Page"

'Set row as heading row

.Rows(1).HeadingFormat = True

.Rows(1).Range.Font.Bold = True

.PreferredWidthType = wdPreferredWidthPercent

.Columns(1).PreferredWidth = 20

.Columns(2).PreferredWidth = 70

.Columns(3).PreferredWidth = 10

End With

With oDoc_Source

Set oRange = .Range

n = 1 'used to count below

With oRange.Find

'Use wildcard search to find strings consisting of 3 or more uppercase letters

'Set the search conditions

'NOTE: If you want to find acronyms with e.g. 2 or more letters,

'change 3 to 2 in the line below

.Text = "<[A-Z]{2" & strListSep & "}>"

.Forward = True

.Wrap = wdFindStop

.Format = False

.MatchCase = True

.MatchWildcards = True

'Perform the search

Do While .Execute

'Continue while found

strAcronym = oRange

'Insert in target doc

'If strAcronym is already in strAllFound, do not add again

If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then

'Add new row in table from second acronym

If n > 1 Then oTable.Rows.Add

'Was not found before

strAllFound = strAllFound & strAcronym & "#"

'Insert in column 1 in oTable

'Compensate for heading row

With oTable

.Cell(n + 1, 1).Range.Text = strAcronym

'Insert page number in column 3

.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)

End With

n = n + 1

End If

Loop

End With

'Sort the acronyms alphabetically - skip if only 1 found

If n > 2 Then

With Selection

.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _

:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending

'Go to start of document

.HomeKey (wdStory)

End With

End If

Application.ScreenUpdating = True

'If no acronyms found, show msg and close new document without saving

'Else keep open

If n = 1 Then

Msg = "No acronyms found."

oDoc_Target.Close savechanges:=wdDoNotSaveChanges

Else

Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."

End If

MsgBox Msg, vbOKOnly, Title

'Clean up

Set oRange = Nothing

Set oDoc_Source = Nothing

Set oDoc_Target = Nothing

Set oTable = Nothing

End Sub

Make fields obey styles

For some reason you might find that a field is a different style to the paragraph style. This is because the field is set to "preserve formatting during updates". The follow macro goes through and unchecks this box from all fields with it to make formatting consistent.

Sub FieldsFormattingFix()

' ' Changes all fields so that they do not retain formatting.

' By Edward Chan

' '

Dim ref As Field

Dim startPos As Integer

Dim isHyperLink As Boolean

For Each ref In Selection.Range.Fields

ref.Select

If (InStr(1, ref.Code, "MERGEFORMAT")) Then

ref.Code.Text = Replace(ref.Code, " \* MERGEFORMAT", "")

ref.Update

End If

Update All fields

Microsoft Word has this thing where it just refuses to update everything. Headers and Footers, Table of Contents, Indexes, fields - they all require a different update mechanism. Just when you think you've updated everything, there's another thing that just doesn't get updated.

Here's a bunch of macros that will hopefully do all the updating for you.

Sub UpdateAll()

UpdateHeadersFooters

UpdateRefTables

UpdateFields

End Sub

Sub UpdateFields()

' Note you'll need to run this at least 3 times!

Dim myRange

Set myRange = Selection.Range

Selection.WholeStory

Selection.Fields.Update

myRange.Select

End Sub

Sub UpdateHeadersFooters()

' Doing a Print Preview updates all headers and footers. Strange but true.

ActiveDocument.ActiveWindow.View.Type = wdPrintPreview

ActiveDocument.ActiveWindow.View.Type = wdPrintView

End Sub

Sub UpdateRefTables()

' This comes from http://www.thecodecage.com/forumz/archive/index.php/t-173094.html

' This is required because Word refuses to update a Table of Tables

' using the normal update fields mechanism (although it will update a

' Table of Figures for some strange reason).

Dim TOC As TableOfContents ' Table of Contents Object

Dim TOA As TableOfAuthorities ' Table of Authorities Object

Dim TOF As TableOfFigures ' Table of Figures Object

With ActiveDocument

' The following routines update TOC, TOA or TOF contents.

' Loop through Tables Of Contents and update

For Each TOC In .TablesOfContents

TOC.Update

For Each TOA In .TablesOfAuthorities

TOA.Update

For Each TOF In .TablesOfFigures

TOF.Update

End Sub

Convert Table X and Figure X into real table and figure captions with automatic numbering

'

' Converts Figure X to the Figure Caption and automatic Figure fields

'

' Find all Figure X and replace with correct style

Selection.HomeKey Unit:=wdStory

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

Selection.Find.Replacement.Style = ActiveDocument.Styles("Figure Caption")

With Selection.Find

.Text = "Figure X"

.Replacement.Text = "Figure SEQ Figure \* ARABIC"

.Forward = True

.Wrap = wdFindStop

.Format = True

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

' Replace with fields

Selection.HomeKey Unit:=wdStory

Do While 1

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

Selection.Find.Replacement.Style = ActiveDocument.Styles("Figure Caption")

With Selection.Find

.Text = "SEQ Figure \* ARABIC"

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindStop

.Format = True

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

If Selection.Find.Execute = False Then Exit Do

' Convert to a field

Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, PreserveFormatting:=False

Selection.Fields.Update

Loop

End Sub

Sub ConvertTables()

'

' Converts Table X to the Figure Caption and automatic Figure fields

'

' Find all Table X and replace with correct style

Selection.HomeKey Unit:=wdStory

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

Selection.Find.Replacement.Style = ActiveDocument.Styles("Table Caption")

With Selection.Find

.Text = "Table X"

.Replacement.Text = "Table SEQ Table \* ARABIC"

.Forward = True

.Wrap = wdFindStop

.Format = True

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

' Replace with fields

Selection.HomeKey Unit:=wdStory

Do While 1

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

Selection.Find.Replacement.Style = ActiveDocument.Styles("Table Caption")

With Selection.Find

.Text = "SEQ Table \* ARABIC"

.Forward = True

.Wrap = wdFindStop

.Format = True

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

If Selection.Find.Execute = False Then Exit Do

' Convert to a field

Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, PreserveFormatting:=False

Selection.Fields.Update

Loop

End Sub

Turn fields into a hyperlinks

This macro goes through every field in a selection, and if it is not a hyperlink, it converts it into one.

Sub FieldsToHyperLinks()

'

' Converts fields that aren't hyperlinks into Hyperlinks

'

Dim ref As Field

Dim startPos As Integer

Dim isHyperLink As Boolean

On Error Resume Next ' Required for first list

For Each ref In Selection.Range.Fields

startPos = InStr(1, ref.Code, "\r")

isHyperLink = InStr(1, ref.Code, "\h")

If startPos > 0 And Not isHyperLink Then

Debug.Print "Original: "; ref.Code

Debug.Print "New: " & Left(ref.Code, startPos + 1) & " \h" & Right(ref.Code, Len(ref.Code) - startPos - 1)

ref.Code.Text = Left(ref.Code, startPos + 1) & " \h" & Right(ref.Code, Len(ref.Code) - startPos - 1)

ref.Update

End If

Word 2013 Fix scrollbar

In Word 2013, the vertical scrollbar will disappear when the window is not focussed, which is a really terrible design change.

The following is an automated workaround that keeps the vertical scrollbar displayed.

It's been adapted from https://superuser.com/questions/685795/disabling-auto-hiding-of-vertical-scrollbar-in-word-2013 (with the addition of an extra line of code to force the correct view mode).

Sub Fix_Scrollbar()

'

' Fix_Scrollbar Macro

'

ActiveWindow.View.ReadingLayout = True

ActiveWindow.View.ReadingLayoutActualView = True ' This line is required!

Selection.EscapeKey

If ActiveWindow.View.SplitSpecial = wdPaneNone Then

ActiveWindow.ActivePane.View.Type = wdPrintView

Else

ActiveWindow.View.Type = wdPrintView

End If

End Sub

Copying Document properties

http://wordribbon.tips.net/T011671_Copying_Custom_Properties.html

Sub CopyDocProps()

Dim dp() As DocumentProperty

Dim CustomPropCount As Integer

Dim i As Integer

Dim iResponse As Integer

If Windows.Count > 2 Then

MsgBox "There are more than two windows. Please " & _

"close the others and re-run the macro.", , _

"Too many windows"

Exit Sub

End If

On Error GoTo Err_Handler

iResponse = MsgBox("Are you currently in the source document?", _

vbYesNoCancel, "Copy Custom Properties")

If iResponse = vbNo Then Application.Run MacroName:="NextWindow"

CustomPropCount = ActiveDocument.CustomDocumentProperties.Count

ReDim dp(1 To CustomPropCount)

For i = 1 To CustomPropCount

Set dp(i) = ActiveDocument.CustomDocumentProperties(i)

Next i

Application.Run MacroName:="NextWindow"

For i = 1 To CustomPropCount

If dp(i).LinkToContent = True Then

ActiveDocument.CustomDocumentProperties.Add _

Name:=dp(i).Name, _

LinkToContent:=True, _

Value:=dp(i).Value, _

Type:=dp(i).Type, _

LinkSource:=dp(i).LinkSource

Else

ActiveDocument.CustomDocumentProperties.Add _

Name:=dp(i).Name, _

LinkToContent:=False, _

Value:=dp(i).Value, _

Type:=dp(i).Type

End If

Next i

MsgBox "The properties have been copied."

Exit Sub

Err_Handler:

' if Word raises an error, then allow the user

' to update the custom document property

iResponse = MsgBox("The custom document property (" & _

dp(i).Name & ") already exists." & vbCrLf & vbCrLf & _

"Do you want to update the value?", vbYesNoCancel, _

"Copy Custom Properties")

Select Case iResponse

Case vbCancel

End

Case vbYes

ActiveDocument.CustomDocumentProperties(dp(i).Name).Value _

= dp(i).Value

Resume Next

Case vbNo

Resume Next

End Select

End Sub