Introduction to VBA Programming

Programming fundamentals

Returning information

Working with tables

Miscellaneous routines

Click a topic:

Move shape anchors away from heading paragraphs.

Interrupt the Document_Close event (or AutoClose macro).

Highlight any misspelled words, so that unrecognized words stand out prominently on a printout.

Change all dates in a document from MMMM DD, YYYY to DD MMMM YYYY.

Force the user to save documents into a particular folder or a subfolder of that folder.

Force the File New dialog to display in List view.

Select the page that the cursor is on.

Change headers and footers in a document protected for forms.

Replace each instance of the text string "Document One" with the contents of a file called c:\test\Doc1.doc.

Prevent a file from showing up on the recently used files list.

Replace one character with another wherever it appears in a string.

Cycle a paragraph through all available paragraph styles, eventually returning to the style the paragraph started with.

Scroll all open documents the same percentage as the active document.

Remove the underline attribute from characters with descenders.

Size the text in a textbox to fill the textbox.

Create a numbered list using SEQuence fields.

Move shape anchors away from heading paragraphs. <Top of Page>

Notes:
When shape anchors are located in heading paragraphs, the table of contents is unable to display heading numbers. This routine works even on shapes whose anchors are locked. It preserves the location of a shape even if the shape is positioned relative to paragraph!

Solution:
Cut offending shapes out of the document and paste them back into the document with their anchors at a new location, immediately below the heading paragraph. Do this without affecting the location of the shape on the page.

This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub MoveAnchorsOutOfHeadings()
For Each oShape In ActiveDocument.Shapes
If Left$(oShape.Anchor.Style, 7) = "Heading" Then
oShape.Select
Selection.Cut
Selection.MoveDown unit:=wdParagraph, Count:=1
Selection.Paste
End If
Next oShape
End Sub

Interrupt the Document_Close event (or AutoClose macro). <Top of Page>

Notes:
The best thing to do is to prevent the close command from being given in the first place, or trap it before it triggers the Document_Close event (or AutoClose macro).

Solution:
Place the following code into the Document_Close event (or AutoClose macro):
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
ActiveDocument.Saved = False
SendKeys "{ESC}"

Explanation:
Word waits to check a document's saved bit until after the Document_Close event (and/or AutoClose macro) runs. If you mark the doc dirty in the Document_Close event (or AutoClose macro) and use sendkeys to queue up an Escape keystroke, Word will prompt the user to save unsaved changes (yes, no, cancel ) but the sendkeys statement will already have the esc keystroke queued up, causing the prompt message to be closed and all action to be canceled.

Highlight any misspelled words, so that unrecognized words stand out prominently on a printout. <Top of Page>

Solution:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
The following macro highlights any misspelled words:
Sub HighlightMisspelledWords()
Dim oWord As Range
Dim StoryRange As Range
For Each StoryRange In ActiveDocument.StoryRanges
Application.CheckSpelling Word:=StoryRange
For Each oWord In StoryRange.Words
If Not Application.CheckSpelling(Word:=oWord.Text) Then
oWord.HighlightColorIndex = wdYellow
End If
Next oWord
Next StoryRange
End Sub

Clear all highlighting from a document.

Solution:
The following macro clears highlighting from all words:
Sub ClearHighlightFromAllWords()
Dim StoryRange As Range
For Each StoryRange In ActiveDocument.StoryRanges
StoryRange.HighlightColorIndex = wdNoHighlight
Next StoryRange
End Sub

Change all dates in a document from MMMM DD, YYYY to DD MMMM YYYY. <Top of Page>

Solution:
Create a macro based on Word's wildcard search-and-replace capabilities. Target only those month names that are followed by a one or two-digit day and then a comma. In other words, change the format of a date like January 12, 1904 but do nothing to a date like January 1904.

Notes:
Use text similar to the following for find what and replace with:
Find What: "(January) ([0-9]{1,2}),"
Replace With "\2 \1"

The text above is specific, of course, to the month of January. Here's how Word interprets the Find What text and Replace With text:

Find What:
Find the word January followed by a space followed by one or two occurrences of a digit from 0-9, followed by a comma. January occurs within parentheses so that it can be reused in the Replace With text. Likewise, the expression that specifies one or two occurrences of a digit from 0-9 also occurs within parentheses so that it fcan be reused in the Replace With text. The space after January and the comma after the one-or-two-digit expression do NOT occur within parentheses, because we don't need to reuse them in the Replace With text.

Replace With:
In place of the found text, insert the one-or-two-digit expression followed by a space followed by the word January. (No space is needed after the word January, because a space already follows the found text.)

