There is no charge for using any of the material (for personal use) on this web site, but if you wish to make a contribution to the ever growing running costs, any donation would be much appreciated. Click the adjacent button to access PayPal

Frequently the Word forums throw up some interesting exercises in macro programming. Some of the better examples that my fellow MVPs and I have come up with appear elsewhere in the Word pages on this site. This page offers a place to present some code examples that may have wider use, which you can adapt to your own requirements. I will add to the examples as they come up, but for the moment we will start with the InsertField dialog:

Insert Field formatting switch

The InsertField dialog (the illustrations are from Word 2003 (top) and 2007, earlier versions are similar) has the Preserve formatting during updates check box checked by default, with no obvious way of resetting that default. This adds a MERGEFORMAT switch to the inserted field. Frankly I have never found any real use for the switch and so I always uncheck it .... when of course I remember, so the first macro I created simply intercepts the InsertFile command and uses the SendKeys command to physically uncheck the box i.e.

Sub InsertField()
SendKeys "{Tab}{Tab} +{Tab}+{Tab}"
Dialogs(wdDialogInsertField).Show
End Sub

Check the box and you will see the further dialog

{ CREATEDATE \@ "dddd, dd MMMM yyyy" }

Finish:
End Sub

Note:

This then negates the use of the above macro for Vista users, but I have included a modified version below with the SendKeys line removed and a separate step to remove the switch. It is not as elegant as un-checking the check box, but it does the job.

Windows Vista Version

The following will work in Windows XP also, but requires an extra step to overcome the SendKeys issue.

Finish:
End Sub

The Vista version of the macro has two message boxes. One of them is identical to the Windows XP version, the other is displayed when the user responds to the first box with 'No'

Number documents

The macro uses a bookmark in the document template named RecNo

Sub AddNoFromINIFileToBookmark()
Dim SettingsFile As String
Dim Order As String
Dim iCount As String
Dim rRecNo As Range
Dim i As Long
iCount = InputBox("Print how many copies?", _
"Print Numbered Copies", 1)
If iCount = "" Then Exit Sub
SettingsFile = Options.DefaultFilePath(wdStartupPath) & "\Settings.ini"
Order = System.PrivateProfileString(SettingsFile, _
"DocNumber", "Order")
If Order = "" Then
    Order = 1
End If
For i = 1 To iCount
    Set rRecNo = ActiveDocument.Bookmarks("RecNo").Range
    rRecNo.Text = Format(Order, "00000")
    With ActiveDocument
        .Bookmarks.Add "RecNo", rRecNo
        .Fields.Update
        .ActiveWindow.View.ShowFieldCodes = False
        .PrintOut
    End With
    Order = Order + 1
Next i
System.PrivateProfileString(SettingsFile, "DocNumber", _
"Order") = Order
End Sub


Sub ResetStartNo()
Dim SettingsFile As String
Dim Order As String
Dim sQuery As String
SettingsFile = Options.DefaultFilePath(wdStartupPath) & "\Settings.ini"
Order = System.PrivateProfileString(SettingsFile, _
"DocNumber", "Order")
sQuery = InputBox("Reset start number?", "Reset", Order)
If sQuery = "" Then Exit Sub
Order = sQuery
System.PrivateProfileString(SettingsFile, "DocNumber", _
"Order") = Order
End Sub
 

Instead of printing a batch of similar numbered documents, the following variation simply adds the incremented number to each new document created from the template at the bookmarked location named RecNo. The reset macro above will reset this version equally as the following uses the same stored number data.

Sub AutoNew()
Dim SettingsFile As String
Dim Order As String
Dim rRecNo As Range
Dim i As Long

SettingsFile = Options.DefaultFilePath(wdStartupPath) & "\Settings.ini"
Order = System.PrivateProfileString(SettingsFile, _
        "DocNumber", "Order")
If Order = "" Then
    Order = 1
End If
    Set rRecNo = ActiveDocument.Bookmarks("RecNo").Range
    rRecNo.Text = Format(Order, "00000")
    With ActiveDocument
        .Bookmarks.Add "RecNo", rRecNo
        .Fields.Update
        .ActiveWindow.View.ShowFieldCodes = False
    End With
    Order = Order + 1
System.PrivateProfileString(SettingsFile, "DocNumber", _
        "Order") = Order
End Sub

Paste unformatted text

If you paste text from the internet for example, the paste will bring across all the formatting of the web page, whereas users frequently require the pasted text to adopt the formatting of the document into which it is pasted. This can be achieved with Paste Special > Unformatted text, but the macro recorder will not accurately record that action so....

Sub PasteUnfText()
    On Error GoTo oops
    Selection.PasteSpecial _
    DataType:=wdPasteText, _
    Placement:=wdInLine
    End
oops:
Beep
End Sub

Copy footnotes c/w formatting to a new document

Sub CopyFootnotes()
Dim sDoc As Document
Dim tDoc As Document
Dim sId As String
Set sDoc = ActiveDocument
Set tDoc = Documents.Add
For i = 1 To sDoc.Footnotes.Count
    sId = sDoc.Footnotes(i).Index
    sDoc.Footnotes(i).Range.Select
    Selection.Copy
    tDoc.Activate
    With Selection
        .Style = "Footnote Text"
        .Font.Superscript = True
        .TypeText sId & " "
        .Font.Superscript = False
        .Paste
        .TypeParagraph
    End With
    sDoc.Activate
