wordsite.com

   
 


Frequently Asked Questions about Macros

Introduction to VBA Programming

Programming fundamentals

Returning information

Working with tables

Miscellaneous routines

New Routines 1999-2001

Microsoft is a registered trademark of Microsoft Corporation
 
 

   


New Routines 1999-2001

Click a topic:

Flush bad karma from Word's find facility after an unsuccessful wildcard search.

Detect when Word is trapped with a partial wildcard match at the very end of a document.

Clear settings from find dialog to prevent unexpected results from future find operations.

Insert into a document the names of all files in a selected folder.

Assign the enter key to a macro.

Retrieve Word's Documents folder setting from the registry and display it to the user in a message box.

Apply the built-in Heading 1 paragraph style to all paragraphs containing text in ALL CAPS.

Unlink all fields in the body of a document.

Unlink all fields located in the headers and footers of a document.

Delete any paragraph that is an exact duplicate of the preceding paragraph, using a Range object.

Delete any paragraph that is an exact duplicate of the preceding paragraph, using the selection object.

Remove all menus from the Customize menu.

Intercept the Keyboard... button on the ToolsCustomize dialog box.

Assign arrow keys to a series of macros so that action of the arrow keys can be determined by the programmer rather than by Word's built-in routines.

Print all documents in a given folder to a single print file.

Access a database and insert into a Word document the data that you find there.


Flush bad karma from Word's find facility after an unsuccessful wildcard search. <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 WildcardSearch()
'call a routine that removes any previous settings from the find dialog
ClearFindParameters
myWorkingRange.Find.Execute FindText:="[!^013]", _
MatchWildcards:=True, Forward:=True
'exit sub if search is successful
If myWorkingRange.Find.Found Then
MsgBox "tell the user something"
ClearFindParameters
Exit Sub
End If
'this is a dummy search because otherwise
'subsequent searches will break down
'somehow this search flushes the bad karma
'and lets subsequent searches function
myWorkingRange.Find.Execute FindText:="^p", _
MatchWildcards:=False
'call a routine that removes all settings from the find dialog
'so future users of the dialog won't get strange results
ClearFindParameters
End Sub

Detect when Word is trapped with a partial wildcard match at the very end of a document. <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.
SearchString(0) = "\<\<"
SearchString(1) = "\<[!>]@\<"
SearchString(2) = "\>\>"
SearchString(3) = "\>[!<]@\>"
For i = 0 To 3
Selection.HomeKey unit:=wdStory
'call subroutine that clears settings from find dialog
ClearFindParameters
With Selection.Find
.Text = SearchString(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While Selection.Find.Execute()
'here's where we detect the fact that
'Word got lost at the end of the doc
If Selection.End = 0 Then Exit Do
'insert code here to act on found text
Selection.Collapse wdCollapseEnd
Loop
Next I

Clear settings from find dialog to prevent unexpected results from future find operations. <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 ClearFindParameters()
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.ClearFormatting
.Replacement.ClearFormatting
End With
End Sub

Insert into a document the names of all files in a selected folder. <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 InsertNamesOfFilesInAFolder()
'let user select a path
With Dialogs(wdDialogCopyFile)
If .Display() <> -1 Then Exit Sub
MyPath = .Directory
End With
'strip quotation marks from path
If Len(MyPath) = 0 Then Exit Sub
If Asc(MyPath) = 34 Then
MyPath = Mid$(MyPath, 2, Len(MyPath) - 2)
End If
'get files from the selected path
'and insert them into the doc
MyName = Dir(MyPath & "*.*")
Do While MyName <> ""
Selection.InsertAfter MyName & vbCr
MyName = Dir
Loop
'collapse the selection
Selection.Collapse wdCollapseEnd
End Sub

Assign the enter key to a macro. <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.
'create a macro to run when the enter key is pressed
Sub myEnterKeyMacro()
MsgBox "Sorry, the enter key has been disabled."
End Sub
'assign the macro to the enter key
Sub AssignEnterKey()
CustomizationContext = NormalTemplate
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyReturn), _
KeyCategory:=wdKeyCategoryMacro, Command:="myEnterKeyMacro"
End Sub
'run a macro to confirm the assignment
Sub DisplayEnterKeyAssignment()
CustomizationContext = NormalTemplate
MsgBox FindKey(BuildKeyCode(Arg1:=wdKeyReturn)).Command
End Sub

