VBA Code Examples (3)

Many people access the material from this web site daily. Most just take what they want and run. That's OK, provided they are not selling on the material as their own; however if your productivity gains from the material you have used, a donation from the money you have saved would help to ensure the continued availability of this resource. Click the appropriate button above to access PayPal.

Word macros - page 3

Create a bar chart based on the content of a dropdown form field

The aim of this procedure is to create a visual indication, by means of a bar chart, the value of a dropdown form field as in the animated illustration below. The animation will run indefinitely:

Each of the dropdown fields in column 1 of the table is configured similarly (create one and copy/paste the remainder). The drop down entries are numbers 0 to 10, and the macro ColTable1Row1 is run on exit from each. The illustration shows the default field bookmark name of Dropdown1. The bookmark names of the fields are immaterial as long as the final character is a number from 1 to 4 to reflect the row of the table. This number is used by the macro to fill the correct row of the table.

Option Explicit
Private mstrFF As String

Sub ColTable1Row1()
Dim oFld As FormFields
Dim i As Long
Dim sCount As Long
Dim sRow As Long
Dim oCol As Long
Dim bProtected As Boolean
Dim sPassword As String
sPassword = ""
'Insert the password (if any), used to protect the form between the quotes
With GetCurrentFF 'Establish which dropdown field is current
mstrFF = GetCurrentFF.name
End With
Set oFld = ActiveDocument.FormFields
sCount = oFld(mstrFF).Result
'Get the dropdown field value
sRow = Right(mstrFF, 1)
'Get the number at the end of the bookmark name
'Check if the document is protected and if so unprotect it
If ActiveDocument.ProtectionType <> wdNoProtection Then
bProtected = True
ActiveDocument.Unprotect Password:=sPassword
End If
For i = 2 To 11
'Select each column of the active row in turn and colour the cell white
ActiveDocument.Tables(1).Rows(sRow).Cells(i).Shading.BackgroundPatternColor = wdColorWhite
Next i
If sCount = 0 Then GoTo lbl_Exit 'If user enters 0, the row is already white so quit
Select Case sRow
Case 1 'Row 1 colour is red
oCol = wdColorRed
Case 2 'Row 2 colour is blue
oCol = wdColorBlue
Case 3 'Row 3 colour is gold
oCol = wdColorGold
Case 4 'Row 4 colour is green
oCol = wdColorGreen
Case Else
End Select
For i = 2 To sCount + 1
'Colour the cells in the row from column 2 to the number entered
ActiveDocument.Tables(1).Rows(sRow).Cells(i).Shading.BackgroundPatternColor = oCol
Next i
lbl_Exit: 'Re-protect the form and apply the password (if any).
If bProtected = True Then
ActiveDocument.Protect _
Type:=wdAllowOnlyFormFields, _
NoReset:=True, Password:=sPassword
End If
Exit Sub
End Sub

Private Function GetCurrentFF() As Word.FormField
'Get the dropdown field name
Dim rngFF As Word.Range
Dim fldFF As Word.FormField
Set rngFF = Selection.Range
rngFF.Expand wdParagraph
For Each fldFF In rngFF.FormFields
Set GetCurrentFF = fldFF
Exit For
Next
lbl_Exit:
Exit Function
End Function

Repeat a block of formatted text and form fields based upon the content of another form field

In the following example a user wished to provide a variable number of fields and associated formatted text dependant on a figure input into a form field, as in the following illustration. For the purpose of the exercise, the control field 'Mortgages' was set as a number field, the following macro was run on exit from that field, and the section to be repeated was bookmarked with the name 'bMortgage'.

Note that some of the text is underlined, some is emboldened and some both underlined and emboldened. There are eight fields in the selection, each of which will be provided with a new bookmark name. The bookmark names of the fields in that marked section will be replaced by the macro, with the names "MortTextn" where 'i' is a numeric digit from 1 to 8. Subsequent iterations will be numbered from 8 - 16, 16 -24 etc.

The user may return to the Mortgages field and change the number and the number of entries will be readjusted to take account of that changed number.

In the illustration, bookmarks are displayed to aid understanding.

