[office]word20十、word201三、word2016比较查重软件

1. word自带：审阅-比较

• 只能比较差很少的文档

2. beyond compare

• 只能比较差很少的文档 三、vba，功能强大，代码见下（包括文字、图片、表格）

NewMacros.bas

Sub 检查雷同64()
'
' 检查雷同 宏
'
'
 UserForm_x64.Show vbModeless
 
End Sub

Sub 检查雷同()
'
' 检查雷同 宏
'
'
 UserForm_x86.Show vbModeless
 
End Sub

UserForm_x86.frm

'在2013版本下开发，2010与2016版本测试OK，其余版本应该也能够但未测试不能保证正常使用

Option Explicit

'//适用与32位环境
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long

'//适用与64位office
'Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
'Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
'Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long


Private Const GWL_STYLE As Long = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const WS_THICKFRAME As Long = &H40000 '(恢复大小)
Private Const WS_MINIMIZEBOX As Long = &H20000 '(最小化)
Private Const WS_MAXIMIZEBOX As Long = &H10000 '(最大化)
Private Const SW_SHOW As Long = 5
Private Const WS_CAPTION As Long = &HC00000
Private Const WS_EX_APPWINDOW As Long = &H40000

Dim hWndForm As Long, IStyle As Long
Dim hMin As Long, hBar As Long, hTaskbar As Long
Dim ADoc As Document, BDoc As Document, CDoc As Document
Dim HighlightFinder As Boolean
Dim started As Boolean


Private Sub CommandButton8_Click()
On Error GoTo Err
Dim i As Long, icount As Long
Dim apage As Long
Dim Amap As New Collection, Bmap As New Collection
Dim ftest As String
Dim myFind As Find
Dim bfind As Boolean
Dim txtRange As Range
Dim myStart As Long, myEnd As Long


Label4.Caption = "0%"

If ADoc Is Nothing Then
    MsgBox "请选择并打开主文件！"
    Exit Sub
End If

If Dir("c:\方案检查\行政区（不要删）.txt") = Empty Then
    MsgBox "请检查c:\方案检查\行政区（不要删）.txt是否存在！"
    Exit Sub
End If

started = Not started
If started Then
    CommandButton8.Caption = "正在检查,点击中止"
Else
    CommandButton8.Caption = "检查行政区名"
End If


Open "c:\方案检查\行政区（不要删）.txt" For Input As #1
Do While Not EOF(1)
    Line Input #1, ftest
    ftest = Trim(ftest)
    If Len(ftest) > 0 Then Amap.Add ftest
    DoEvents
    If Not started Then
        Close #1
        started = Not started
        Exit Sub
    End If
Loop
Close #1
For i = 1 To Amap.Count
    apage = 0
    ftest = Amap.Item(i)
    Set myFind = ADoc.Content.Find
    Do While myFind.Execute(ftest, False, False, False, False, False, True, wdFindStop, False)
        Set txtRange = myFind.Parent
        apage = myFind.Parent.Information(wdActiveEndPageNumber)
        myStart = txtRange.Start
        myEnd = txtRange.End
        txtRange.Start = txtRange.Start - 20
        txtRange.End = txtRange.End + 30
        Bmap.Add (ftest + vbTab + "P" + Str(apage) + vbTab + txtRange.Text)
        txtRange.Start = myStart
        txtRange.End = myEnd
        DoEvents
    Loop

    Label4.Caption = Str(Int(i * 100 / Amap.Count)) + "%"
    DoEvents
    If Not started Then i = Amap.Count
Next