Code:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub ChangeDateFormatWithReplaceCommand()
Dim myMonth(1 To 12) As String
myMonth(1) = "January"
myMonth(2) = "February"
myMonth(3) = "March"
myMonth(4) = "April"
myMonth(5) = "May"
myMonth(6) = "June"
myMonth(7) = "July"
myMonth(8) = "August"
myMonth(9) = "September"
myMonth(10) = "October"
myMonth(11) = "November"
myMonth(12) = "December"
For i = 1 To 12
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "(" & myMonth(i) & ")" & " ([0-9]{1,2}),"
.Replacement.Text = "\2 \1"
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next i
End Sub

Force the user to save documents into a particular folder or a subfolder of that folder. <Top of Page>

Solution:
Use a FileSave macro that will run in place of Word's own built-in File Save routine. The macro allows the user to save directly to a target folder or to a subfolder within that folder, but NOT to a location outside the target folder.

Code:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub FileSave()
'save changes if doc has been saved previously
If ActiveDocument.Path <> "" Then
ActiveDocument.Save
Exit Sub
End If
'preset Word's document folder to desired target
ChangeFileOpenDirectory "C:\My Documents\Test"
'display the File Save As dialog
Set UserSaveDialog = Dialogs(wdDialogFileSaveAs)
UserSaveDialog.Display
'Quit if user has switched out of target folder
'but don't quit if user has made a subfolder within
'the target folder
If Left$(CurDir, 20) <> "C:\My Documents\Test" Then
MsgBox "Documents can't be saved in that folder. Please try again."
Exit Sub
End If
'save the document according to user preferences
UserSaveDialog.Execute
End Sub

Force the File New dialog to display in List view. <Top of Page>

Solution:
Create a FileNew macro that will run in place of Word's own File New routine.

Code:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub FileNew()
SendKeys "%2"
Dialogs(wdDialogFileNew).Show
End Sub

Change the SendKeys statement to "%1" for Large Icon view or to "%3" for Detail view.

Select the page that the cursor is on. <Top of Page>

Solution:
Selection.GoTo what:=wdGoToBookmark, Name:="\page"

Change headers and footers in a document protected for forms. <Top of Page>

Solution:
Wrap the code in an unprotect/reprotect sandwich like so:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
ActiveDocument.Unprotect
ActiveDocument.Sections(1).Headers(1).Range.Text = "Hello"
ActiveDocument.Protect wdAllowOnlyFormFields

Replace each instance of the text string "Document One" with the contents of a file called c:\test\Doc1.doc. <Top of Page>

Code:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub ReplaceTagWithFile()
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Document One"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
While Selection.Find.Execute()
Selection.InsertFile _
FileName:="c:\test\Doc1.doc", Range:="", _
ConfirmConversions:=False, _
Link:=False, _
Attachment:=False
Wend
End Sub

Prevent a file from showing up on the recently used files list. <Top of Page>

Solution:
Turn off the list when the document opens and turn it back on again when the document closes.

Notes:
In order to do this, you need to create some document variables to store the user's original settings. Then you need to capture those settings and store them in the document variables before turning off the list. Finally, you need to use the document variables to turn the list back on with the user's original settings. A separate subroutine is used for each of these actions. Generally speaking, you will want to call these routines from the Document_Open and Document_Close events.

Code:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub CreateDocumentVariables()
ActiveDocument.Variables.Add Name:="DisplayRecentFiles", Value:="0"
ActiveDocument.Variables.Add Name:="RecentFilesMaximum", Value:="0"
End Sub

Sub RecordUserOptions()
''make a record of user settings so they can be restored after my
''last document is closed
ActiveDocument.Variables("DisplayRecentFiles") =
Application.DisplayRecentFiles
ActiveDocument.Variables("RecentFilesMaximum") =
Application.RecentFiles.Maximum
End Sub

Sub SetTemporaryOptions()
'Change user options to suit my requirements
'Application.DisplayRecentFiles = True
'Application.RecentFiles.Maximum = 4
End Sub

Sub RestoreUserOptions()
'restore user settings to what they were before my first doc was opened
Application.DisplayRecentFiles =
ActiveDocument.Variables("DisplayRecentFiles")
Application.RecentFiles.Maximum =
ActiveDocument.Variables("RecentFilesMaximum")
End Sub

Replace one character with another wherever it appears in a string. <Top of Page>

Solution:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
' the following code calls the "ReplaceACharacter" function
Sub TestTheFunction()
Dim myString As String
Dim OldCharacter As String
Dim NewCharacter As String
myString = "Hello, I love you. Let me jump in your game."
OldCharacter = "e"
NewCharacter = "u"
myString = ReplaceACharacter(InWhat:=myString, FindWhat:=OldCharacter,
ReplaceWith:=NewCharacter)
MsgBox myString
End Sub
'here's the function itself
Function ReplaceACharacter(InWhat As String, FindWhat As String, ReplaceWith
As String) As String
Dim StartAtCharacter As Integer
StartAtCharacter = 1
StartAtCharacter = InStr(StartAtCharacter, InWhat, FindWhat)
Do While StartAtCharacter <> 0
InWhat = Left$(InWhat, StartAtCharacter - 1) _
& ReplaceWith _
& Mid$(InWhat, StartAtCharacter + 1)
StartAtCharacter = InStr(StartAtCharacter, InWhat, FindWhat)
Loop
ReplaceACharacter = InWhat
End Function

