Microsoft Office Forums - View Single Post

djonsen · 10-27-2021, 07:43 AM

Hi scienceguy,

Thank you for posting this - I used your script as the beginning of mine, which is below and works on my Mac, so I would assume it will work on Windows as well with different directories defined. I think the problem with your script is that you tried to compare two documents without opening them first. This script takes a corresponding pair of documents, opens them, compares them, saves the tracked change document with the comparisons, closes all files, then loops to the next pair of files. I wrote this specifically to compare old and new revisions of controlled documents in our company's quality management system, so it determines the "document number" in the beginning of the old rev file name and uses that with a wild card to search for the corresponding new file in the "new files" folder. I hope you can use it to make your application work.

================================================== ===

Code:

Sub DoDiffs()
    Dim strOldFolder As String, strNewFolder As String, strDifFolder As String
    Dim strOldFile As String, strNewFile As String, strDocNum As String
    Dim strOldFileFull As String, strNewFileFull As String
    Dim I As Long, J As Long, N As Long
    Dim OldFileList() As String, NewFileList() As String, DocNums() As String, FilePermList() As String
    ReDim OldFileList(1000)
    
    'Re-define the 3 strings below as appropriate for your system
    strOldFolder = "/Users/dan/Desktop/QMS_Updates/Old/"
    strNewFolder = "/Users/dan/Desktop/QMS_Updates/New/"
    strDifFolder = "/Users/dan/Desktop/QMS_Updates/Dif/"
    
    'Get list of old file names
    strOldFile = Dir$(strOldFolder & "*.docx", vbNormal)
    I = 0
    Do While strOldFile <> ""
        OldFileList(I) = strOldFile
        strOldFile = Dir$
        I = I + 1
    Loop
    N = I - 1
    ReDim Preserve OldFileList(0 To N)
    ReDim NewFileList(0 To N)
    ReDim DocNums(0 To N)
    
    'From old file names, get document Number (everything up to the first space)
    'and find corresponding new file with the same document number, then build old
    'and new file list arrays with full paths
    For I = 0 To N
        strOldFile = OldFileList(I)
        strDocNum = Left(strOldFile, InStr(1, strOldFile, " ") - 1)
        strNewFile = Dir$(strNewFolder & strDocNum & "*.docx", vbNormal)
        strOldFileFull = strOldFolder & strOldFile
        strNewFileFull = strNewFolder & strNewFile
        OldFileList(I) = strOldFileFull
        NewFileList(I) = strNewFileFull
        DocNums(I) = strDocNum
    Next I
    
'*** Un-comment until the next '*** if you use a Mac and you keep getting the "grant access to file?" dialog
'    ReDim FilePermList(0 To N * 2 + 2)
'    J = 0
'    For I = 0 To N
'        FilePermList(J) = OldFileList(I)
'        J = J + 1
'        FilePermList(J) = NewFileList(I)
'        J = J + 1
'    Next I
'    FilePermList(N * 2 + 2) = strDifFolder
'    Dim fileAccessGranted As Boolean
'    fileAccessGranted = GrantAccessToMultipleFiles(FilePermList) 'returns true if access granted, false otherwise
'***
    'Open each corresponding pair of old and new files, and save the changed tracked file
    ' to the "diffs" folder
    For I = 0 To N
        Documents.Open (OldFileList(I))
        Documents.Open (NewFileList(I))
        Application.CompareDocuments OriginalDocument:=Documents(OldFileList(I)), RevisedDocument:=Documents(NewFileList(I)), CompareFormatting:=False
        ActiveDocument.SaveAs2 (strDifFolder & DocNums(I) & "_Diffs.docx")
        Documents.Close
    Next I
End Sub