Sub Mortgages()
Dim sNum As Long
Dim oRng As Range
Dim bProtected As Boolean
Dim fCount As Long
Dim i As Long
Dim j As Long
'Unprotect the file
If ActiveDocument.ProtectionType <> wdNoProtection Then
bProtected = True
ActiveDocument.Unprotect Password:=""
End If
sNum = ActiveDocument.FormFields("Mortgages").Result
Selection.GoTo What:=wdGoToBookmark, Name:="bMortgage"
'Define the range object. This is where the cursor is at (start point)
Set oRng = Selection.Range
For i = 1 To sNum
With Selection
'Insert two blank lines
.TypeParagraph
.TypeParagraph
'Set the underline option
.Font.Underline = wdUnderlineSingle
'Set the bold option
.Font.Bold = False
'Ensure that the paragraphs stay together on the same page
.ParagraphFormat.KeepWithNext = True
.TypeText "Plaintiff: "
.Font.Underline = wdUnderlineNone
'Add a form field
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
.TypeParagraph
.TypeParagraph
.Font.Underline = wdUnderlineSingle
.Font.Bold = True
.TypeText "Mortgage:"
'Turn off the underline
.Font.Underline = wdUnderlineNone
'Turn off the bold option
.Font.Bold = False
.TypeParagraph
.TypeParagraph
.TypeText "From: "
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
.TypeParagraph
.TypeParagraph
.TypeText "To: "
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
.TypeParagraph
.TypeParagraph
.Font.Bold = True
.TypeText "Dated: "
.Font.Bold = False
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
.TypeText Chr(32) 'Add a Space
.Font.Bold = True
.TypeText "Recorded: "
.Font.Bold = False
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
.TypeText Chr(32)
.Font.Bold = True
.TypeText "OR Book: "
.Font.Bold = False
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
.TypeText Chr(32)
.Font.Bold = True
.TypeText "Page: "
.Font.Bold = False
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
.TypeText Chr(32)
.Font.Bold = True
.TypeText "Original Amount: $"
.Font.Bold = False
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
'Turn off the Keep with next option
.ParagraphFormat.KeepWithNext = False
.TypeParagraph
.TypeParagraph
End With
Next i
'The selection has moved down the page. Redefine the end of the range object.
oRng.End = Selection.Range.End
'Recreate the bookmark.
ActiveDocument.Bookmarks.Add "bMortgage", oRng
'Count the form fields added to the range
fCount = oRng.FormFields.Count
'Give each of the added fields a unique bookmark name
For j = 1 To fCount
With oRng.FormFields(j)
.Name = "MortText" & j 'Add a unique bookmark name
.Enabled = True 'Enable the field for user entry
.CalculateOnExit = False 'Uncheck the calculate on exit check box
End With
Next j
'Reprotect the document.
If bProtected = True Then
ActiveDocument.Protect _
Type:=wdAllowOnlyFormFields, NoReset:=True, _
Password:=""
End If
'Select the first of the fields in the range
ActiveDocument.FormFields("MortText1").Select
lbl_Exit:
Exit Sub
End Sub

Colour a form field check box with a contrasting colour when it is checked.

In the following illustration the checked form field check box is coloured red.

This can be achieved by checking the value of the check box and formatting the check box when the value is 'True'.

The following code uses the function Private Function GetCurrentFF() As Word.FormField used in the Bar Chart example above to get the current field name, so that the same macro can be applied to the On Exit property of each check box field.

Option Explicit

Private mstrFF As String
Sub EmphasiseCheckedBox()
Dim oFld As FormFields
Dim sCount As Long
Dim bProtected As Boolean
Dim sPassword As String
sPassword = "" 'Insert the password (if any), used to protect the form between the quotes
With GetCurrentFF
'Establish field is current
mstrFF = GetCurrentFF.name
End With
Set oFld = ActiveDocument.FormFields
sCount = oFld(mstrFF).CheckBox.Value 'Get the Checkbox field value
'Check if the document is protected and if so unprotect it
If ActiveDocument.ProtectionType <> wdNoProtection Then
bProtected = True
ActiveDocument.Unprotect Password:=sPassword
End If
With oFld(mstrFF).Range
If sCount = True Then
.Font.Color = wdColorRed
'Set the colour of the checked box
Else
.Font.Color = wdColorAutomatic
'Set the colour of the unchecked box
End If
End With
'Re-protect the form and apply the password (if any).
If bProtected = True Then
ActiveDocument.Protect _
Type:=wdAllowOnlyFormFields, _
NoReset:=True, Password:=sPassword
End If
lbl_Exit:
Exit Sub
End Sub

