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

Frage: Worddokumente vergleichen - aus Excel. In zwei Verzeichnissen sind unterschiedliche Versionen zweier Worddateien. Die Anzahl der "Deletions" und "Insertions" sollen in Excel geschrieben werden. 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. How does it work?

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

Links zum Thema:
Link 1...
Link 2...

Siehe auch hier:
Link 3...

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
' Variablendeklaration 
Const wdCompareDestinationOriginal = 0
Private blnTMP As Boolean
Private objApp As Object
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 11.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      : 11.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 objDocument1.Close False
            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      : 11.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)...