MS WORD macro template Global availability

[Jeffrey Smith]

I have made a macro to extract the track changes in a document and put them in a table in a new document. It runs fine if the macro resides as a module within the current document and also if I put it the "Normal" module. I can not get the macro to be available to all documents if I put it in a .DOCM (macro) file and load it with the document I want to work with. I can not get the macro to run if I create a .DOTM (template) and put it in the C:\Users\username\AppData\Roaming\Microsoft\Word\STARTUP folder. it gives me an application error.

Is there a way to create a macro document and have all the macros in that file available to all documents?

Jeff

 

[Macropod]

Depending on the code, a macro in one document can be run on another document, but not via Alt-F8. Instead, you'd need to use Alt-F11 and run it from the VBE. The main issue as to whether the macro will work correctly then has to do with things like whether it references 'ThisDocument' instead of 'ActiveDocument' or things that pertain to the document it's in rather than the active document.

Without seeing you code, it's impossible to say what's causing the application error.

 

[Jeffrey Smith]

The problem with templates is you can't debug them. The macro runs fine as a .DOCM, it runs fine as code in the Normal project. As soon as I try to add it as a global template, it doesn't work. it complains about the code not being compatible with the current version of Word.

Not a question for you, but a question for MS: Why can't Word treat macros the same as in excel? (insert expletive here).