Next i
tDoc.Activate
End Sub
 

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.

'in the vba editor Tools > References
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
On Error Resume Next
If Len(ActiveDocument.Path) = 0 Then 'Document has not been saved
     ActiveDocument.Save 'so save it
End If
'see if Outlook is running and if so turn your attention there
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then 'Outlook isn't running
     'So fire it up
     Set oOutlookApp = CreateObject("Outlook.Application")
     bStarted = True
End If
'Open a new e-mail message
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem 'and add the detail to it
     .To = "someone@somewhere.com" 'send to this address
     .Subject = "New subject" 'This is the message subject
     .Body = "See attached document" ' This is the message body text
     .Attachments.Add Source:=ActiveDocument.FullName, Type:=olByValue
     .Send
     '**********************************
     'If you want to view the message before it goes
     'change the line above from .Send to .Display
     'Otherwise the message is sent straight to the Outbox
     'and if you have Outlook set to send mail immediately,
     'it will simply be Sent
     'with no obvious sign that Outlook has operated.
     'Apart from the copy in the Outlook Sent folder
'**********************************
End With
If bStarted Then 'If the macro started Outlook, stop it again.
     oOutlookApp.Quit
End If
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub

Toggle the SQL security entry in the registry through vba

This linked page explains how to create registry entries to turn off the security message. Some users have been concerned about the security implications of turning off this warning message. The following code was conceived with that issue in mind. The macro creates the registry entry if it is not present and then toggles the setting between 0 and 1 each time the macro is run. It could therefore be adapted for use in a mail merge macro to switch off the warning while the particular merge was run, then switch it back on again on completion.

     MsgBox "SQL Security checking is switched on", vbInformation, "SQL Check"
End If
End Sub
 

True title case

If one of the listed words was the first word in the selected text, then it too would be set in lower case, so that too needs to be corrected, and similarly if there is a colon in the selected text, the word following the colon would need to be corrected. The macro forces capitalization on the first letters of all words that appear in either position.

Sub TrueTitleCase()
Dim sText As Range
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Dim k As Long
Dim m As Long
Set sText = Selection.Range
'count the characters in the selected string
k = Len(sText)
If k < 1 Then 'If none, then no string is selected
'so warn the user
     MsgBox "Select the text first!", vbOKOnly, "No text selected"
     Exit Sub 'and quit the macro
End If
'format the selected string as title case
sText.Case = wdTitleWord
'list the exceptions to look for in an array
vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
"If", "In", "Of", "On", "Or", "The", "To", "With")
'list their replacements in a matching array
vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
"if", "in", "of", "on", "or", "the", "to", "with")
With sText
     With .Find
     'replace items in the first list
     'with the corresponding items from the second
          .ClearFormatting
          .Replacement.ClearFormatting
          .Forward = True
          .Wrap = wdFindStop
          .MatchWholeWord = True
          .MatchWildcards = False
          .MatchSoundsLike = False
          .MatchAllWordForms = False
          .Format = True
          .MatchCase = True
          For i = LBound(vFindText) To UBound(vFindText)
               .Text = vFindText(i)
               .Replacement.Text = vReplText(i)
               .Execute Replace:=wdReplaceAll
          Next i
     End With
     'Reduce the range of the selected text
     'to encompass only the first character
     .MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
     'format that character as upper case
     .Case = wdUpperCase
     'restore the selected text to its original length
     .MoveEnd Unit:=wdCharacter, Count:=k
     'and check to see if the string contains a colon
     If InStr(1, sText, ":") > 0 Then
     'If it does note the position of the character
     'after the first colon
          m = InStr(1, sText, ":") + 1
          'and set that as the new start of the selected text
          .MoveStart wdCharacter, m
          'set the end of the selected text to include
          'one extra character
          .MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
          'format that character as upper case
          .Case = wdUpperCase
     End If
End With
End Sub

Extract Acronyms to a new document

A newsgroup contributor asked if it was possible to extract acronyms to a new document. The following will extract all words in the format NATO or N.A.T.O. consisting of more than two characters to a new document. The list is then sorted and duplicate entries removed. The macro does not extract acronyms that are adopted as proper nouns e.g. Unesco.

End Sub

Format part of a found text string

You could create a macro to do so.

End Sub

Add a row to a table in a protected form

The modified solution works in a table with seven columns. The content of the fields in the first six columns is added in the final column.

    With ActiveDocument
          .Protect NoReset:=True, Password:="sPassword", _
          Type:=wdAllowOnlyFormFields 'Reprotect the form
          .Range.FormFields("col1row" & CurRow).Select 'Select the first field in the new row
     End With
End If
End Sub
 

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.

If sCount = 0 Then GoTo Quit '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

Quit: 'Re-protect the form and apply the password (if any).
If bProtected = True Then
     ActiveDocument.Protect _
     Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=sPassword
End If
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
End Function