create a new document containing all the tables of the current one:
Sub extract_data()
  Set actDoc = ActiveDocument
  Set newDoc = Documents.Add
  actDoc.Activate
  For Each aTable In actDoc.Tables
    aTable.Range.Copy
    Set Range = newDoc.Content
    Range.Collapse Direction:=wdCollapseEnd
    Range.Paste
  Next aTable
End Sub

transfer the requirement tables into Excel via a text file:
Sub extract_data_txt()
   Dim extractionFormat As String
   extractionFormat = "txt" ' "htm" should also be supported
' create the temporary documentation
   Dim actDoc, newDoc As Variant
   Set actDoc = ActiveDocument
   Set newDoc = Documents.Add
' copy the requirement tables in the temporary file
   Dim i, r, c, j As Integer
   For i = 1 To actDoc.Tables.Count
     Application.StatusBar = "copying table " & i & "/" & actDoc.Tables.Count
     Dim aTable, firstCell As Variant
     Set aTable = actDoc.Tables(i)
     Set firstCell = aTable.Cell(1, 1)
     If (actDoc.Range(firstCell.Range.Start, firstCell.Range.End - 1).Text = "Identifier") Then
         For r = 2 To aTable.Rows.Count
            For c = 1 To aTable.Columns.Count
                 If (c > 1) Then
                    newDoc.Content.InsertAfter (vbTab)
                 End If
                 Dim cellText As String
                 cellText = actDoc.Range(aTable.Cell(r, c).Range.Start, aTable.Cell(r, c).Range.End - 1).Text
                 cellText = Replace(cellText, """", """""")
                 cellText = Replace(cellText, "“", """""")
                 cellText = Replace(cellText, "”", """""")
                 newDoc.Content.InsertAfter ("""" & cellText & """")
             Next c
             newDoc.Content.InsertParagraphAfter
         Next r
    End If
   Next i
' compute the name of the temporary file
   Dim newDocname As String
   newDocname = actDoc.FullName
   newDocname = Left(newDocname, InStr(newDocname, ".") - 1)
   newDocname = newDocname & "_extract." & extractionFormat
' save the temporary file
   newDoc.SaveAs FileName:=newDocname, FileFormat:=wdFormatText
   newDoc.Close
' start Excel on the temporary file
   Shell "excel """ & newDocname & """", vbNormalFocus
  End Sub

transfer the requirement tables into Excel via a HTML file:
Sub extract_data()
' compute the name of the temporary file
   Set actDoc = ActiveDocument
   newDocname = ActiveDocument.FullName
   pos = InStr(newDocname, ".")
   newDocname = Left(newDocname, pos - 1)
   newDocname = newDocname & "_extract.htm"
' create the temporary documentation
   Set newDoc = Documents.Add
' copy the requirement tables in the temporary documentation
   actDoc.Activate
   For Each aTable In actDoc.Tables
     Set firstCell = aTable.Cell(1, 1)
     If (ActiveDocument.Range(firstCell.Range.Start, firstCell.Range.End - 1).Text = "Identifier") Then
       ActiveDocument.Range(aTable.Cell(2, 1).Range.Start, _
                            aTable.Cell(aTable.Rows.Count, aTable.Columns.Count).Range.End).Copy
       Set Range = newDoc.Content
       Range.Collapse Direction:=wdCollapseEnd
       Range.Paste
     End If
   Next aTable
' Reset the width of the temporary table in case some tables has bad widths in the original document
   Set newTable = newDoc.Tables(1)
   For c = 1 To newTable.Columns.Count
     For r = 2 To newTable.Rows.Count
       newTable.Cell(r, c).Width = newTable.Cell(1, c).Width
     Next r
   Next c
' Uncomment the next line if you just want the traceability (i.e. remove the requirements in the Excel file)
'   newTable.Columns(2).Delete
' save the temporary documentation in the temporary file
   newDoc.SaveAs FileName:=newDocname, FileFormat:=wdFormatHTML
   newDoc.Close
' start Excel on the temporary file
   Shell "excel """ & newDocname & """", vbNormalFocus
 End Sub
second version, faster but dirtier 
 Sub extract_data()
' compute the name of the temporary file
   Set actDoc = ActiveDocument
   newDocname = ActiveDocument.FullName
   pos = InStr(newDocname, ".")
   newDocname = Left(newDocname, pos - 1)
   newDocname = newDocname & "_extract.htm"
' create the temporary documentation
   Set newDoc = Documents.Add
' copy the requirement tables in the temporary documentation
   actDoc.Activate
   Dim newTable
   For i = 1 To actDoc.Tables.Count
     StatusBar = "copying table " & i & "/" & actDoc.Tables.Count
     Set aTable = actDoc.Tables(i)
     Set firstCell = aTable.Cell(1, 1)
     If (ActiveDocument.Range(firstCell.Range.Start, firstCell.Range.End - 1).Text = "Identifier") Then
' reset the width of the temporary table in case some tables have incorrect widths in the original document
       If (Not IsEmpty(newTable)) Then
         For c = 1 To newTable.Columns.Count
           aTable.Columns(c).SetWidth ColumnWidth:=newTable.Columns(c).Width, RulerStyle:=wdAdjustFirstColumn
         Next c
       Else
' copy the column titles
         ActiveDocument.Range(aTable.Cell(1, 1).Range.Start, _
                              aTable.Cell(1, aTable.Columns.Count).Range.End).Copy
         Set Range = newDoc.Content
         Range.Collapse Direction:=wdCollapseEnd
         Range.Paste

       End If
       ActiveDocument.Range(aTable.Cell(2, 1).Range.Start, _
                            aTable.Cell(aTable.Rows.Count, aTable.Columns.Count).Range.End).Copy
' now that we have copied the table with the right widths, we cancel the changes
       If (Not IsEmpty(newTable)) Then
         ActiveDocument.Undo (newTable.Columns.Count)
       End If
' paste the table at the end of the temporary document
       Set Range = newDoc.Content
       Range.Collapse Direction:=wdCollapseEnd
       Range.Paste
' initialise the temporary table if it has just been created
       If (IsEmpty(newTable)) Then
          Set newTable = newDoc.Tables(1)
       End If
     End If
   Next i
' ### BEGIN ### Uncomment the next lines if you just want the traceability (i.e. remove the requirements in the Excel file)
'   newTable.Columns(2).Delete
' ### END ###
' save the temporary documentation in the temporary file
   newDoc.SaveAs FileName:=newDocname, FileFormat:=wdFormatHTML
   newDoc.Close
' start Excel on the temporary file
   Shell "excel""" & newDocname & """", vbNormalFocus
  End Sub
 
explicitly write the hyperlinks contained in the document:
Sub ShowURLs()
     For Each aField In ActiveDocument.Fields
         If InStr(1, aField.Code.Text, "HYPERLINK", vbTextCompare) Then
              Dim intStart As Integer, intEnd As Integer
              Dim strURL As String
              intStart = InStr(1, aField.Code.Text, """", vbTextCompare)
              intEnd = InStr(intStart + 1, aField.Code.Text, """", vbTextCompare)
              strURL = Mid(aField.Code.Text, intStart + 1, intEnd - intStart - 1)
              aField.Result.InsertAfter (" <" + strURL + "> ")
         End If
     Next aField
 End Sub

facilitate the edition of the XML files

Sub xml2text()
'
' replace the U, B and I tags by underline, bold and italic text
'
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Font.Underline = wdUnderlineSingle
        .Text = "\<U\>(?*)\</U\>"
        .Replacement.Text = "\1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
'
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Font.Italic = True
        .Text = "\<I\>(?*)\</I\>"
        .Replacement.Text = "\1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
'
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Font.Bold = True
        .Text = "\<B\>(?*)\</B\>"
        .Replacement.Text = "\1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
'
' hide the HTML tags
'
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = True
        .Text = "(\<[!>]@\>)"
        .Replacement.Font.Hidden = True
        .Replacement.Text = "\1"
        .Execute Replace:=wdReplaceAll
    End With
'
' replace the character codes by the corresponding characters
'
    With ActiveDocument.Content.Find
        .ClearFormatting
        .MatchWildcards = True
        .Text = "&#x[A-F0-9]{2};"
        Do While .Execute = True
            .Parent.Text = ChrW(Val("&H" & Mid(.Parent.Text, 4, 2)))
            .Parent.Collapse Direction:=wdCollapseEnd
        Loop
    End With
End Sub



Sub text2xml()
'
' replace special characters by their codes
'
    With ActiveDocument.Content.Find
        .ClearFormatting
        .MatchWildcards = True
        .Text = "[áàâäãæÁÀÂÄÃÆçÇéèêëÉÈÊËíìîï&ÍÌÎÏñÑóòôöœÓÒÔÖŒúùûüÚÙÛÜ¡¿©®™<>&]"
        Do While .Execute = True
            .Parent.Text = "&#x" & Hex(AscW(.Parent.Text)) & ";"
            .Parent.Collapse Direction:=wdCollapseEnd
        Loop
    End With
'
' replace italic, bold and underline by the respective tags
'
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        With .Replacement.Font
            .Bold = False
            .Italic = False
            .Underline = wdUnderlineNone
        End With
        .Text = "^p"
        .Replacement.Text = ""
        .Wrap = wdFindAsk
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
'
        .ClearFormatting
        .Font.Underline = wdUnderlineSingle
        .Replacement.ClearFormatting
        .Replacement.Font.Underline = wdUnderlineNone
        .Text = ""
        .Replacement.Text = "<U>^&</U>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
'
        .ClearFormatting
        .Font.Italic = True
        .Replacement.ClearFormatting
        .Replacement.Font.Italic = False
        .Text = ""
        .Replacement.Text = "<I>^&</I>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
        .ClearFormatting
        .Font.Bold = True
        .Replacement.ClearFormatting
        .Replacement.Font.Bold = False
        .Text = ""
        .Replacement.Text = "<B>^&</B>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
'
End Sub

old shortcut for displaying/handling the toolbars

Sub DisplayBar()
    If CommandBars("Standard").Visible Then
       CommandBars("Standard").Visible = False
       CommandBars("Formatting").Visible = True
    ElseIf CommandBars("Formatting").Visible Then
       CommandBars("Standard").Visible = False
       CommandBars("Formatting").Visible = False
    Else
       CommandBars("Standard").Visible = True
       CommandBars("Formatting").Visible = False
    End If
End Sub

' Ctrl+Alt+Space
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeySpacebar, wdKeyControl, wdKeyAlt), _
                         KeyCategory:=wdKeyCategoryMacro, _
                         Command:="DisplayBar"

insert a bookmark at the selected word and replace all instances of these words by a reference toward the new bookmark

' compute a string that can be used as a bookmark name
Function bookmarkEscapeString(st As String) As String
    Dim i As Integer
    bookmarkEscapeString = ""
    For i = 1 To Len(st)
        Dim c As Integer
        c = Asc(Mid(st, i, 1))
        If (c > 64 And c < 91) Or (c > 96 And c < 123) Then
            bookmarkEscapeString = bookmarkEscapeString & Chr(c)
        Else
            bookmarkEscapeString = bookmarkEscapeString & "_" & Mid(str(c), 2)
        End If
    Next i
    bookmarkEscapeString = "bk___" & bookmarkEscapeString
End Function

' insert a bookmark at the selected word and
' replace all instances of these words by a reference toward the new bookmark
Sub linkToSelectedWord()
   
    ' extend selection to whole word (without the last space)
    Selection.Expand (wdWord)
    If (Right(Selection.text, 1) = " ") Then
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    End If
   
    ' define text and name of bookmark
    Dim text As String, name As String
    text = Selection.text
    name = bookmarkEscapeString(text)
   
    ' create bookmark
    ActiveDocument.Bookmarks.Add Range:=Selection.Range, name:=name
   
    ' replace all instances of text by a link toward the newly created bookmark
    With ActiveDocument.Content.Find
        .ClearFormatting
        .text = text
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
        Do While .Found = True
            If (.Parent.start <> ActiveDocument.Bookmarks(name).Range.start) Then
                Dim oldEnd As Long, oldLength As Long, newLength As Long
                oldLength = ActiveDocument.Range.End
                oldEnd = .Parent.End
                .Parent.InsertCrossReference ReferenceType:=wdRefTypeBookmark, _
                                             ReferenceKind:=wdContentText, _
                                             ReferenceItem:=name, _
                                             InsertAsHyperlink:=True, _
                                             IncludePosition:=False
                newLength = ActiveDocument.Range.End
                .Parent.start = oldEnd + Len(name) + (newLength - oldLength) ' to avoid looping on the same location forever (beacuse the link insertion displaces the range of the current finding)
            End If
            .Execute
        Loop
    End With

End Sub


translate a file into ASCII before running a Perl script:

There is probably something more intelligent than this, but it works...

Last update: July 11th, 2004 - Laurent