Public Sub Extract_Tracked_Changes()  '=========================
  'Macro Edited by Jeffrey N. Mahoney 2014 - Added more fields for the type of edit
  'Added the ability to open many documents and process them all at once.
  'Added a statusbar update
  'Added text moved to and from location
  'Added more columns to suit particular needs
  'MAKE SURE YOU SAVE CHANGES TO DOCUMENTS BEFORE PRECEDING
  '+++++++++++++++++++++++++
  '
  'Original Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com
  'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
  'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
  '=========================
  'The macro processes all open documents with track changes
  'It creates a new document with the same name as the original but with "_Track" at the end
  'it extracts insertions and deletions
  'marked as tracked changes from the active document
  'NOTE: Other types of changes are skipped
  '(e.g. formatting changes or inserted/deleted footnotes and endnotes)
  'Only insertions and deletions in the main body of the document will be extracted
  'The document will also include metadata
  'Inserted text will be applied black font color
  'Deleted text will be applied red font color
  
  'Minor adjustments are made to the styles used
  'You may need to change the style settings and table layout to fit your needs
  '=========================


  Dim oDoc As Document
  Dim oNewDoc As Document
  Dim oTable As Table
  Dim oRow As Row
  Dim oCol As Column
  Dim oRange As Range
  Dim oRevision As Revision
  Dim strText As String
  Dim n As Long
  Dim i As Long
  Dim Title As String
  Dim RCnt As Long
  Dim cPage As Long
  Dim cLine As Long
  Dim cType As Long
  Dim RowNum As Long
  Dim A As String
  Dim X As Long
  Dim TotFileCnt As Long
  Dim ThisDocStr As String
  Dim FileCnt As Long    'Count
  Dim CurDocStr As String
    
    
  Title = "Extract Tracked Changes to New Documents"
  
  ThisDocStr = ActiveDocument.Name
  FileCnt = 0
  
  
  'Count all the documents except this macro
  For Each oDoc In Documents
    CurDocStr = oDoc.Name
    If CurDocStr <> ThisDocStr Then
      TotFileCnt = TotFileCnt + 1
    End If
  Next oDoc
  
  'check to see if no other files exist
  If TotFileCnt < 1 Then
    If MsgBox("All " & Str$(TotFileCnt) & " Open Documents will have tracked changes extracted to new files" & vbCr & _
              "The following types of track changes will be included in this report: Insertions, Deletions, Replaced, and Moved" & vbCr & vbCr & _
              "Do you want to continue?", _
              vbYesNo + vbQuestion, Title) <> vbYes Then
      GoTo ExitHere
    Else
      MsgBox "No open documents found. Please open documents with track changes before running the macro"
      GoTo ExitHere
    End If
  End If
  
  
  Application.ScreenUpdating = False
  
  
  For Each oDoc In Documents
    CurDocStr = oDoc.Name
    FileCnt = FileCnt + 1
    If CurDocStr = ThisDocStr Then GoTo NextFile
    
    'check to see if there are any revisions
    RCnt = oDoc.Revisions.Count
    If RCnt = 0 Then
      oDoc.Close (False)
      GoTo NextFile
    End If
    
    'reset statusbar variables
    n = 0
    RowNum = 0
    
    'Create a new document for the tracked changes
    Set oNewDoc = Documents.Add
    'Set to landscape
    oNewDoc.PageSetup.Orientation = wdOrientLandscape
    With oNewDoc
      'Make sure any content is deleted
      .Content = ""
      'Set appropriate margins
      With .PageSetup
        .LeftMargin = CentimetersToPoints(2)
        .RightMargin = CentimetersToPoints(2)
        .TopMargin = CentimetersToPoints(2.5)
      End With
      'Insert a 9-column table for the tracked changes and metadata
      Set oTable = .Tables.Add(Range:=Selection.Range, numrows:=1, NumColumns:=9)
    End With
    
    'Insert info in header - change date format as you wish
    oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
        "Tracked changes extracted from: " & oDoc.FullName & vbCr & _
        "Created by: " & Application.UserName & vbCr & _
        "Creation date: " & Format(Date, "MMMM d, yyyy")
            
    'Adjust the Normal style and Header style
    With oNewDoc.Styles(wdStyleNormal)
        With .Font
          .Name = "Arial"
          .Size = 9
          .Bold = False
        End With
        With .ParagraphFormat
          .LeftIndent = 0
          .SpaceAfter = 6
        End With
    End With
    
    With oNewDoc.Styles(wdStyleHeader)
      .Font.Size = 8
      .ParagraphFormat.SpaceAfter = 0
    End With
    
    'Format the table appropriately
    With oTable
      .Range.Style = wdStyleNormal
      .AllowAutoFit = False
      .PreferredWidthType = wdPreferredWidthPercent
      .PreferredWidth = 100
      For Each oCol In .Columns
          oCol.PreferredWidthType = wdPreferredWidthPercent
      Next oCol
      .Columns(1).PreferredWidth = 5  'Page
      .Columns(2).PreferredWidth = 5  'Line
      .Columns(3).PreferredWidth = 10 'Type of change
      .Columns(4).PreferredWidth = 30 'Inserted/deleted text
      .Columns(5).PreferredWidth = 15 'Author
      .Columns(6).PreferredWidth = 10 'Revision date
      .Columns(7).PreferredWidth = 5 'IPR Yes
      .Columns(8).PreferredWidth = 5 'IPR No
      .Columns(9).PreferredWidth = 15 'IPR No w/Guidance
    End With


    'Insert table headings
    With oTable.Rows(1)
      .Cells(1).Range.Text = "Page"
      .Cells(2).Range.Text = "Line"
      .Cells(3).Range.Text = "Type"
      .Cells(4).Range.Text = "What has been inserted or deleted"
      .Cells(5).Range.Text = "Author"
      .Cells(6).Range.Text = "Date"
      .Cells(7).Range.Text = "IPR Yes"
      .Cells(8).Range.Text = "IPR No"
      .Cells(9).Range.Text = "IPR No w/Guidance"
    End With
    With oTable.Rows(1)
      .Cells.VerticalAlignment = wdCellAlignVerticalBottom
    End With
    
    'Get info from each tracked change (insertion/deletion) from oDoc and insert in table
    For Each oRevision In oDoc.Revisions
      Select Case oRevision.Type
        'Only include insertions and deletions
        Case wdRevisionInsert, wdRevisionDelete, wdRevisionReplace, wdRevisionMovedFrom, wdRevisionMovedTo
            'In case of footnote/endnote references (appear as Chr(2)),
            'insert "[footnote reference]"/"[endnote reference]"
          With oRevision
            'Get the changed text
            strText = .Range.Text
        
            Set oRange = .Range
            Do While InStr(1, oRange.Text, Chr(2)) > 0
              'Find each Chr(2) in strText and replace by appropriate text
              i = InStr(1, strText, Chr(2))
              
              If oRange.Footnotes.Count = 1 Then
                  strText = Replace(Expression:=strText, _
                          Find:=Chr(2), Replace:="[footnote reference]", _
                          Start:=1, Count:=1)
                  'To keep track of replace, adjust oRange to start after i
                  oRange.Start = oRange.Start + i
          
              ElseIf oRange.Endnotes.Count = 1 Then
                  strText = Replace(Expression:=strText, _
                          Find:=Chr(2), Replace:="[endnote reference]", _
                          Start:=1, Count:=1)
                  'To keep track of replace, adjust oRange to start after i
                  oRange.Start = oRange.Start + i
              End If
           Loop
          End With
          'Add 1 to counter
          n = n + 1
          'Add row to table
          Set oRow = oTable.Rows.Add
          
          'Insert data in cells in oRow
          With oRow
            cPage = Val(oRevision.Range.Information(wdActiveEndPageNumber))
            cLine = Val(oRevision.Range.Information(wdFirstCharacterLineNumber))
            
            .Cells.VerticalAlignment = wdCellAlignVerticalCenter
             'Page number
            .Cells(1).Range.Text = oRevision.Range.Information(wdActiveEndPageNumber)
            'Line number - start of revision
            .Cells(2).Range.Text = oRevision.Range.Information(wdFirstCharacterLineNumber)
                  
              
              'Type of revision
            cType = oRevision.Type
            Select Case cType
            Case wdRevisionInsert
              .Cells(3).Range.Text = "Inserted"
              'Apply automatic color (black on white)
              oRow.Range.Font.Color = wdColorAutomatic
            Case wdRevisionDelete
              .Cells(3).Range.Text = "Deleted"
              'Apply red color
              oRow.Range.Font.Color = wdColorRed
            Case wdRevisionReplace
              .Cells(3).Range.Text = "Replaced"
              'Apply red color
              oRow.Range.Font.Color = wdColorRed
            Case wdRevisionMovedFrom
              .Cells(3).Range.Text = "Moved From"
              'Apply automatic color (black on white)
              oRow.Range.Font.Color = wdColorAutomatic
            Case wdRevisionMovedTo
              .Cells(3).Range.Text = "Moved To"
              'Apply automatic color (black on white)
              oRow.Range.Font.Color = wdColorAutomatic
            End If
            
            'The inserted/deleted text
            .Cells(4).Range.Text = strText
            
            'The author
            .Cells(5).Range.Text = oRevision.Author
            
            'The revision date
            .Cells(6).Range.Text = Format(oRevision.Date, "mm-dd-yyyy")
          End With
      End Select
      
      'update statusbar every tenth revision
      If n - RowNum >= 10 Then
        Application.StatusBar = "File:" & Str$(TotFileCnt + 1 - FileCnt) & "     Revision:" & Str$(n)
        RowNum = n
      End If
    
    
    
    Next oRevision
    
    'Apply bold formatting and heading format to row 1
    With oTable.Rows(1)
      .Range.Font.Bold = True
      .HeadingFormat = True
    End With


    'Get the original filename and path. Add "_Track" to end
    A = CurDocStr
    For X = Len(A) To 1 Step -1
      If Mid$(A, X, 1) = "." Then
        A = Left$(A, X - 1) & "_Track"
        Exit For
      End If
    Next X
    A = oDoc.Path & "\" & A
    oNewDoc.SaveAs2 (A)
    oNewDoc.Close
    oDoc.Close
    