Retrieve Word's Documents folder setting from the registry and display it to the user in a message box. <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.
myDocPath = System.PrivateProfileString("", _
"HKEY_CURRENT_USER\Software\Microsoft\Office\8.0\Word\Options", "DOC-PATH")
MsgBox myDocPath

Apply the built-in Heading 1 paragraph style to all paragraphs containing text in ALL CAPS. <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 FindAllCaps()
'start at beginning of doc
Selection.HomeKey wdStory
'get rid of any previous format criteria in the find dialog
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'search for any paragraph that has no lowercase letters
'WARNING: If you need to exclude paragraphs with numerals,
'change the .Text argument to [!^013a-z0-9]@^013
With Selection.Find
.Text = "[!^013a-z]@^013"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
While Selection.Find.Execute()
'change the style only if the found text
'represents the entire paragraph
If Selection.Start = _
Selection.Paragraphs.First.Range.Start Then
Selection.Style = wdStyleHeading1
End If
'position the cursor after the found text
'in preparation for finding the next occurrence
Selection.Collapse wdCollapseEnd
Wend
End Sub

Unlink all fields in the body of a document. <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.
For Each oField In ActiveDocument.Fields
oField.Unlink
Next oField

Unlink all fields located in the headers and footers of a document. <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.
Dim oField As Field
Dim oSection As Section
Dim oHeader As HeaderFooter
Dim oFooter As HeaderFooter
For Each oSection In ActiveDocument.Sections
For Each oHeader In oSection.Headers
If oHeader.Exists Then
For Each oField In oHeader.Range.Fields
oField.Unlink
Next oField
End If
Next oHeader
For Each oFooter In oSection.Footers
If oFooter.Exists Then
For Each oField In oFooter.Range.Fields
oField.Unlink
Next oField
End If
Next oFooter
Next oSection

Delete any paragraph that is an exact duplicate of the preceding paragraph, using a Range object. <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.
Dim AmountMoved As Integer
Dim myRange As Range
'start with first paragraph and extend range down to second
Set myRange = ActiveDocument.Paragraphs(1).Range
AmountMoved = myRange.MoveEnd(unit:=wdParagraph, Count:=1)
'loop until there are no more paragraphs to check
Do While AmountMoved > 0
'if two paragraphs are identical, delete second one
'and add the one after that to myRange so it can be checked
If myRange.Paragraphs(1).Range.Text = _
myRange.Paragraphs(2).Range.Text Then
myRange.Paragraphs(2).Range.Delete
AmountMoved = myRange.MoveEnd(unit:=wdParagraph, Count:=1)
Else
'if two paragraphs aren't identical, add the one after
'that to my range, so it can be checked, and drop the first one,
'since it is no longer of interest.
AmountMoved = myRange.MoveEnd(unit:=wdParagraph, Count:=1)
myRange.MoveStart unit:=wdParagraph, Count:=1
End If
Loop

Delete any paragraph that is an exact duplicate of the preceding paragraph, using the selection object. <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.
Dim AmountMoved As Integer
'select first two paragraphs
Selection.HomeKey unit:=wdStory
Selection.MoveDown unit:=wdParagraph, Count:=1, Extend:=wdExtend
AmountMoved = Selection.MoveDown(unit:=wdParagraph, Count:=1,
Extend:=wdExtend)
'loop until no more paragraphs to move down to
Do While AmountMoved > 0
If Selection.Paragraphs(1).Range.Text = Selection.Paragraphs(2).Range.Text
Then
Selection.Paragraphs(2).Range.Delete
AmountMoved = Selection.MoveDown(unit:=wdParagraph, Count:=1,
Extend:=wdExtend)
Else
AmountMoved = Selection.MoveDown(unit:=wdParagraph, Count:=1,
Extend:=wdExtend)
Selection.MoveStart unit:=wdParagraph, Count:=1
End If
Loop
'Return to top of doc
Selection.HomeKey unit:=wdStory

Remove items from the Customize menu. <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 RemoveItemsFromCustomizeMenu()
Dim oCommandBar As CommandBar
On Error Resume Next
For Each oCommandBar In CommandBars
oCommandBar.Protection = _
msoBarNoChangeDock + msoBarNoChangeVisible _
+ msoBarNoCustomize + msoBarNoMove + Noresize
Next oCommandBar
End Sub

