-
Solved: Word Compare - Convert Copy of"Original" and "Revised" to Plain Text Prior to Compare
Hi,
Been stumped on this for awhile now.
I was wondering if anyone knows how to create a procedure (will most likely be used to re-purpose Word's "Compare" command in '07 and '10) that does the following:- If there are any track changes in either the Original Document or Revised Document, accept them all, THEN:
- Take the Original Document, create a copy of it in memory, and then convert everything to text in the copy of the Original Document (so for example, if the document has autonumbered paragraphs--they will become "hard numbering", if the document has fields--they will be unlinked, in other words, everything in the document will be converted to plain text)
- Take the Revised Document and create a copy of it in memory, and do the exact same thing (i.e., convert everything in the document to plain text)
- Then, Compare the "plain text" versions of the documents to each other (at the character level) using the "Compare" command, and put the result in a new document.
I would like to do be able to do this compare without in any way effecting the source files (meaning the Original Document and the Revised Document--they should keep all auto numbering, fields, etc., and not otherwise be "dirtied" or cause a change in the value of ActiveDocument.Saved).
Let me know if anyone has any input.
Best,
Brian
-
A Start
So, I have this as a start:
[vba]Sub CompareDocsFlat()
'BETA - a document compare procedure that converts the documents to plain text first
Dim fd As FileDialog
Dim comparedocument As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim dcOriginalDocument As Document
Dim dcRevisedDocument As Document
With fd
.AllowMultiSelect = False
.Title = "Select the Original Document"
.InitialFileName = ActiveDocument.Path
If .Show = -1 Then
OriginalDocument = .SelectedItems(1)
Else
Exit Sub
End If
End With
With fd
.AllowMultiSelect = False
.Title = "Select the Revised Document"
.InitialFileName = ActiveDocument.Path
If .Show = -1 Then
RevisedDocument = .SelectedItems(1)
Else
Exit Sub
End If
End With
Set dcOriginalDocument = Documents.Open(OriginalDocument)
dcOriginalDocument.ConvertNumbersToText
Dim rngStory As Word.Range
Dim oShp As Word.Shape
For Each rngStory In dcOriginalDocument.StoryRanges
Do
On Error Resume Next
rngStory.Fields.Unlink
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory
Set dcRevisedDocument = Documents.Open(RevisedDocument)
dcRevisedDocument.ConvertNumbersToText
For Each rngStory In dcRevisedDocument.StoryRanges
Do
On Error Resume Next
rngStory.Fields.Unlink
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory
Set fd = Nothing
Application.CompareDocuments OriginalDocument:=Documents(dcOriginalDocument), _
RevisedDocument:=Documents(dcRevisedDocument), Destination:= _
wdCompareDestinationNew, Granularity:=wdGranularityCharLevel, _
CompareFormatting:=False, CompareCaseChanges:=True, CompareWhitespace:= _
False, CompareTables:=True, CompareHeaders:=True, CompareFootnotes:=True, _
CompareTextboxes:=True, CompareFields:=True, CompareComments:=True, _
CompareMoves:=True, RevisedAuthor:="Author", IgnoreAllComparisonWarnings _
:=True
dcOriginalDocument.Close
dcRevisedDocument.Close
End Sub[/vba]
Would like guidance on how to unlink the fields in a more efficient manner, seems odd to duplicate the code twice.
Also, this code is using the original files and simply tries to close them at the end. Would be nice if I could get it to compare the files without touching the original files. I am worried about losing the user's changes if the user had previously been working in either of the compared files prior to the compare.
-
Closer
This is getting closer (doesn't touch the original files). Just noticed that the field unlinker messes up page numbering compare because it turns the page number field to text which is repeated on every page.
Need a way to flatten all the fields in the footer except the page number.
Any thoughts?
[VBA]Sub CompareDocsFlatTESTER()
'BETA - a document compare macro for comparing flat documents
Dim fd As FileDialog
Dim OriginalDocument As String
Dim RevisedDocument As String
Dim dcOriginalDocument As Document
Dim dcRevisedDocument As Document
Dim rngStory As Word.Range
Dim oShp As Word.Shape
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Select the Original Document"
.InitialFileName = ActiveDocument.FullName 'Options.DefaultFilePath(wdDocumentsPath)
If .Show = -1 Then
OriginalDocument = .SelectedItems(1)
Else
Exit Sub
End If
End With
With fd
.AllowMultiSelect = False
.Title = "Select the Revised Document"
.InitialFileName = ActiveDocument.Path
If .Show = -1 Then
RevisedDocument = .SelectedItems(1)
Else
Exit Sub
End If
End With
Documents.Add Template:=OriginalDocument
Documents.Add Template:=RevisedDocument
'Process Original Document
Documents(2).ConvertNumbersToText
For Each rngStory In Documents(2).StoryRanges
Do
On Error Resume Next
rngStory.Fields.Unlink
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11 'YOUR PAGE NUMBERS COMPARES ARE MESSED UP - FIGURE THIS OUT _
YOU WANT TO KEEP THE PAGE NUMBERS AS A FIELD CODE, BUT FLATTEN EVERYTHING ELSE IN THE FOOTER
Case Else
End Select
On Error GoTo 0
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory
'Process Revised Document
Documents(1).ConvertNumbersToText
For Each rngStory In Documents(1).StoryRanges
Do
On Error Resume Next
rngStory.Fields.Unlink
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
Case Else
End Select
On Error GoTo 0
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory
Set fd = Nothing
Application.CompareDocuments OriginalDocument:=Documents(2), _
RevisedDocument:=Documents(1), Destination:= _
wdCompareDestinationNew, Granularity:=wdGranularityCharLevel, _
CompareFormatting:=False, CompareCaseChanges:=True, CompareWhitespace:= _
False, CompareTables:=True, CompareHeaders:=True, CompareFootnotes:=True, _
CompareTextboxes:=True, CompareFields:=True, CompareComments:=True, _
CompareMoves:=True, RevisedAuthor:="Author", IgnoreAllComparisonWarnings _
:=True
'figure out page numbering issue first
'Documents(3).Close SaveChanges:=wdDoNotSaveChanges
'Documents(2).Close SaveChanges:=wdDoNotSaveChanges
End Sub[/VBA]
-
This is even better 
Let me know if anyone has pointers or sees an area I could improve.
Best,
Brian
[vba]
Sub CompareDocsFlat()
Dim fd As FileDialog
Dim OriginalDocument As String
Dim RevisedDocument As String
Dim rngStory As Word.Range
Dim oShp As Word.Shape
Dim oFld As Word.Field
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Select the Original Document"
.InitialFileName = ActiveDocument.FullName 'Options.DefaultFilePath(wdDocumentsPath)
If .Show = -1 Then
OriginalDocument = .SelectedItems(1)
Else
Exit Sub
End If
End With
With fd
.AllowMultiSelect = False
.Title = "Select the Revised Document"
.InitialFileName = ActiveDocument.Path
If .Show = -1 Then
RevisedDocument = .SelectedItems(1)
Else
Exit Sub
End If
End With
'Create the documents to be compared from a template
Documents.Add Template:=OriginalDocument
Documents.Add Template:=RevisedDocument
'Flatten the Original Document
Documents(2).ConvertNumbersToText 'first convert auto numbering to text
'Unlink the applicable fields, you may have to add an additional _
Case statement for any other fields you want as text
For Each rngStory In Documents(2).StoryRanges
Do
For Each oFld In rngStory.Fields
On Error Resume Next
Select Case oFld.Type
Case wdFieldFileName
oFld.Unlink
Case wdFieldTOC
oFld.Unlink
Case wdFieldRef
oFld.Unlink
Case wdFieldListNum
oFld.Unlink
Case wdFieldCreateDate
oFld.Unlink
Case wdFieldDocVariable
oFld.Unlink
Case Else
End Select
Next
On Error GoTo 0
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory
'Flatten the Revised Document
Documents(1).ConvertNumbersToText
For Each rngStory In Documents(1).StoryRanges
Do
For Each oFld In rngStory.Fields
On Error Resume Next
Select Case oFld.Type
Case wdFieldFileName
oFld.Unlink
Case wdFieldTOC
oFld.Unlink
Case wdFieldRef
oFld.Unlink
Case wdFieldListNum
oFld.Unlink
Case wdFieldCreateDate
oFld.Unlink
Case wdFieldDocVariable
oFld.Unlink
Case Else
End Select
Next
On Error GoTo 0
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory
Set fd = Nothing
'Start the compare
Application.CompareDocuments OriginalDocument:=Documents(2), _
RevisedDocument:=Documents(1), Destination:= _
wdCompareDestinationNew, Granularity:=wdGranularityCharLevel, _
CompareFormatting:=False, CompareCaseChanges:=True, CompareWhitespace:= _
False, CompareTables:=True, CompareHeaders:=True, CompareFootnotes:=True, _
CompareTextboxes:=True, CompareFields:=True, CompareComments:=True, _
CompareMoves:=True, RevisedAuthor:="Author", IgnoreAllComparisonWarnings _
:=True
'Close the documents that were temporarily created and "flattened" for the compare
Documents(3).Close SaveChanges:=wdDoNotSaveChanges
Documents(2).Close SaveChanges:=wdDoNotSaveChanges
'Avoid seeing Word's squiggle lines
Documents(1).ShowGrammaticalErrors = False
Documents(1).ShowSpellingErrors = False
'Prompt the user to save
With Dialogs(wdDialogFileSaveAs)
.name = "red - " & FileNameNoExt(RevisedDocument) & _
" vs " & FileNameNoExt(OriginalDocument)
.Show
End With
End Sub
Function FileNameNoExt(strPath As String) As String
Dim strTemp As String
strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function
[/vba]
-
Rather than referring to your documents as "Documents(1)" and "Documents(2)" (which can cause you issues in using this code if you ever have other documents open), instead dim two document objects at the top of your routine like this:
Dim oDocOrigCopy As Document
Dim oDocRevisedCopy As Document
And then in where you create these documents, use the following instead:
Set oDocOrigCopy = Documents.Add (Template:=OriginalDocument)
Set oDocRevisedCopy = Documents.Add(Template:=RevisedDocument)
If you need to use a 3rd document for the purposes of the comparison, you should do that as well. It becomes problematic to refer to specific documents by an index of the document collection (which could be anything) when you're opening and closing other documents.
Also, I like where your code is going... but you should really try to separate the structure out into separate procedures. This is called "modularizing" your code. Using a combination of passed parameters and returning values from functions, you can avoid repeating code "chunks" (which makes it easier to revise those code chunks later).
For example, you could easily take the above routine and break it into two chunks like so (I've also included my suggestions for document variables, and changed some of your naming conventions to make your variable names more clear, as well as some comments on specific issues.
In general-- comment your code way way more. Especially the things which don't necessarily make sense. Why are you using on error resume next, and then resetting the error trapping?
You don't need to use Left$... you can use Left. The # and $ typing (and there are a few others) are legacy ways of automatically typing something as a number or a string or a date (if memory serves).
If you're going to use code derived from a recorded macro, I would suggest cleaning it up the way I did (although you don't necessarily need to break up every parameter into a separate line, don't break up parameters with the values you want to pass in by a line break-- makes your code tough to follow).
Those are my notes. There's at least one other way I would modularize this code, but I'll leave that to you to discover, if you're interested.
As a general note: the reason you modularize is not just to prevent copy/paste, but also to speed up the development cycle. How many times did you have to select the two documents in order to see how to flatten a single document? Break stuff apart into separate procedures, and then run the procedure from the immediate pane a la:
FlattenDocument ActiveDocument
Then you can test just that part of it.
Hope this helps.
[vba]
'get the file path of a selected file returned as a string
Public Function fGetFilePath(sDialogTitle As String, sDialogInitialFileName As String) As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = sDialogTitle
.InitialFileName = sDialogInitialFileName
If .Show = -1 Then
fGetFilePath = .SelectedItems(1)
Else
'return nothing, if cancel was selected
fGetFilePath = ""
End If
End With
End Function
'convert all numbers to text, unlink a number of fields
Public Sub FlattenDocument(oDoc As Document)
Dim rngStory As Word.Range
Dim oFlt As Word.Field
'flatten
oDoc.ConvertNumbersToText
'cycle through each story range
For Each rngStory In oDoc.StoryRanges
'I don't understand the need for the do...loop, nor setting the .NextStoryRange
'If you are working through a bug, comment why you're doing this
'Otherwise, it makes no sense-- this is what a For Each loop does anyway...
' Do
For Each oFld In rngStory.Fields
'*** I don't understand your error trapping here-- comment why
'On Error Resume Next
'you can have multiple cases perform the action
Select Case oFld.Type
Case wdFieldFileName, wdFieldTOC, wdFieldRef, _
wdFieldListNum, wdFieldCreateDate, wdFieldDocVariable
oFld.Unlink
Case Else
End Select
Next
' On Error GoTo 0
' Set rngStory = rngStory.NextStoryRange
' Loop Until rngStory Is Nothing
Next rngStory
End Sub
'compare two documents in a pseudo-text-only way
Public Sub CompareDocsFlat()
Dim sOriginalDocFullName As String
Dim sRevisedDocFullName As String
Dim oCopyOriginal As Document
Dim oCopyRevised As Document
Dim oDocComparison As Document
'get the documents to compare
sOriginalDocument = fGetFilePath("Select the Original Document", ActiveDocument.FullName)
If sOriginalDocument = "" Then
Exit Sub
End If
sRevisedDocument = fGetFilePath("Select the Revised Document", ActiveDocument.Path)
If sRevisedDocument = "" Then
Exit Sub
End If
'Create the documents to be compared from a template
Set oCopyOriginal = Documents.Add(Template:=sOriginalDocument)
Set oCopyRevised = Documents.Add(Template:=sRevisedDocument)
'Flatten the Original Document
FlattenDocument oCopyOriginal
'and the revised
FlattenDocument oCopyRevised
'Start the compare
Set oDocComparison = Application.CompareDocuments( _
OriginalDocument:=oCopyOriginal, _
RevisedDocument:=oCopyRevised, _
Destination:=wdCompareDestinationNew, _
Granularity:=wdGranularityCharLevel, _
CompareFormatting:=False, _
CompareCaseChanges:=True, _
CompareWhitespace:=False, _
CompareTables:=True, _
CompareHeaders:=True, _
CompareFootnotes:=True, _
CompareTextboxes:=True, _
CompareFields:=True, _
CompareComments:=True, _
CompareMoves:=True, _
RevisedAuthor:="Author", _
IgnoreAllComparisonWarnings:=True)
'Close the documents that were temporarily created and "flattened" for the compare
oCopyOriginal.Close SaveChanges:=wdDoNotSaveChanges
oCopyRevised.Close SaveChanges:=wdDoNotSaveChanges
'Avoid seeing Word's squiggle lines
oDocComparison.ShowGrammaticalErrors = False
oDocComparison.ShowSpellingErrors = False
'Prompt the user to save
With Dialogs(wdDialogFileSaveAs)
.name = "red - " & FileNameNoExt(sRevisedDocFullName) & _
" vs " & FileNameNoExt(sOriginalDocFullName)
.Show
End With
End Sub
'pass in a file path, return the name of the file, sans file extension
Public Function FileNameNoExt(strPath As String) As String
Dim strTemp As String
strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function
[/vba]
-
Frosty, thank you! The part about not using the index numbers from the documents object is especially helpful
I am studying your revised code. On my machine it is throwing an error on the part related to suggesting the file name, I believe the error is in the following function:
Will post again once I have it figured out.
Thank you again for your detailed comments and suggestions, it is truly appreciated. 
[VBA]Public Function FileNameNoExt(strPath As String) As String Dim strTemp As String strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1) FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1) End Function [/VBA]
-
What is the error? Compile or runtime?
-
Errors
Hi Frosty, here are the errors I am getting:
Am I not passing a string to this function after the modularization of the code? I thought it was, I am trying to follow it but I think I am getting lost somewhere.
Best,
Brian
-
That function fails if you pass in a string which doesn't contain a period.
Because...
InStrRev("Hello", ".") = 0
Whereas
InStrRev("Hello.doc", ".") = 6
If you then subtract 1 from zero, you get -1.
If you then try...
Left("Hello", -1)
you will get the error you're getting.
There are so many ways to address this... general error trapping will handle it, probably... but I'm not sure if that's what you want (and it can cause issues if you pass in a file which doesn't have an extension, but one of your containing folders contains a period...).
This was, of course, the one function I didn't rewrite, hehe. I wouldn't normally write it out this long, as I'm fairly familiar with string manipulation. But when I'm troubleshooting, I might break it apart this much, just to make it easier to step through and see what's going on.
Try this in place:
[vba]
'pass in a file path, return the name of the file, sans file extension
Public Function FileNameNoExt(strPath As String) As String
Dim strTemp As String
Dim iLocation As Integer
On Error GoTo l_err
'first you're getting the file name?
strTemp = strPath
iLocation = InStrRev(strTemp, "\")
strTemp = Mid(strTemp, iLocation + 1)
'then you're removing the file extension?
iLocation = InStrRev(strTemp, ".")
strTemp = Left(strTemp, iLocation - 1)
l_exit:
FileNameNoExt = strTemp
Exit Function
l_err:
'if an error, reset and exit
strTemp = strPath
Resume l_exit
End Function
[/vba] However... couple of quick pointers:
1. When in debug mode... try hovering over the individual variables, you will see where you're at in your processing
2. When doing string manipulation, until you're really confident, it helps to break apart the individual components each time, so that you can see where it breaks down (I've broken it apart a little bit more, as you can see). That also lets you do more hovering to see the current state of the variable (#1)
3. Learn error trapping-- it will help "blackbox" core functions like this, where you really don't want a catastrophic error to stop your processing (this function is, after all, only meant to give a suggestion)
4. Learn to use the immediate window. Typing the following options in the immediate window will help you see what circumstances the function breaks in:
?FileNameNoExt("Hello there")
?FileNameNoExt("C:\Program Files\SubFolder.1\Hello")
?FileNameNoExt("C:\Program Files\SubFolder.1\Hello.doc")
-
Thanks!
Frosty, thanks again, the below accomplishes exactly what I wanted, I revised a little, and also added a concept that the initial compare directory will always be the directory the user is currently working in.
For anyone interested, below is the code:
Module: CompareDocsFlat
[VBA]'Compare two documents in a pseudo-text-only way
Public Sub CompareDocsFlat()
Dim sOriginalDocFullName As String
Dim sRevisedDocFullName As String
Dim sPriorDefaultPath As String
Dim sDialogPathOriginal As String
Dim sDialogPathRevised As String
Dim oCopyOriginal As Document
Dim oCopyRevised As Document
Dim oDocComparison As Document
'Get the documents to compare
sDialogPathOriginal = Options.DefaultFilePath(wdDocumentsPath) & "\" & "[Original]"
sOriginalDocFullName = fGetFilePath("Select the Original Document", sDialogPathOriginal)
If sOriginalDocFullName = "" Then
Exit Sub
End If
sDialogPathRevised = Options.DefaultFilePath(wdDocumentsPath) & "\" & "[Revised]"
sRevisedDocFullName = fGetFilePath("Select the Revised Document", sDialogPathRevised)
If sRevisedDocFullName = "" Then
Exit Sub
End If
sPriorDefaultPath = Options.DefaultFilePath(wdDocumentsPath)
'Create the documents to be compared from a template
Set oCopyOriginal = Documents.Add(Template:=sOriginalDocFullName, Visible:=False)
Set oCopyRevised = Documents.Add(Template:=sRevisedDocFullName, Visible:=False)
'Flatten the Original Document
FlattenDocument oCopyOriginal
'and the revised
FlattenDocument oCopyRevised
'Start the compare
Set oDocComparison = Application.CompareDocuments( _
OriginalDocument:=oCopyOriginal, _
RevisedDocument:=oCopyRevised, _
Destination:=wdCompareDestinationNew, _
Granularity:=wdGranularityCharLevel, _
CompareFormatting:=False, _
CompareCaseChanges:=True, _
CompareWhitespace:=False, _
CompareTables:=True, _
CompareHeaders:=True, _
CompareFootnotes:=True, _
CompareTextboxes:=True, _
CompareFields:=True, _
CompareComments:=True, _
CompareMoves:=True, _
RevisedAuthor:="Author", _
IgnoreAllComparisonWarnings:=True)
'Close the documents that were temporarily created and "flattened" for the compare
oCopyOriginal.Close SaveChanges:=wdDoNotSaveChanges
oCopyRevised.Close SaveChanges:=wdDoNotSaveChanges
'Avoid seeing Word's squiggle lines
oDocComparison.ShowGrammaticalErrors = False
oDocComparison.ShowSpellingErrors = False
'Bring focus to the comparison
oDocComparison.Activate
'Prompt the user to save with a suggested file name
With Dialogs(wdDialogFileSaveAs)
.name = sPriorDefaultPath & "\" & _
"red - " & FileNameNoExt(sRevisedDocFullName) & _
" vs " & FileNameNoExt(sOriginalDocFullName)
.Show
End With
End Sub
'Get the file path of a selected file returned as a string
Public Function fGetFilePath(sDialogTitle As String, sDialogInitialFileName As String) As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = sDialogTitle
.InitialFileName = sDialogInitialFileName
If .Show = -1 Then
fGetFilePath = .SelectedItems(1)
Else
'Return nothing, if cancel was selected
fGetFilePath = ""
End If
End With
End Function
'Convert all numbers to text, unlink a number of fields
Public Sub FlattenDocument(oDoc As Document)
Dim rngStory As Word.Range
Dim oFlt As Word.Field
'Convert automatic numbering to text numbering
oDoc.ConvertNumbersToText
'Cycle through each story range
For Each rngStory In oDoc.StoryRanges
For Each oFld In rngStory.Fields
Select Case oFld.Type
Case wdFieldFileName, wdFieldTOC, wdFieldRef, _
wdFieldListNum, wdFieldCreateDate, wdFieldDocVariable
oFld.Unlink
Case Else
End Select
Next
Next rngStory
End Sub
'Pass in a file path, return the name of the file, sans file extension
Public Function FileNameNoExt(strPath As String) As String
Dim strTemp As String
Dim iLocation As Integer
On Error GoTo l_err
strTemp = strPath
iLocation = InStrRev(strTemp, "\")
strTemp = Mid(strTemp, iLocation + 1)
iLocation = InStrRev(strTemp, ".")
strTemp = Left(strTemp, iLocation - 1)
l_exit:
FileNameNoExt = strTemp
Exit Function
l_err:
'If an error, reset and exit
strTemp = strPath
Resume l_exit
End Function[/VBA]
Module AutoMacros (in normal.dotm)
[VBA]
Dim oEventHandler As New EventHandler
Sub RegisterEventHandler()
'Register the event handler to handle the _
DocumentOpen and WindowActivate event
Set oEventHandler.appWord = Word.Application
End Sub
Sub AutoExec()
'AutoExec automatically registers the event handler in the class module
Call RegisterEventHandler
End Sub
[/VBA]
Class Module EventHandler (in normal.dotm)
[VBA]Public WithEvents appWord As Word.Application
'Changes default file open path to the path of the active document _
on a window activate event
Private Sub appWord_WindowActivate _
(ByVal Doc As Document, ByVal Wn As Word.Window)
On Error GoTo ErrHandler
'Declare objects necessary to locate "My Documents"
Dim objFolders As Object
Set objFolders = CreateObject("WScript.Shell").SpecialFolders
'If there is no path then change default open path to My Documents
If Len(Doc.Path) = 0 Then
Options.DefaultFilePath(wdDocumentsPath) = objFolders("mydocuments")
'Otherwise set the path to the path of the current document
Else: Options.DefaultFilePath(wdDocumentsPath) = Doc.Path
End If
ErrHandler:
Exit Sub
End Sub[/VBA]
-
Using the WindowActivate event will work, but you could probably just use the DocumentChange event, which, conceptually, makes more sense for what it looks like your code is doing (basing the default file path on the current document).
The first goal of any program is to work. But the second goal (especially when deploying to other users) is to attempt to have the smallest coding "footprint" you can. Your code changing the default path will fire a lot more often with the activate event than it will with the change event.
i.e., you don't need that code to run if you switch to Outlook to check an email, and then come back to Word in order to continue working on the document... but you will trigger an Activate event when that happens.
I'm not 100% sure I'm a fan of using the event model to change an application option based on the properties of a current document, but if it works for your environment, fantastic.
When I need to refresh myself on when particular events fire, I typically create a new app event class, and then put messageboxes in each one to see when, how often and in what order the events fire. This may help you to streamline the process.
Neat to see the progression of your code here.
- Jason
-
Jason,
Concerning your questions about the need to Do ... Loop or setting the next story rang ...
It may not be required in the specific case, but if a user truly wants to update or unlink or whatever with all fields it must be so.
Create a simple test document with two or more text boxes in main text and a shape in the header or footer. In the shape add text and put in a "REF" field. Put a "REF" field in both textboxes, one in the header or footer and run these two procedures. You should then see why:
[VBA]Option Explicit
Public Sub UpdateAllFields()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
On Error Resume Next
rngStory.Fields.Update
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
oShp.TextFrame.TextRange.Fields.Update
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Public Sub FlattenDocument()
Dim rngStory As Word.Range
Dim oFld As Word.Field
For Each rngStory In ActiveDocument.StoryRanges
For Each oFld In rngStory.Fields
oFld.Update
Next
Next rngStory
End Sub
[/VBA]
-
I had an update to this. This update fixes a bug where some fields did not "flatten" in documents with multiple section breaks, I also included a concept where the compared document is converted to formatted text at the end (instead of being left as track changes). This way when you send the document via email, you can be sure the other party is seeing what you intended. If you prefer to leave the result in track changes this can easily be commented out (see comments in the posted code).
For those of you doing a lot of comparisons of documents in a professional field but aren't satisfied with word's internal "compare" feature (which messes up comparing of auto-numbering, etc.) this should be helpful to you!
A special thank you to Greg Maxey, Frosty, and MakeItHappen on this one!
The event handler portion of the code is obviously optional.
Module: CompareDocsFlat
[vba]'Compare two documents in a pseudo-text-only way
Public Sub CompareDocsFlat()
Dim sOriginalDocFullName As String
Dim sRevisedDocFullName As String
Dim sPriorDefaultPath As String
Dim sDialogPathOriginal As String
Dim sDialogPathRevised As String
Dim oCopyOriginal As Document
Dim oCopyRevised As Document
Dim oDocComparison As Document
'Get the documents to compare
sDialogPathOriginal = Options.DefaultFilePath(wdDocumentsPath) & "\" & "[Original]"
sOriginalDocFullName = fGetFilePath("Select the Original Document", sDialogPathOriginal)
If sOriginalDocFullName = "" Then
Exit Sub
End If
sDialogPathRevised = Options.DefaultFilePath(wdDocumentsPath) & "\" & "[Revised]"
sRevisedDocFullName = fGetFilePath("Select the Revised Document", sDialogPathRevised)
If sRevisedDocFullName = "" Then
Exit Sub
End If
sPriorDefaultPath = Options.DefaultFilePath(wdDocumentsPath)
'Create the documents to be compared from a template
Set oCopyOriginal = Documents.Add(Template:=sOriginalDocFullName, Visible:=False)
Set oCopyRevised = Documents.Add(Template:=sRevisedDocFullName, Visible:=False)
'Flatten the Original Document
FlattenDocument oCopyOriginal
'and the revised
FlattenDocument oCopyRevised
'Start the compare
Set oDocComparison = Application.CompareDocuments( _
OriginalDocument:=oCopyOriginal, _
RevisedDocument:=oCopyRevised, _
Destination:=wdCompareDestinationNew, _
Granularity:=wdGranularityCharLevel, _
CompareFormatting:=False, _
CompareCaseChanges:=True, _
CompareWhitespace:=False, _
CompareTables:=True, _
CompareHeaders:=True, _
CompareFootnotes:=True, _
CompareTextboxes:=True, _
CompareFields:=True, _
CompareComments:=True, _
CompareMoves:=True, _
RevisedAuthor:="Author", _
IgnoreAllComparisonWarnings:=True)
'Close the documents that were temporarily created and "flattened" for the compare
oCopyOriginal.Close SaveChanges:=wdDoNotSaveChanges
oCopyRevised.Close SaveChanges:=wdDoNotSaveChanges
'Avoid seeing Word's squiggle lines
oDocComparison.ShowGrammaticalErrors = False
oDocComparison.ShowSpellingErrors = False
'Bring focus to the comparison
oDocComparison.Activate
'Convert track changes to formatted text
FormatRevisionsSilent oDocComparison 'if you want the changes to be formatted as track changes then delete this line
'Prompt the user to save with a suggested file name
With Dialogs(wdDialogFileSaveAs)
.name = sPriorDefaultPath & "\" & _
"red - " & FileNameNoExt(sRevisedDocFullName) & _
" vs " & FileNameNoExt(sOriginalDocFullName)
.Show
End With
End Sub
'Get the file path of a selected file returned as a string
Public Function fGetFilePath(sDialogTitle As String, sDialogInitialFileName As String) As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = sDialogTitle
.InitialFileName = sDialogInitialFileName
If .Show = -1 Then
fGetFilePath = .SelectedItems(1)
Else
'Return nothing, if cancel was selected
fGetFilePath = ""
End If
End With
End Function
'Convert all numbers to text, unlink a number of fields
Sub FlattenDocument(oDoc As Document)
Dim pRange As Word.Range
Dim oFld As Word.Field
Dim iLink As Long
iLink = oDoc.Sections(1).Headers(1).Range.StoryType
'Convert automatic numbering to text numbering
oDoc.ConvertNumbersToText
'Cycle through each story range
For Each pRange In oDoc.StoryRanges
Do
For Each oFld In pRange.Fields
Select Case oFld.Type
Case wdFieldFileName, wdFieldTOC, wdFieldRef, _
wdFieldListNum, wdFieldCreateDate, wdFieldDocVariable, _
wdFieldSaveDate, wdFieldCreateDate
oFld.Unlink
Case Else
'Do nothing
End Select
Next
Set pRange = pRange.NextStoryRange
Loop Until pRange Is Nothing
Next
End Sub
'Pass in a file path, return the name of the file, sans file extension
Public Function FileNameNoExt(StrPath As String) As String
Dim strTemp As String
Dim iLocation As Integer
On Error GoTo l_err
strTemp = StrPath
iLocation = InStrRev(strTemp, "\")
strTemp = Mid(strTemp, iLocation + 1)
iLocation = InStrRev(strTemp, ".")
strTemp = Left(strTemp, iLocation - 1)
l_exit:
FileNameNoExt = strTemp
Exit Function
l_err:
'If an error, reset and exit
strTemp = StrPath
Resume l_exit
End Function
Sub FormatRevisionsSilent(oDoc As Document)
'Convert track changes to regular text formatted with color.
Dim oRngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Word.Shape
Dim lngRevs As Long
Dim i As Long
If Documents.Count = 0 Then
Exit Sub
End If
lngJunk = oDoc.Sections(1).Headers(1).Range.StoryType
'lngJunk = oDoc.Sections(1).Footers(1).Range.StoryType
'First switch off TrackChanges, else each of your reformattings will become a revision again
oDoc.TrackRevisions = False
'Iterate through all story types in the current document
lngRevs = 0
For Each oRngStory In oDoc.StoryRanges
'Iterate through all linked stories
Do
For i = oRngStory.Revisions.Count To 1 Step -1
lngRevs = lngRevs + 1
RevisionProcessor oRngStory.Revisions(i)
Next i
On Error Resume Next
Select Case oRngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If oRngStory.ShapeRange.Count > 0 Then
For Each oShp In oRngStory.ShapeRange
If oShp.TextFrame.HasText Then
For i = oShp.TextFrame.TextRange.Revisions.Count To 1 Step -1
lngRevs = lngRevs + 1
RevisionProcessor oShp.TextFrame.TextRange.Revisions(i)
Next i
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set oRngStory = oRngStory.NextStoryRange
Loop Until oRngStory Is Nothing
Next
End Sub
Sub RevisionProcessor(ByRef oRev As Revision)
'Sub-routine used by FormatRevisions to turn track changes into formatted text
Dim oRevRange As Range
Dim strText As String
'Anchor revision range and text.
Set oRevRange = oRev.Range
strText = oRevRange.Text
On Error Resume Next
Select Case oRev.Type
Case wdRevisionDelete
oRev.Accept
'Format revised text.
With oRevRange
.Text = strText
.Font.StrikeThrough = 1
.Font.Color = wdColorRed
End With
Case wdRevisionInsert
oRev.Accept
With oRevRange
.Font.Underline = wdUnderlineDouble
.Font.Color = wdColorBlue
End With
Case Else
oRev.Accept
End Select
On Error GoTo 0
End Sub
[/vba]
Module AutoMacros (in normal.dotm)
[vba]Dim oEventHandler As New EventHandler
Sub RegisterEventHandler()
'Register the event handler to handle the _
DocumentOpen And WindowActivate event
Set oEventHandler.appWord = Word.Application
End Sub
Sub AutoExec()
'AutoExec automatically registers the event handler in the class module
Call RegisterEventHandler
End Sub
[/vba]
Class Module EventHandler (in normal.dotm)
[vba]Public WithEvents appWord As Word.Application
'Changes default file open path to the path of the active document _
on a window activate event
Private Sub appWord_WindowActivate _
(ByVal Doc As Document, ByVal Wn As Word.Window)
On Error Goto ErrHandler
'Declare objects necessary to locate "My Documents"
Dim objFolders As Object
Set objFolders = CreateObject("WScript.Shell").SpecialFolders
'If there is no path then change default open path to My Documents
If Len(Doc.Path) = 0 Then
Options.DefaultFilePath(wdDocumentsPath) = objFolders("mydocuments")
'Otherwise set the path to the path of the current document
Else: Options.DefaultFilePath(wdDocumentsPath) = Doc.Path
End If
ErrHandler:
Exit Sub
End Sub[/vba]
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
Reply With Quote