NextFile:
  Next oDoc
    
    
    
    
  If FileCnt < 1 Then
    MsgBox "There are no other documents open.  Please open a document with track changes."
    Exit Sub
  End If
    
    
  Application.ScreenUpdating = True
  Application.ScreenRefresh
        


ExitHere:
    Set oDoc = Nothing
    Set oNewDoc = Nothing
    Set oTable = Nothing
    Set oRow = Nothing
    Set oRange = Nothing
    Application.StatusBar = ""
    
End Sub

 

[Macropod]

The macro runs fine as a .DOCM, it runs fine as code in the Normal project. As soon as I try to add it as a global template, it doesn't work. it complains about the code not being compatible with the current version of Word.

Not a question for you, but a question for MS: Why can't Word treat macros the same as in excel? (insert expletive here).

It seems to me the most likely cause is that you're trying to run the code on Word versions that don't support all of the properties you're invoking. For example, wdRevisionMovedFrom and wdRevisionMovedTo didn't exist in Word 2003 (I'm not sure when they were introduced) and running the code on Word 2003 would generate the kind of error to which you refer. Your code also has at least one other bug - and that one prevents it from running at all.

This error has nothing to do with Word not treating macros the same as in Excel, because Excel would generate an error in the same situation. As always, the maxim is that you should test your code on every platform on which you intend to run it.