|
Sub AuthorTec_ReplaceAuthorName() |
|
|
|
Const MacroName = "AuthorTec™ Replace Author Name" |
|
|
|
'In XML formatted Word documents (docx, dotx, docm, dotm), this |
|
|
|
'macro changes a specified author name on comments and tracked |
|
|
|
'revisions. It runs on both Windows and Mac versions of Microsoft Word |
|
|
|
'Authored by Richard V Michaels, Microsoft Office Services MVP |
|
|
|
'Chief Product Architect of Great Circle Learning, Inc. |
|
|
|
'https://www.greatcirclelearning.com |
|
|
|
'AuthorTec is a Trademark of Richard V Michaels |
|
|
|
Dim doc As Word.Document |
|
|
|
Dim Sec As Word.Section |
|
|
|
Dim HF As Word.HeaderFooter |
|
|
|
Dim sOldAuthor As String |
|
|
|
Dim sNewAuthor As String |
|
|
|
Dim sWOOXML As String |
|
|
|
Dim sFindAuthor As String |
|
|
|
Dim sReplaceAuthor As String |
|
|
|
Dim TRStatus As Boolean |
|
|
|
On Error GoTo WrapUp |
|
|
|
'obtain the author name to replace |
|
|
|
sOldAuthor = InputBox("Find this name...", MacroName) |
|
|
|
If sOldAuthor = vbNullString Then End |
|
|
|
'obtain the replacement name |
|
|
|
sNewAuthor = InputBox("Replace with...", MacroName) |
|
|
|
If sNewAuthor = vbNullString Then End |
|
|
|
'Only work from a stored document |
|
|
|
Set doc = ActiveDocument |
|
|
|
If doc.Saved = False Then doc.Save |
|
|
|
'save the current track revision setting |
|
|
|
TRStatus = doc.TrackRevisions |
|
|
|
'must perform this with track revisions turned off |
|
|
|
doc.TrackRevisions = False |
|
|
|
'document's main content layer is processed |
|
|
|
sFindAuthor = "w:author=" & chr(34) & sOldAuthor & chr(34) |
|
|
|
sReplaceAuthor = "w:author=" & chr(34) & sNewAuthor & chr(34) |
|
|
|
sWOOXML = doc.Content.WordOpenXML |
|
|
|
sWOOXML = Replace(sWOOXML, sFindAuthor, sReplaceAuthor) |
|
|
|
doc.Content.InsertXML sWOOXML |
|
|
|
'headers and footers must be processed separately |
|
|
|
For Each Sec In doc.Sections |
|
|
|
For Each HF In Sec.Footers |
|
|
|
sWOOXML = HF.Range.WordOpenXML |
|
|
|
sWOOXML = Replace(sWOOXML, sFindAuthor, sReplaceAuthor) |
|
|
|
HF.Range.InsertXML sWOOXML |
|
|
|
Next |
|
|
|
For Each HF In Sec.Headers |
|
|
|
sWOOXML = HF.Range.WordOpenXML |
|
|
|
sWOOXML = Replace(sWOOXML, sFindAuthor, sReplaceAuthor) |
|
|
|
HF.Range.InsertXML sWOOXML |
|
|
|
Next |
|
|
|
Next |
|
|
|
WrapUp: |
|
|
|
If Err.Number <> 0 Then |
|
|
|
MsgBox Err.Number & vbCr & Err.Description, vbCritical, MacroName |
|
|
|
Else |
|
|
|
MsgBox "Action Complete", vbOKOnly, MacroName |
|
|
|
End If |
|
|
|
'the document's original track revision setting is restored |
|
|
|
'and the document is saved to register the changes |
|
|
|
doc.TrackRevisions = TRStatus |
|
|
|
doc.Save |
|
|
|
End Sub |