If Dir("c:\方案检查\", vbDirectory) = "" Then MkDir "c:\方案检查\"
    Open "c:\方案检查\查到的行政区.txt" For Output As #1
    Print #1, "查到的行政区文字以下："
    For i = 1 To Bmap.Count
        Print #1, Bmap.Item(i)
    Next
    Close #1
    If MsgBox("请查看 c:\方案检查\查到的行政区.txt", vbOKCancel) = vbOK Then Shell "Explorer.exe c:\方案检查\查到的行政区.txt", vbNormalFocus
    started = Not started
    If started Then
        CommandButton8.Caption = "正在检查,点击中止"
    Else
        CommandButton8.Caption = "检查行政区名"
    End If
Exit Sub


Err:
    MsgBox "出错了！" & vbCrLf & "错误编号：" & Err.Number & " 错误描述：" & Err.Description
    Close #1
    started = False
    CommandButton8.Caption = "检查行政区名"
'Resume Next

End Sub

Private Sub UserForm_Initialize()

hWndForm = FindWindow("ThunderDFrame", Me.Caption)
IStyle = GetWindowLong(hWndForm, GWL_STYLE)
'IStyle = IStyle Or WS_THICKFRAME '还原
'IStyle = IStyle Or WS_MINIMIZEBOX '最小化
'IStyle = IStyle Or WS_MAXIMIZEBOX '最大化
'SetWindowLong hWndForm, GWL_STYLE, IStyle
SetFocus hWndForm
started = False
End Sub

Private Sub UserForm_Terminate()
    ThisDocument.Application.Visible = True
End Sub


Function FindLB(ByVal test As String, apage As Long) As Boolean
Dim myFind As Find
Set myFind = ADoc.Content.Find
If CDoc Is Nothing Then
    FindLB = myFind.Execute(test, False, False, False, False, False, True, wdFindContinue, False)
    If FindLB Then
        apage = myFind.Parent.Information(wdActiveEndPageNumber)
        If HighlightFinder Then myFind.Parent.HighlightColorIndex = wdYellow
    End If
Else
    If CDoc.Content.Find.Execute(test, False, False, False, False, False, True, wdFindContinue, False) Then
        FindLB = False
    Else
        FindLB = myFind.Execute(test, False, False, False, False, False, True, wdFindContinue, False)
        If FindLB Then
            apage = myFind.Parent.Information(wdActiveEndPageNumber)
            If HighlightFinder Then myFind.Parent.HighlightColorIndex = wdYellow
        End If
    End If
End If
End Function


Sub GMap()
On Error GoTo Err
Dim i As Long, icount As Long, p As Long, s As Long, ls As Long
Dim apage As Long, bpage As Long
Dim Bmap As New Collection
Dim strRange As String, ftest As String
Dim fRange As Range, iRange As Range

icount = BDoc.Paragraphs.Count
For i = 1 To icount
    Set iRange = BDoc.Paragraphs(i).Range
'    strRange = Trim(iRange.Text)
    strRange = Trim(Replace(iRange.Text, "，", "。"))
'大与3个字符才检查
    ls = Len(strRange)
    If ls > 3 Then
        p = 0
        Do While p < ls
            If started = False Then Exit Sub
            s = p + 1
            p = InStr(s, strRange, "。")
            '字符数控制在4～254
            If p = 0 Then p = ls + 1
            If p - s > 255 Then p = s + 255
            If p - s > 3 Then
                ftest = Mid(strRange, s, p - s)
                If FindLB(ftest, apage) Then
                    If HighlightFinder Then
                        Set fRange = BDoc.Range(Start:=iRange.Start + s - 1, End:=iRange.Start + p - 1)
                        fRange.HighlightColorIndex = wdYellow
                    End If
                    bpage = iRange.Information(wdActiveEndPageNumber)
                    Bmap.Add ("P" + Str(apage) + "——>P" + Str(bpage) + vbTab + ftest)
                End If
            End If
            DoEvents
        Loop
    End If
    Label4.Caption = Str(Int(i * 100 / BDoc.Paragraphs.Count)) + "%"
Next

If Bmap.Count = 0 Then
    MsgBox "没有找到雷同内容"
Else
    If Dir("c:\方案检查\", vbDirectory) = "" Then MkDir "c:\方案检查\"
    Open "c:\方案检查\查重.txt" For Output As #1
    Print #1, "可能雷同内容以下："
    Print #1, "主文件位置" + vbTab + "对比文件位置" + vbTab + "雷同内容"
    For i = 1 To Bmap.Count
        Print #1, Bmap.Item(i)
    Next
    Close #1
'    MsgBox "请查看 c:\方案检查\查重.txt"
    If MsgBox("请查看 c:\方案检查\查重.txt", vbOKCancel) = vbOK Then Shell "Explorer.exe c:\方案检查\查重.txt", vbNormalFocus
End If
Exit Sub
Err:
    MsgBox "出错了！" & vbCrLf & "错误编号：" & Err.Number & " 错误描述：" & Err.Description
'Resume Next
End Sub

Function ExtractShape(Mdoc As Document) As Boolean
On Error GoTo Err
Dim sDoc As Document
Dim Mshape As InlineShape
Dim sRange As Range
Dim i As Long, EndPos As Long
i = 0

If Not Mdoc Is Nothing Then
    Set sDoc = Documents.Add
    EndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1
    Set sRange = sDoc.Range(Start:=EndPos, End:=EndPos)
    sRange.InsertAfter "图片来自：" + Mdoc.Name + Chr(10) + Chr(13)
    For Each Mshape In Mdoc.InlineShapes
        With sRange
            EndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1
            .SetRange EndPos, EndPos
            .InsertAfter "P" + Trim(Str(Mshape.Range.Information(wdActiveEndPageNumber))) + Chr(10)
            EndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1
            .SetRange EndPos, EndPos
            Mshape.Range.Copy
            .Paste
            EndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1
            .SetRange EndPos, EndPos
           .InsertAfter Chr(10) + Chr(13)
        End With
        i = i + 1
        Label4.Caption = Str(Int(i * 100 / Mdoc.InlineShapes.Count)) + "%"
        DoEvents
    Next
    If Dir("c:\方案检查\", vbDirectory) = "" Then MkDir "c:\方案检查\"
    sDoc.SaveAs2 "c:\方案检查\图片来自" + Mdoc.Name
    ExtractShape = True
Else
    ExtractShape = False
End If
Exit Function
Err:
    ExtractShape = False
    MsgBox "出错了！" & vbCrLf & "错误编号：" & Err.Number & " 错误描述：" & Err.Description
End Function

Function ExtractTable(Mdoc As Document) As Boolean
On Error GoTo Err
Dim sDoc As Document
Dim Mtable As Table
Dim sRange As Range
Dim i As Long, EndPos As Long
i = 0
If Not Mdoc Is Nothing Then
    Set sDoc = Documents.Add
    EndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1
    Set sRange = sDoc.Range(Start:=EndPos, End:=EndPos)
    sRange.InsertAfter "表格来自：" + Mdoc.Name + Chr(10) + Chr(13)
    For Each Mtable In Mdoc.Tables
        With sRange
            EndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1
            .SetRange EndPos, EndPos
            .InsertAfter "P" + Trim(Str(Mtable.Range.Information(wdActiveEndPageNumber))) + Chr(10)
            EndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1
            .SetRange EndPos, EndPos
            Mtable.Range.Copy
            .Paste
            EndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1
            .SetRange EndPos, EndPos
           .InsertAfter Chr(10) + Chr(13)
        End With
        i = i + 1
        Label4.Caption = Str(Int(i * 100 / Mdoc.InlineShapes.Count)) + "%"
        DoEvents
    Next
    If Dir("c:\方案检查\", vbDirectory) = "" Then MkDir "c:\方案检查\"
    sDoc.SaveAs2 "c:\方案检查\表格来自" + Mdoc.Name
    ExtractTable = True
Else
    ExtractTable = False
End If
Exit Function
Err:
    ExtractTable = False
    MsgBox "出错了！" & vbCrLf & "错误编号：" & Err.Number & " 错误描述：" & Err.Description
End Function


Private Sub CommandButton1_Click()

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Word文件", "*.doc;*.docx"
        .Filters.Add "All Files", "*.*"
        If .Show = -1 Then
            'FileDialog 对象的 Show 方法显示对话框，而且返回 -1（若是您按 OK）和 0（若是您按 Cancel）。
            TextBox1.Text = .SelectedItems(1)
        End If
    End With
    If Trim(TextBox1.Text) <> "" Then
        Set BDoc = Documents.Open(FileName:=TextBox1.Text, Visible:=False)
        SetFocus hWndForm
    End If
End Sub

Private Sub CommandButton2_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Word文件", "*.doc;*.docx"
        .Filters.Add "All Files", "*.*"
        If .Show = -1 Then
            'FileDialog 对象的 Show 方法显示对话框，而且返回 -1（若是您按 OK）和 0（若是您按 Cancel）。
            TextBox2.Text = .SelectedItems(1)
        End If
    End With
    If Trim(TextBox2.Text) <> "" Then
        Set CDoc = Documents.Open(FileName:=TextBox2.Text, Visible:=False)
        SetFocus hWndForm
    End If
End Sub


Private Sub CommandButton3_Click()
Dim Atrack As Boolean, Btrack As Boolean
    If ADoc Is Nothing Then
        MsgBox "请选择并打开主文件！"
        Exit Sub
    Else
        Atrack = ADoc.TrackRevisions
        ADoc.TrackRevisions = False
    End If
    If BDoc Is Nothing Then
        MsgBox "请选择并打开对比文件！"
        Exit Sub
    Else
        Btrack = BDoc.TrackRevisions
        BDoc.TrackRevisions = False
    End If
    HighlightFinder = CheckBox1.Value
'    Application.Visible = False
    ADoc.TrackRevisions = False
    started = Not started
    If started Then
        CommandButton3.Caption = "正在检查,点击中止"
        GMap
        started = Not started
        CommandButton3.Caption = "开始文字雷同检查"
    Else
        CommandButton3.Caption = "开始文字雷同检查"
    End If

    ADoc.TrackRevisions = Atrack
    BDoc.TrackRevisions = Btrack
    Application.Visible = True
End Sub


Private Sub CommandButton4_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Word文件", "*.doc;*.docx"
        .Filters.Add "All Files", "*.*"
        If .Show = -1 Then
            'FileDialog 对象的 Show 方法显示对话框，而且返回 -1（若是您按 OK）和 0（若是您按 Cancel）。
            TextBox3.Text = .SelectedItems(1)
        End If
    End With
    If Trim(TextBox3.Text) <> "" Then
        Set ADoc = Documents.Open(FileName:=TextBox3.Text, Visible:=False)
        SetFocus hWndForm
    End If
End Sub

Private Sub CommandButton5_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Word文件", "*.doc;*.docx"
        .Filters.Add "All Files", "*.*"
        If .Show = -1 Then
            'FileDialog 对象的 Show 方法显示对话框，而且返回 -1（若是您按 OK）和 0（若是您按 Cancel）。
            TextBox4.Text = .SelectedItems(1)
        End If
    End With
    If Trim(TextBox4.Text) <> "" Then
        Set ADoc = Documents.Open(FileName:=TextBox3.Text, Visible:=False)
        SetFocus hWndForm
    End If
End Sub

Private Sub CommandButton6_Click()
    Application.ScreenUpdating = False
    If ExtractShape(ADoc) Or ExtractShape(BDoc) Then
        MsgBox "抽取完成，请查看对比图片文件"
    Else
        MsgBox "抽取没有正常完成！"
    End If
    Application.Visible = True
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton7_Click()
    Application.ScreenUpdating = False
    If ExtractTable(ADoc) Or ExtractTable(BDoc) Then
        MsgBox "抽取完成，请查看对比表格文件"
    Else
        MsgBox "抽取没有正常完成！"
    End If
    Application.Visible = True
    Application.ScreenUpdating = True
    
End Sub