Intercept the Keyboard... button on the ToolsCustomize dialog box. <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 ToolsCustomizeKeyboard()
MsgBox "That function has been disabled."
End Sub
Other customization routines that can be intercepted in a similar way:
ToolsCustomize
ToolsCustomizeAddMenuShortcut
ToolsCustomizeKeyboard
ToolsCustomizeKeyboardShortcut
ToolsCustomizeMenus
ToolsCustomizeRemoveMenuShortcut

Assign arrow keys to a series of macros so that action of the arrow keys can be determined by the programmer rather than by Word's built-in routines. <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 AssignArrowKeysToAMacro()
KeyBindings.Add _
KeyCategory:=wdKeyCategoryMacro, _
Command:="LeftArrowKeyMacro", _
KeyCode:=37
KeyBindings.Add _
KeyCategory:=wdKeyCategoryMacro, _
Command:="UpArrowKeyMacro", _
KeyCode:=38
KeyBindings.Add _
KeyCategory:=wdKeyCategoryMacro, _
Command:="RightArrowKeyMacro", _
KeyCode:=39
KeyBindings.Add _
KeyCategory:=wdKeyCategoryMacro, _
Command:="DownArrowKeyMacro", _
KeyCode:=40
End Sub
Sub LeftArrowKeyMacro()
MsgBox "You pressed the left arrow key."
End Sub
Sub UpArrowKeyMacro()
MsgBox "You pressed the up arrow key."
End Sub
Sub RightArrowKeyMacro()
MsgBox "You pressed the right arrow key."
End Sub
Sub DownArrowKeyMacro()
MsgBox "You pressed the down arrow key."
End Sub

Print all documents in a given folder to a single print file. <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.
Dim MyFile, MyPath, MyName
MyPath = "c:\my documents\*.doc"
MyName = Dir(MyPath)
MsgBox "About to print " & MyName & "to c:\myfile.prn"
'Application.PrintOut _
Background:=False, _
Append:=False, _
OutputFilename:="c:\myfile.prn", _
PrintToFile:=True, _
FileName:=MyName
MyName = Dir
Do While MyName <> ""
MsgBox "About to append " & MyName & " to c:\myfile.prn"
'Application.PrintOut _
Background:=False, _
Append:=True, _
OutputFilename:="c:\myfile.prn", _
PrintToFile:=True, _
FileName:=MyName
MyName = Dir
Loop

Access a database and insert into a Word document the data that you find there. <Top of Page>

Solution:
The basic concepts involved in doing this aren't very difficult. The following code assumes that you have an Access database called DataBase.mdb stored in a folder called C:\DataBaseFolder. Further, it assumes that this database contains a table called Table_1 and that this table contains two fields, one called Field_1 and the other called Field_2. Finally, it assumes that Field_1 is a numeric field and Field_2 is a text field.
The code looks up the value in Field_1. If the value is non-zero, the code inserts the text from Field_2 into the currently active Word document, at the current cursor location.
In a real situation, you might need to have bookmarks in your document (and its underlying template). Instead of inserting the database items at the current cursor location, you would insert them at the bookmarked locations.
One final tip: In order for this code to run, you must establish a reference, in your template, to Microsoft DAO 3.51 Object Library and Microsoft Datasource Interfaces. To do this, open the VB editor and choose References on the Tools menu.
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 GetDataFromDataBase()
'allocate memory for the database object as a whole and for the active record
Dim myDataBase As Database
Dim myActiveRecord As Recordset
'Open a database
Set myDataBase = OpenDatabase("C:\DataBaseFolder\Database.mdb")
'access the first record from a particular table
Set myActiveRecord = myDataBase.OpenRecordset("Table_1", dbOpenForwardOnly)
'loop through all the records in the table until the end-of-file marker is reached
Do While Not myActiveRecord.EOF
'If field #1 contains a non-zero value,
'insert the value of field #2 into the document
'after the current cursor or selection location
If myActiveRecord.Fields("Field_1") <> 0 Then
Selection.InsertAfter myActiveRecord.Fields("Field_2")
End If
'access the next record
myActiveRecord.MoveNext
Loop
'Then close the database
myActiveRecord.Close
myDataBase.Close
End Sub