1. word自带：审阅-比较

• 只能比较差不多的文档

1. beyond compare

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

NewMacros.bas

Sub 检查雷同64()
'
' 检查雷同 宏
'
'UserForm_x64.Show vbModelessEnd SubSub 检查雷同()
'
' 检查雷同 宏
'
'UserForm_x86.Show vbModelessEnd 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 LongPrivate 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 = &H40000Dim 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 BooleanPrivate 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 LongLabel4.Caption = "0%"If ADoc Is Nothing ThenMsgBox "请选择并打开主文件！"Exit Sub
End IfIf Dir("c:\方案检查\行政区（不要删）.txt") = Empty ThenMsgBox "请检查c:\方案检查\行政区（不要删）.txt是否存在！"Exit Sub
End Ifstarted = Not started
If started ThenCommandButton8.Caption = "正在检查,点击停止"
ElseCommandButton8.Caption = "检查行政区名"
End IfOpen "c:\方案检查\行政区（不要删）.txt" For Input As #1
Do While Not EOF(1)Line Input #1, ftestftest = Trim(ftest)If Len(ftest) > 0 Then Amap.Add ftestDoEventsIf Not started ThenClose #1started = Not startedExit SubEnd If
Loop
Close #1
For i = 1 To Amap.Countapage = 0ftest = Amap.Item(i)Set myFind = ADoc.Content.FindDo While myFind.Execute(ftest, False, False, False, False, False, True, wdFindStop, False)Set txtRange = myFind.Parentapage = myFind.Parent.Information(wdActiveEndPageNumber)myStart = txtRange.StartmyEnd = txtRange.EndtxtRange.Start = txtRange.Start - 20txtRange.End = txtRange.End + 30Bmap.Add (ftest + vbTab + "P" + Str(apage) + vbTab + txtRange.Text)txtRange.Start = myStarttxtRange.End = myEndDoEventsLoopLabel4.Caption = Str(Int(i * 100 / Amap.Count)) + "%"DoEventsIf Not started Then i = Amap.Count
NextIf Dir("c:\方案检查\", vbDirectory) = "" Then MkDir "c:\方案检查\"Open "c:\方案检查\查到的行政区.txt" For Output As #1Print #1, "查到的行政区文字如下："For i = 1 To Bmap.CountPrint #1, Bmap.Item(i)NextClose #1If MsgBox("请查看 c:\方案检查\查到的行政区.txt", vbOKCancel) = vbOK Then Shell "Explorer.exe c:\方案检查\查到的行政区.txt", vbNormalFocusstarted = Not startedIf started ThenCommandButton8.Caption = "正在检查,点击停止"ElseCommandButton8.Caption = "检查行政区名"End If
Exit SubErr:MsgBox "出错了！" & vbCrLf & "错误编号：" & Err.Number & " 错误描述：" & Err.DescriptionClose #1started = FalseCommandButton8.Caption = "检查行政区名"
'Resume NextEnd SubPrivate 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 SubPrivate Sub UserForm_Terminate()ThisDocument.Application.Visible = True
End SubFunction FindLB(ByVal test As String, apage As Long) As Boolean
Dim myFind As Find
Set myFind = ADoc.Content.Find
If CDoc Is Nothing ThenFindLB = myFind.Execute(test, False, False, False, False, False, True, wdFindContinue, False)If FindLB Thenapage = myFind.Parent.Information(wdActiveEndPageNumber)If HighlightFinder Then myFind.Parent.HighlightColorIndex = wdYellowEnd If
ElseIf CDoc.Content.Find.Execute(test, False, False, False, False, False, True, wdFindContinue, False) ThenFindLB = FalseElseFindLB = myFind.Execute(test, False, False, False, False, False, True, wdFindContinue, False)If FindLB Thenapage = myFind.Parent.Information(wdActiveEndPageNumber)If HighlightFinder Then myFind.Parent.HighlightColorIndex = wdYellowEnd IfEnd If
End If
End FunctionSub 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 Rangeicount = BDoc.Paragraphs.Count
For i = 1 To icountSet iRange = BDoc.Paragraphs(i).Range
'    strRange = Trim(iRange.Text)strRange = Trim(Replace(iRange.Text, "，", "。"))
'大与3个字符才检查ls = Len(strRange)If ls > 3 Thenp = 0Do While p < lsIf started = False Then Exit Subs = p + 1p = InStr(s, strRange, "。")'字符数控制在4～254If p = 0 Then p = ls + 1If p - s > 255 Then p = s + 255If p - s > 3 Thenftest = Mid(strRange, s, p - s)If FindLB(ftest, apage) ThenIf HighlightFinder ThenSet fRange = BDoc.Range(Start:=iRange.Start + s - 1, End:=iRange.Start + p - 1)fRange.HighlightColorIndex = wdYellowEnd Ifbpage = iRange.Information(wdActiveEndPageNumber)Bmap.Add ("P" + Str(apage) + "——>P" + Str(bpage) + vbTab + ftest)End IfEnd IfDoEventsLoopEnd IfLabel4.Caption = Str(Int(i * 100 / BDoc.Paragraphs.Count)) + "%"
NextIf Bmap.Count = 0 ThenMsgBox "没有找到雷同内容"
ElseIf Dir("c:\方案检查\", vbDirectory) = "" Then MkDir "c:\方案检查\"Open "c:\方案检查\查重.txt" For Output As #1Print #1, "可能雷同内容如下："Print #1, "主文件位置" + vbTab + "对比文件位置" + vbTab + "雷同内容"For i = 1 To Bmap.CountPrint #1, Bmap.Item(i)NextClose #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 SubFunction 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 = 0If Not Mdoc Is Nothing ThenSet sDoc = Documents.AddEndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1Set sRange = sDoc.Range(Start:=EndPos, End:=EndPos)sRange.InsertAfter "图片来自：" + Mdoc.Name + Chr(10) + Chr(13)For Each Mshape In Mdoc.InlineShapesWith sRangeEndPos = 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, EndPosMshape.Range.Copy.PasteEndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1.SetRange EndPos, EndPos.InsertAfter Chr(10) + Chr(13)End Withi = i + 1Label4.Caption = Str(Int(i * 100 / Mdoc.InlineShapes.Count)) + "%"DoEventsNextIf Dir("c:\方案检查\", vbDirectory) = "" Then MkDir "c:\方案检查\"sDoc.SaveAs2 "c:\方案检查\图片来自" + Mdoc.NameExtractShape = True
ElseExtractShape = False
End If
Exit Function
Err:ExtractShape = FalseMsgBox "出错了！" & vbCrLf & "错误编号：" & Err.Number & " 错误描述：" & Err.Description
End FunctionFunction 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 ThenSet sDoc = Documents.AddEndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1Set sRange = sDoc.Range(Start:=EndPos, End:=EndPos)sRange.InsertAfter "表格来自：" + Mdoc.Name + Chr(10) + Chr(13)For Each Mtable In Mdoc.TablesWith sRangeEndPos = 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, EndPosMtable.Range.Copy.PasteEndPos = sDoc.Paragraphs(sDoc.Paragraphs.Count).Range.End - 1.SetRange EndPos, EndPos.InsertAfter Chr(10) + Chr(13)End Withi = i + 1Label4.Caption = Str(Int(i * 100 / Mdoc.InlineShapes.Count)) + "%"DoEventsNextIf Dir("c:\方案检查\", vbDirectory) = "" Then MkDir "c:\方案检查\"sDoc.SaveAs2 "c:\方案检查\表格来自" + Mdoc.NameExtractTable = True
ElseExtractTable = False
End If
Exit Function
Err:ExtractTable = FalseMsgBox "出错了！" & vbCrLf & "错误编号：" & Err.Number & " 错误描述：" & Err.Description
End FunctionPrivate 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 IfEnd WithIf Trim(TextBox1.Text) <> "" ThenSet BDoc = Documents.Open(FileName:=TextBox1.Text, Visible:=False)SetFocus hWndFormEnd If
End SubPrivate 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 IfEnd WithIf Trim(TextBox2.Text) <> "" ThenSet CDoc = Documents.Open(FileName:=TextBox2.Text, Visible:=False)SetFocus hWndFormEnd If
End SubPrivate Sub CommandButton3_Click()
Dim Atrack As Boolean, Btrack As BooleanIf ADoc Is Nothing ThenMsgBox "请选择并打开主文件！"Exit SubElseAtrack = ADoc.TrackRevisionsADoc.TrackRevisions = FalseEnd IfIf BDoc Is Nothing ThenMsgBox "请选择并打开对比文件！"Exit SubElseBtrack = BDoc.TrackRevisionsBDoc.TrackRevisions = FalseEnd IfHighlightFinder = CheckBox1.Value
'    Application.Visible = FalseADoc.TrackRevisions = Falsestarted = Not startedIf started ThenCommandButton3.Caption = "正在检查,点击停止"GMapstarted = Not startedCommandButton3.Caption = "开始文字雷同检查"ElseCommandButton3.Caption = "开始文字雷同检查"End IfADoc.TrackRevisions = AtrackBDoc.TrackRevisions = BtrackApplication.Visible = True
End SubPrivate 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 IfEnd WithIf Trim(TextBox3.Text) <> "" ThenSet ADoc = Documents.Open(FileName:=TextBox3.Text, Visible:=False)SetFocus hWndFormEnd If
End SubPrivate 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 IfEnd WithIf Trim(TextBox4.Text) <> "" ThenSet ADoc = Documents.Open(FileName:=TextBox3.Text, Visible:=False)SetFocus hWndFormEnd If
End SubPrivate Sub CommandButton6_Click()Application.ScreenUpdating = FalseIf ExtractShape(ADoc) Or ExtractShape(BDoc) ThenMsgBox "抽取完成，请查看对比图片文件"ElseMsgBox "抽取没有正常完成！"End IfApplication.Visible = TrueApplication.ScreenUpdating = True
End SubPrivate Sub CommandButton7_Click()Application.ScreenUpdating = FalseIf ExtractTable(ADoc) Or ExtractTable(BDoc) ThenMsgBox "抽取完成，请查看对比表格文件"ElseMsgBox "抽取没有正常完成！"End IfApplication.Visible = TrueApplication.ScreenUpdating = TrueEnd Sub