Cycle a paragraph through all available paragraph styles, eventually returning to the style the paragraph started with. <Top of Page>

Notes:
The following macro includes a line that prevents execution when text is selected. (The cursor must be flashing for the macro to run.)

I played with this a bit because someone else thought it would be a nice feature. I assigned the macro to a button, then to a keystroke. I found the keystroke much easier to use. But Word has so many built-in styles that it can be tedious to keep cycling through the styles until the original style comes back around.

Code:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub CycleThroughStyles()
Dim NeedToRollOver As Boolean
Dim i, j, k As Integer
NeedToRollOver = True
'quit if cursor isn't flashing.
'This limits action to one paragraph
If Selection.Type <> wdSelectionIP Then GoTo EndGracefully
'find the current paragraph style, then
'find the next available paragraph style
For i = 1 To ActiveDocument.Styles.Count - 1
If Selection.Paragraphs(1).Style = ActiveDocument.Styles(i) Then
For j = i + 1 To ActiveDocument.Styles.Count - 1
If ActiveDocument.Styles(j).Type = wdStyleTypeParagraph Then
Selection.Paragraphs(1).Style = ActiveDocument.Styles(j)
NeedToRollOver = False
Exit For
End If
Next j
End If
If NeedToRollOver = False Then
Exit For
End If
Next i
'if we reached the last paragraph style, then
'roll over to first available paragraph style
If NeedToRollOver = False Then GoTo EndGracefully
For k = 1 To ActiveDocument.Styles.Count
If ActiveDocument.Styles(k).Type = wdStyleTypeParagraph Then
Selection.Paragraphs(1).Style = ActiveDocument.Styles(k)
Exit For
End If
Next k
'tell user what current style is.
'clear the undo buffer to prevent error message
'about document formatting being too complex.
EndGracefully:
Application.StatusBar = Selection.Paragraphs(1).Style
ActiveDocument.UndoClear
End Sub

Scroll all open documents the same percentage as the active document. <Top of Page>

Solution:
Scroll the active document to the desired point, then run a macro that scrolls all other open documents to the same percentage.

Notes:
The following code is written for Word 97. It looks at how far you've scrolled the active window, then scrolls all other document windows the same percentage. Of course, if one document is 10 pages long and another is 100 pages long, then a 50% vertical scroll would put you on page 5 in one document and page 50 in the other.

Code:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub ScrollAllWindowsALike()
Set myWindow = ActiveWindow
ScrollPercent = myWindow.VerticalPercentScrolled
For Each oWindow In Application.Windows
oWindow.Activate
oWindow.VerticalPercentScrolled = ScrollPercent
Next oWindow
myWindow.Activate
End Sub

Remove the underline attribute from characters with descenders. <Top of Page>

Solution:
Select the text that you want to fix, then run the following macro:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub FixUnderlinedText()
For Each oCharacter In Selection.Characters
If oCharacter Like "[qypjg]" Then oCharacter.Font.Underline = wdUnderlineNone
Next oCharacter
End Sub

Size the text in a textbox to fill the textbox. <Top of Page>

Solution:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.
Sub ResizeTextToFitTextBox()
If Selection.StoryType <> _
wdTextFrameStory Then Exit Sub
Dim myTextRange As Range
Dim myShape As Shape
Set myShape = Selection.ShapeRange(1)
Set myTextRange = myShape.TextFrame.TextRange
myTextRange.Font.Size = 2
If myShape.TextFrame.Overflowing = True Then
ActiveDocument.Undo
MsgBox "Even when set to a size of 2 points, the text overflows the textbox."
Exit Sub
End If
Do Until _
myShape.TextFrame.Overflowing = True
myTextRange.Font.Size = _
myTextRange.Font.Size + 0.5
Loop
myTextRange.Font.Size = _
myTextRange.Font.Size - 0.5
End Sub

Create a numbered list using SEQuence fields. <Top of Page>

Solution:
This code is provided for illustrative purposes only and is not warranted to be suitable for any particular business purpose. The code may be freely copied for any lawful business purpose.

Notes:
The following code was developed by fellow MVP Doug Robbins. I commented the code and added a bit of code at the top of Doug's routine to make sure that at least one full paragraph of text has been selected ahead of time. The code is provided in the hope that it might help you explore how to work with fields in general and sequence fields in particular. Thank you to Doug Robbins for providing the code.