Word - CompareDocuments - Count - Deletions - Insertions - Save...

Frage: Worddokumente vergleichen - aus Excel. In zwei Verzeichnissen sind unterschiedliche Versionen zweier Worddateien. Die Anzahl der "Deletions" und "Insertions" sollen in Excel geschrieben werden. Die Vergleichsdateien müssen in einem separaten Ordner abgespeichert und verlinkt werden. Im zweiten Code werden DisplayAlerts von WORD werden aus- bzw. angeschaltet. Wie geht das?

Compare Word documents - from Excel. In two directories are different versions of two Word files. The number of "Deletion" and "Insertion" shall be written in Excel. Compare files must be saved in a separate folder and linked. The second code DisplayAlerts of WORD will be turned off or on. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Word - CompareDocuments - Count - Deletions - Insertions - Save...[ZIP 90 KB]

Hier noch eine Beispieldatei mit Pfaden in Range K1:K3 / Here is a sample file with paths in range K1:K3:
Word - CompareDocuments - Count - Deletions - Insertions - Save...[ZIP 90 KB]

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
    Alias "GetCurrentDirectoryA" _
    (ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
    Alias "SetCurrentDirectoryA" _
    (ByVal lpPathName$) As Long
' Konstanten für Pfad und Wordkonstanten, da Late Binding 
' Pfad für Vergleichsdokument - also anpassen!!!! 
Const strPathCompare As String = "C:\Temp\CompareDocuments_1\Comparison\"
Const wdCompareDestinationOriginal = 0
Const wdFormatXMLDocument = 12
' Variablendeklaration 
Private blnTMP As Boolean
Private objApp As Object
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 14.01.2013 
' Purpose   : Word - CompareDocuments - Count - Deletions - Insertions... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    Dim strPathNew As String
    Dim strPathOld As String
    Dim strDirOld As String
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    strDirOld$ = String(255, 0)
    Call GetCurrentDirectory(255, strDirOld$)
    strDirOld$ = Left(strDirOld$, _
        InStr(1, strDirOld$, vbNullChar) - 1)
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objApp Is Nothing Then
        ' Pfade bei Bedarf anpassen!!! 
        strPathNew = ThisWorkbook.Path & Application.PathSeparator & "New"
        strPathOld = ThisWorkbook.Path & Application.PathSeparator & "Old"
        SearchFiles strPathNew, strPathOld
    End If
Fin:
    ' Die Applikation aufwecken 
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Not objApp Is Nothing Then objApp.Quit
    Call SetCurrentDirectory(strDirOld$)
    Set objApp = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : SearchFiles 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 14.01.2013 
' Purpose   : Word - CompareDocuments - Count - Deletions - Insertions... 
'-------------------------------------------------------------------------- 
Private Sub SearchFiles(strFolder1 As String, strFolder2 As String)
    Dim intInsertions As Integer
    Dim intDeletions As Integer
    Dim objDocument1 As Object
    Dim objDocument2 As Object
    Dim intCount As Integer
    Dim lngLastRow As Long
    ' CodeName des Tabellenblattes hier englische Version 
    With Sheet1
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        For lngLastRow = 2 To lngLastRow
            If Dir(strFolder1 & Application.PathSeparator & _
                .Cells(lngLastRow, 1).Value) <> "" Then
                    Set objDocument1 = objApp.Documents.Open _
                        (strFolder1 & Application.PathSeparator & _
                        .Cells(lngLastRow, 1).Value)
                If Dir(strFolder2 & Application.PathSeparator & _
                    .Cells(lngLastRow, 1).Value) <> "" Then
                    Set objDocument2 = objApp.Documents.Open _
                        (strFolder2 & Application.PathSeparator & _
                        .Cells(lngLastRow, 1).Value)
                    objApp.CompareDocuments OriginalDocument:=objDocument1, _
                        RevisedDocument:=objDocument2, _
                        Destination:=wdCompareDestinationOriginal
                    .Cells(lngLastRow, 3).Value = objDocument1.Revisions.Count
                    For intCount = 1 To objDocument1.Revisions.Count
                        If objDocument1.Revisions(intCount).Type = 2 Then
                            intDeletions = intDeletions + 1
                        ElseIf objDocument1.Revisions(intCount).Type = 1 Then
                            intInsertions = intInsertions + 1
                        End If
                    Next intCount
                    .Cells(lngLastRow, 4).Value = intDeletions
                    .Cells(lngLastRow, 5).Value = intInsertions
                Else
                    .Cells(lngLastRow, 7).Value = "no file in " & _
                        strFolder2 & Application.PathSeparator
                End If
            Else
                .Cells(lngLastRow, 6).Value = "no file in " & _
                    strFolder1 & Application.PathSeparator
            End If
            If Not objDocument1 Is Nothing Then
                If objDocument1.Revisions.Count > 0 Then
                    With objDocument1
                        .SaveAs Filename:=strPathCompare & _
                            Left(.Name, InStrRev(.Name, ".") - 1), _
                            FileFormat:=wdFormatXMLDocument
                        .Close False
                    End With
                    .Cells(lngLastRow, 8).Value = _
                        .Cells(lngLastRow, 1).Value & "x"
                    .Hyperlinks.Add Anchor:=.Cells(lngLastRow, 8), _
                        Address:=strPathCompare & .Cells(lngLastRow, 8)
                End If
            End If
            Set objDocument1 = Nothing
            If Not objDocument2 Is Nothing Then objDocument2.Close False
            Set objDocument2 = Nothing
            intInsertions = 0
            intDeletions = 0
        Next lngLastRow
    End With
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 14.01.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Pfade sind in Range K1:K3 - DisplayAlerts von WORD werden aus- bzw. angeschaltet / DisplayAlerts WORD be switched off or on. Paths are in range K1:K3.

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
    Alias "GetCurrentDirectoryA" _
    (ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
    Alias "SetCurrentDirectoryA" _
    (ByVal lpPathName$) As Long
' Wordkonstanten, da Late Binding 
Const wdCompareDestinationOriginal = 0
Const wdFormatXMLDocument = 12
Const wdAlertsAll = -1
Const wdAlertsNone = 0
' Variablendeklaration 
Private blnTMP As Boolean
Private objApp As Object
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 14.01.2013 
' Purpose   : Word - CompareDocuments - Count - Deletions - Insertions... 
'-------------------------------------------------------------------------- 
Public Sub Main_1()
    ' Variablendeklaration 
    Dim strPathCompare As String
    Dim strPathNew As String
    Dim strPathOld As String
    Dim strDirOld As String
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    strDirOld$ = String(255, 0)
    Call GetCurrentDirectory(255, strDirOld$)
    strDirOld$ = Left(strDirOld$, _
        InStr(1, strDirOld$, vbNullChar) - 1)
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objApp Is Nothing Then
        ' Pfade bei Bedarf anpassen!!! 
        With objApp
            .DisplayAlerts = wdAlertsNone
            .WordBasic.DisableAutoMacros 1
        End With
        With ThisWorkbook.Worksheets("Sheet2")
            ' Pfad für New 
            strPathNew = .Range("K1").Value
            strPathNew = IIf(Right(strPathNew, 1) <> "\", _
                strPathNew & "\", strPathNew)
            ' Pfad für Old 
            strPathOld = .Range("K2").Value
            strPathOld = IIf(Right(strPathOld, 1) <> "\", _
                strPathOld & "\", strPathOld)
            ' Pfad für Comparsion 
            strPathCompare = .Range("K3").Value
            strPathCompare = IIf(Right(strPathCompare, 1) <> "\", _
                strPathCompare & "\", strPathCompare)
        End With
        SearchFiles strPathNew, strPathOld, strPathCompare
    End If
Fin:
    ' Die Applikation aufwecken 
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Not objApp Is Nothing Then
        With objApp
            .WordBasic.DisableAutoMacros 0
            .DisplayAlerts = wdAlertsAll
            .Quit
        End With
    End If
    Call SetCurrentDirectory(strDirOld$)
    Set objApp = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : SearchFiles 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 14.01.2013 
' Purpose   : Word - CompareDocuments - Count - Deletions - Insertions... 
'-------------------------------------------------------------------------- 
Private Sub SearchFiles(strFolder1 As String, strFolder2 As String, _
    strFolder3 As String)
    Dim intInsertions As Integer
    Dim intDeletions As Integer
    Dim objDocument1 As Object
    Dim objDocument2 As Object
    Dim intCount As Integer
    Dim lngLastRow As Long
    ' CodeName des Tabellenblattes hier englische Version 
    With Sheet2
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        For lngLastRow = 2 To lngLastRow
            If Dir(strFolder1 & Application.PathSeparator & _
                .Cells(lngLastRow, 1).Value) <> "" Then
                    Set objDocument1 = objApp.Documents.Open _
                        (strFolder1 & Application.PathSeparator & _
                        .Cells(lngLastRow, 1).Value)
                If Dir(strFolder2 & Application.PathSeparator & _
                    .Cells(lngLastRow, 1).Value) <> "" Then
                    Set objDocument2 = objApp.Documents.Open _
                        (strFolder2 & Application.PathSeparator & _
                        .Cells(lngLastRow, 1).Value)
                    objApp.CompareDocuments OriginalDocument:=objDocument1, _
                        RevisedDocument:=objDocument2, _
                        Destination:=wdCompareDestinationOriginal
                    .Cells(lngLastRow, 3).Value = objDocument1.Revisions.Count
                    For intCount = 1 To objDocument1.Revisions.Count
                        If objDocument1.Revisions(intCount).Type = 2 Then
                            intDeletions = intDeletions + 1
                        ElseIf objDocument1.Revisions(intCount).Type = 1 Then
                            intInsertions = intInsertions + 1
                        End If
                    Next intCount
                    .Cells(lngLastRow, 4).Value = intDeletions
                    .Cells(lngLastRow, 5).Value = intInsertions
                Else
                    .Cells(lngLastRow, 7).Value = "no file in " & strFolder2
                End If
            Else
                .Cells(lngLastRow, 6).Value = "no file in " & strFolder1
            End If
            If Not objDocument1 Is Nothing Then
                If objDocument1.Revisions.Count > 0 Then
                    With objDocument1
                        .SaveAs Filename:=strFolder3 & _
                            Left(.Name, InStrRev(.Name, ".") - 1), _
                            FileFormat:=wdFormatXMLDocument
                        .Close False
                    End With
                    .Cells(lngLastRow, 8).Value = _
                        .Cells(lngLastRow, 1).Value & "x"
                    .Hyperlinks.Add Anchor:=.Cells(lngLastRow, 8), _
                        Address:=strFolder3 & .Cells(lngLastRow, 8)
                End If
            End If
            Set objDocument1 = Nothing
            If Not objDocument2 Is Nothing Then objDocument2.Close False
            Set objDocument2 = Nothing
            intInsertions = 0
            intDeletions = 0
        Next lngLastRow
    End With
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 14.01.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...