[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