Private Function GetCurrentFF() As Word.FormField
Dim rngFF As Word.Range
Dim fldFF As Word.FormField
Set rngFF = Selection.Range
rngFF.Expand wdParagraph
For Each fldFF In rngFF.FormFields
Set GetCurrentFF = fldFF
Exit For
Next
lbl_Exit:
Exit Function
End Function

Count times entered into a document

A user in a Word forum asked how to total the number of times associated with documented sound bites grouped in sections, similar to that shown in the illustration below. The macro below will count all the times in the format HH:MM:SS in the section where the cursor is located.

Option Explicit

Sub CountTimes()
'Totals times in the current section
'Times should be in the format HH:MM:SS
Dim sNum As Long
Dim oRng As Range
Dim sText As String
Dim sHr As Long
Dim sMin As Long
Dim sSec As Long
sHr = 0
sMin = 0
sSec = 0
sNum = Selection.Information(wdActiveEndSectionNumber)
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[0-9]{2}:[0-9]{2}:[0-9]{2}"
'Look for times in the format 00:00:00
.Wrap = wdFindStop
.MatchWildcards = True
Do While .Execute = True
sText = oRng.Text
'To count the whole document, omit the next line
If oRng.Information(wdActiveEndSectionNumber) = sNum Then
'Split the found time into three separate numbers
'representing hours minutes and seconds and add to
'the previously recorded hours, minutes and seconds
sHr = sHr + Left(sText, 2)
sMin = sMin + Mid(sText, 4, 2)
sSec = sSec + Right(sText, 2)
'To count the whole document, omit the next line
End If
Loop
End With
If sSec > 60 Then
'Divide by 60 and add to the minutes total
sMin = sMin + Int(sSec / 60)
sSec = sSec Mod 60 'The remainder is the seconds
End If
If sMin > 60 Then
'Divide by 60 and add to the hours total
sHr = sHr + Int(sMin / 60)
sMin = sMin Mod 60 'The remainder is the minutes
End If
MsgBox sHr & " hours" & vbCr & _
Format(sMin, "00") & " Minutes" & vbCr & _
Format(sSec, "00") & " Seconds"
lbl_Exit:
Exit Sub
End Sub

Transpose Characters

There is no function in Word to transpose the order of two characters - a function that has been available in some word processing software since before Windows found its way onto the home computer. The following macro attached to some suitable keyboard shortcut will correct that omission.

The macro works with either two selected characters or the characters either side of the cursor. The macro also takes account of the case of the transposed characters.

If the first character to be transposed is upper case and the second not, then after transposition the first character will be upper case and the second lower case. Where both or neither characters are upper case, the case of the characters is retained.

Option Explicit

Sub Transpose()
Dim oRng As Range
Dim sText As String
Dim Msg1 As String
Dim Msg2 As String
Dim Msg3 As String
Dim MsgTitle As String
Msg1 = "You must place the cursor between " & _
"the 2 characters to be transposed!"
Msg2 = "There are no characters to transpose?"
Msg3 = "There is no document open!"
MsgTitle = "Transpose Characters"
On Error GoTo err_Handler
If ActiveDocument.Characters.Count > 2 Then
Set oRng = Selection.Range
Select Case Len(oRng)
Case Is = 0
If oRng.Start = oRng.Paragraphs(1).Range.Start Then
MsgBox Msg1, vbCritical, MsgTitle
Exit Sub
End If
If oRng.End = oRng.Paragraphs(1).Range.End - 1 Then
MsgBox Msg1, vbCritical, MsgTitle
Exit Sub
End If
With oRng
.Start = .Start - 1
.End = .End + 1
.Select
sText = .Text
End With
Case Is = 1
MsgBox Msg1, vbCritical, MsgTitle
Exit Sub
Case Is = 2
sText = Selection.Range.Text
Case Else
MsgBox Msg1, vbCritical, MsgTitle
Exit Sub
End Select
With Selection
If .Range.Characters(1).Case = 1 _
And .Range.Characters(2).Case = 0 Then
.Text = UCase(Mid(sText, 2, 1)) & _
LCase(Mid(sText, 1, 1))
Else
.Text = Mid(sText, 2, 1) & _
Mid(sText, 1, 1)
End If
.Collapse wdCollapseEnd
.Move wdCharacter, -1
End With
Else
MsgBox Msg2, vbCritical, MsgTitle
End If
lbl_Exit:
Exit Sub
err_Handler:
If Err.Number = 4248 Then
MsgBox Msg3, vbCritical, MsgTitle
End If
GoTo lbl_Exit
End Sub

