Word Macros I've written
Here are some macros I've written for Microsoft Word. Since I wouldn't have been able to write these without the examples provided by many other people and put on line, I'm releasing them under the Creative Commons Attribution-Noncommercial-Share Alike 3.0 United States License.
I've only run these from Microsoft Word 2003 and Visio 2003, so your mileage may vary. If they cause problems on your system, you can't sue me, you use them at your own risk, etc. etc. I also make no promise that they'll work for you at all. These macros are written in VBA, which is being phased out in favor of signed code.
508 Compliance
CheckAltText
This macro will go through every InlineShape in the active Word document and see if the shape has alternate text. If there is no alternate text, this macro will throw a dashed red border around the image.
Note that this macro also requires shapesToInlineShapes() (below) to function correctly. (This is not a huge problem. After all, if you want to create 508 compliant Word documents, you should probably be using InlineShapes only anyway. The Shapes that "float" are like Post-it notes; they may be ignored by screen readers or "fall off the page" some other way.)
Sub checkAltText()
'Check pictures for Alternate text and add it if not present.
'Copyright 2006 by Matt Bear.
'Released under terms of Creative Commons Attribution-Noncommercial-Share Alike 3.0 United States License
shapesToInlineShapes
Dim sAltText As String
For Each InlineShape In ActiveDocument.InlineShapes
sAltText = InlineShape.AlternativeText
'Do While sAltText = ""
If sAltText = "" Then
InlineShape.Select 'show me which image is missing text.
InlineShape.Borders.Enable = True
InlineShape.Borders.OutsideColor = wdColorRed
InlineShape.Borders.OutsideLineWidth = wdLineWidth300pt
InlineShape.Borders.OutsideLineStyle = wdLineStyleOutset
ElseIf sAltText <> "" Then
InlineShape.Borders.Enable = False
End If
Next InlineShape
End Sub
ShapesToInlineShapes
Makes sure each shape in the active document is an InlineShape so checkAltText will work correctly. Since Word's drawing tools use shapes and not InlineShapes, and are a royal pain in the neck to make compliant, just run this subroutine to convert any Shape to its InlineShape equivalent.
The macro will not convert objects linked into a document via OLE. If the document this macro is run against has any such objects, a messagebox will appear and display the page with the object.
Sub shapesToInlineShapes()
'Makes sure each shape in the active document is an InlineShape so checkAltText will work correctly.
'Copyright 2006 by Matt Bear.
'Released under terms of Creative Commons Attribution-Noncommercial-Share Alike 3.0 United States License
Dim q As Long
Dim shCount As Long
Dim rCnt As Long
Dim pageNum As Long
rCnt = 0
For Each Shape In ActiveDocument.Shapes
Shape.Select 'show me which image is active
pageNum = Selection.Information(wdActiveEndPageNumber)
'MsgBox ("page: " & pageNum) 'debug
Select Case Shape.Type
Case msoEmbeddedOLEObject
Case 1 'goofy autoshape I can't figure out.
q = MsgBox("There is an embedded object on page " & pageNum & " that this macro cannot make compliant.", _
vbInformation, "Non-Compliant Object")
Case Else
Shape.ConvertToInlineShape
rCnt = rCnt + 1
End Select
Next Shape
MsgBox ("Reformatted " & rCnt & " shapes (images)." & vbCrLf _
& "Some text formatting alterations may have occurred." & vbCrLf _
& "Please review the document and correct any formatting errors.")
End Sub
SelectricColumns (formatting macro)
When I first started my contract job at DFAS-Columbus, my teammates were taking a lot of preformatted materials and stripping out extra spaces, tabs, etc. by hand. This worked pretty well, considering that the content we had was set up as a pair of "table columns" that were set up via the creative use of spaces, rather than Word's native columns or table tools. The problem was that it took a long time to get anything done. So I wrote a macro that would automatically convert the selected content into a table. This macro reduced the manual work by 90%.
Directions
- Select the text you want to convert.
- Select cleanTable from your macro list.
- The macro should run, and replace your faux columns with a table that has two columns.
This is actually a set of four macros that run in sequence to accomplish what I wanted. If you can make it better, more power to you.
Sub SelectricColumns()
'version 3.7 - delete empty table rows
'Copyright 2006 by Matt Bear.
'Released under terms of Creative Commons Attribution-Noncommercial-Share Alike 3.0 United States License
If Selection.Type = wdSelectionIP Then
MsgBox ("Error: No text was selected." & vbCrLf & "Please select text and try again.")
Else
removeSpaces
ClearFindAndReplaceParameters
makeTable
deleteEmptyRows
End If
End Sub
MakeTable
Needed by SelectricColumns.
Sub makeTable()
Selection.ConvertToTable Separator:=wdSeparateByTabs, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
.PreferredWidthType = wdPreferredWidthPoints
.PreferredWidth = InchesToPoints(6) 'make the table 6" wide.
End With
End Sub
ClearFindAndReplaceParameters
Not needed by SelectricColumns, but it will clear anything left behind in the Find and Replace dialog box. Just to clear out any weirdness that may be left behind by the process.
Sub ClearFindAndReplaceParameters()
'from http://word.mvps.org/FAQs/MacrosVBA/ClearFind.htm
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End Sub
DeleteEmptyRows
Needed by SelectricColumns, this macro will find any empty table rows in the text that was selected and converted into a table and remove them automatically.
Sub deleteEmptyRows()
'from http://word.mvps.org/FAQs/MacrosVBA/DeleteEmptyRowsContent.htm
Dim oTable As Table, oRow As Range, oCell As Cell, counter As Long, NumRows As Long, TextInRow As Boolean
'specify which table to work on
Set oTable = Selection.Tables(1)
'set a range variable to the first row's range
Set oRow = oTable.Rows(1).Range
NumRows = oTable.Rows.Count
Application.ScreenUpdating = False
For counter = 1 To NumRows
StatusBar = "Row " & counter
TextInRow = False
For Each oCell In oRow.Rows(1).Cells
If Len(oCell.Range.Text) > 2 Then
'end of cell marker is actually 2 characters
TextInRow = True
Exit For
End If
Next oCell
If TextInRow Then
Set oRow = oRow.Next(wdRow)
Else
oRow.Rows(1).Delete
End If
Next counter
Application.ScreenUpdating = True
End Sub
RemoveSpaces
Needed by SelectricColumns. This will delete the long rows of spaces used by people to create the false columns. The only restriction is that it will only replace 3 or more spaces in a row. This will preserve the two spaces that (should) occur after each punctuation mark.
Sub removeSpaces()
With Selection.Find
.MatchWildcards = True
.Text = "[ ]{3,}"
.Replacement.Text = vbTab
.Execute Replace:=wdReplaceAll, Forward:=True
End With
End Sub
UpdateDraftNumber
In order to be sure I had the most up to date copy of the document, I decided to create a custom document property that would show the latest draft number. This number would be incremented automatically when the document was closed.
Didn't that duplicate functions that already exist in Word? Sure does. The problem is that Word's built-in functions are flaky, and don't always get the correct information.
When you add in the fact that there were several authors working on each document, you can see how the problems with this stuff multiply very quickly. Duplicating the Word functions with something that I knew would work was just common sense.
Sub updateDraftNumber()
Dim dnProp As DocumentProperty
Set dnProp = ActiveDocument.CustomDocumentProperties("DraftNo")
dnProp = dnProp + 1
ActiveDocument.CustomDocumentProperties("DraftNo") = dnProp
'Runs automatically on document close.
End Sub
References
Here are some of the sites and articles I found useful while putting together these macros.
- Working with Word 2003 Images Programmatically
- The Word MVP Site, particularly the Macros/VBA section.
- The Office 2003 VBA Reference.
Visio 2003 Macro
A quick macro for Visio to save each page of a Visio diagram as a WMF image. Visio macros are not as transportable as Word macros as there is no NORMAL.DOT equivalent. (Well, I couldn't find it at any rate.)
Sub SaveAllPagesAsWMF()
'Macro will save all pages of Visio drawing as a set of WMF images.
'Each page is its own image.
'bulk of this was found at http://www.mvps.org/visio/VBA.htm under "Export Pages"
'Set up variables to hold stuff. Just declaring them here, no values assigned.
Dim myPageArray As Pages
Dim myVisioFileName As String
Dim myVisioFileNameLength As Integer
Dim TotalPages As Integer
Dim WmfFile As String 'Have to get name of page to name WMF file correctly.
'assign initial values to variables.
'get current file name
myVisioFileName = Application.ActiveDocument.Name
'get length of file name [Len(myVisioFileName)] and subtract last 4 characters...
myVisioFileNameLength = Len(myVisioFileName) - 4
'... to get Visio file name without extension.
myVisioFileName = Left(myVisioFileName, myVisioFileNameLength)
Set myPageArray = Application.ActiveDocument.Pages
TotalPages = myPageArray.Count
For N = 1 To TotalPages
Set CurrentPage = myPageArray(N)
PgName = CurrentPage.Name
ExportName = Application.ActiveDocument.Path + myVisioFileName + " - " + PgName + ".WMF"
CurrentPage.Export ExportName
Next N
End Sub