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

  1. Select the text you want to convert.
  2. Select cleanTable from your macro list.
  3. 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.

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