Insert Autotext Entry with VBA

When you request an autotext entry, looks into the active template first, then in add in templates and finally in the normal template. This appears rather complex to arrange with VBA.

While you can insert an autotext entry using VBA from the attached (active) template or from the normal template, if it is present relatively simply, provided you know its location and it is present. The problems arise when the location is not known or may not be present.

The following macro first checks whether the document template is the normal template. If it is not, then the document template is checked for the entry. If it is or if the entry has not been found, the macro then checks all installed add-ins. Finally, if the normal template was not checked in the first step, it is now checked. If the entry is found in any of these locations the entry is inserted and the macro quits. If not the user is given a message to that effect.

Word 2007 & 2010

Word 2007 introduced building blocks which added a whole lot of other parameters and a separate building blocks template where autotext entries could be stored. Provided the autotext entry that you wish to insert is defined in the autotext gallery (or it is included in a Word 97-2003 format template or add-in, then the first macro will work as it stands.

If you want to check all the galleries, then you will need some extra code. In addition to checking the active template, add-in templates and the normal template, the second macro looks in the building blocks.dotx template.

It is to be hoped that if you are using VBA to insert entries, you might have a better idea of where they are stored beforehand, but the macro below should do the trick wherever they are.

Option Explicit

Sub InsertMyAutotext()
Dim oAT As AutoTextEntry
Dim oTemplate As Template
Dim oAddin As AddIn
Dim bFound As Boolean
Const strAutoTextName As String = "AutoText Name" 'Define the required autotext entry

'Set the found flag default to False
bFound = False
'Ignore the attached template for now if the
'document is based on the normal template
If ActiveDocument.AttachedTemplate <> NormalTemplate Then
Set oTemplate = ActiveDocument.AttachedTemplate
'Check each autotext entry in the attached template
For Each oAT In oTemplate.AutoTextEntries
'Look for the autotext name
If oAT.name = strAutoTextName Then
'if found insert it
oTemplate.AutoTextEntries(strAutoTextName).Insert _
Where:=Selection.Range
'Set the found flag to true
bFound = True
'Clean up and stop looking
Set oTemplate = Nothing
GoTo lbl_Exit
End If
Next oAT
End If
'Autotext entry was not found
If bFound = False Then
For Each oAddin In AddIns
'Check currently loaded add-ins
If oAddin.Installed = False Then GoTo Skip
Set oTemplate = Templates(oAddin.Path & _
Application.PathSeparator & oAddin.name)
'Check each autotext entry in the current attached template
For Each oAT In oTemplate.AutoTextEntries
If oAT.name = strAutoTextName Then
'if found insert it
oTemplate.AutoTextEntries(strAutoTextName).Insert _
Where:=Selection.Range
'Set the found flag to true
bFound = True
'Clean up and stop looking
Set oTemplate = Nothing
GoTo lbl_Exit
End If
Next oAT
Skip:
Next oAddin
End If
'The entry has not been found check the normal template
If bFound = False Then
For Each oAT In NormalTemplate.AutoTextEntries
If oAT.name = strAutoTextName Then
NormalTemplate.AutoTextEntries(strAutoTextName).Insert _
Where:=Selection.Range
bFound = True
Exit For
End If
Next oAT
End If
'All sources have been checked and the entry is still not found
'so tell the user.
If bFound = False Then
MsgBox "Entry not found", _
vbInformation, _
"Autotext " _
& Chr(145) & strAutoTextName & Chr(146)
End If
lbl_Exit:
Exit Sub
End Sub

Insert Autotext Entry with VBA - Word 2007/2010

Option Explicit

Sub InsertMyBuildingBlock()
Dim oTemplate As Template
Dim oAddin As AddIn
Dim bFound As Boolean
Dim i As Long
'Define the required building block entry
Const strBuildingBlockName As String = "Building Block Name"

'Set the found flag default to False
bFound = False
'Ignore the attached template for now if the
'document is based on the normal template
If ActiveDocument.AttachedTemplate <> NormalTemplate Then
Set oTemplate = ActiveDocument.AttachedTemplate
'Check each building block entry in the attached template
For i = 1 To oTemplate.BuildingBlockEntries.Count
'Look for the building block name
'and if found, insert it.
If oTemplate.BuildingBlockEntries(i).name = strBuildingBlockName Then
oTemplate.BuildingBlockEntries(strBuildingBlockName).Insert _
Where:=Selection.Range
'Set the found flag to true
bFound = True
'Clean up and stop looking
Set oTemplate = Nothing
GoTo lbl_Exit
End If
Next i
End If
'The entry has not been found
If bFound = False Then
For Each oAddin In AddIns
'Check currently loaded add-ins
If oAddin.Installed = False Then Exit For
Set oTemplate = Templates(oAddin.Path & _
Application.PathSeparator & oAddin.name)
'Check each building block entry in the each add in
For i = 1 To oTemplate.BuildingBlockEntries.Count
If oTemplate.BuildingBlockEntries(i).name = strBuildingBlockName Then
'Look for the building block name
'and if found, insert it.
oTemplate.BuildingBlockEntries(strBuildingBlockName).Insert _
Where:=Selection.Range
'Set the found flag to true
bFound = True
'Clean up and stop looking
Set oTemplate = Nothing
GoTo lbl_Exit
End If
Next i
Next oAddin
End If
'The entry has not been found. Check the normal template
If bFound = False Then
For i = 1 To NormalTemplate.BuildingBlockEntries.Count
If NormalTemplate.BuildingBlockEntries(i).name = strBuildingBlockName Then
NormalTemplate.BuildingBlockEntries(strBuildingBlockName).Insert _
Where:=Selection.Range
'set the found flag to true
bFound = True
GoTo lbl_Exit
End If
Next i
End If
'If the entry has still not been found
'finally check the Building Blocks.dotx template
If bFound = False Then
Templates.LoadBuildingBlocks
For Each oTemplate In Templates
If oTemplate.name = "Building Blocks.dotx" Then Exit For
Next
For i = 1 To Templates(oTemplate.FullName).BuildingBlockEntries.Count
If Templates(oTemplate.FullName).BuildingBlockEntries(i).name = strBuildingBlockName Then
Templates(oTemplate.FullName).BuildingBlockEntries(strBuildingBlockName).Insert _
Where:=Selection.Range
'set the found flag to true
bFound = True
'Clean up and stop looking
Set oTemplate = Nothing
GoTo lbl_Exit
End If
Next i
End If
'All sources have been checked and the entry is still not found
If bFound = False Then
'so tell the user.
MsgBox "Entry not found", _
vbInformation, _
"Building Block " _
& Chr(145) & strBuildingBlockName & Chr(146)
End If
lbl_Exit:
Exit Sub
End Sub

Click the links below for more Word macros

Page 1

Insert Field formatting switch
Number documents
Paste unformatted text
Copy footnotes c/w formatting to a new document
Send the current document from Word by e-mail as an attachment, with the header details pre-completed, e.g. for the return of a completed form document.
Toggle the SQL security entry in the registry through vba

Page 2

True title case
Extract acronyms to a new document
Format part of a found text string
Format part of a found text string in a list of items
Add a row to a table in a protected form

This page

Create a bar chart based on the content of a dropdown form field
Repeat a block of formatted text and form fields based upon the content of another form field
Colour a form field check box with a contrasting colour when it is checked.
Count times entered into a document
Transpose Characters
Insert Autotext Entry with VBA
Insert Building Blocks with VBA

Page 4

Replace a list of words from an array
Replace a list of words from a table
Replace a list of words from a table and offer a choice of replacements
Add tabs to centre of text area and right margin
Extract e-mail addresses from a document to a list
Fix scrambled view of some open type fonts in Word 2010
Word 2010 Print Preview

Useful Functions

BrowseforFile
Browse for Folder
FileExists
FolderExists
CleanFileName
FileNameUnique
FolderNameUnique
CreateFolders
UpdateTemplate
ExtractDigits - from text string
FillBM
ImageToBM
IsInteger
Validate Userform TextBox

Graham Mayor

... helping to ease the lives of Microsoft Word users.

You appear to be using ad blocking software. While I respect your right to do so, please be aware that the minimal advertising on this site helps defray the cost of providing this facility, and I would therefore ask that you turn off the blocker while browsing this site.