来自 技术 2019-04-17 00:00 的文章

[office]word2010、word2013、word2016比较查重软件

八年Java开发的感悟:什么才是程序员的立身之本>>>   

word自带:审阅-比较只能比较差不多的文档
    beyond compare只能比较差不多的文档3、vba,功能强大,代码见下(包括文字、图片、表格)

    NewMacros.bas

    Sub 检查雷同64()'' 检查雷同 宏'' UserForm_x64.Show vbModeless End SubSub 检查雷同()'' 检查雷同 宏'' 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 LongPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As LongPrivate 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 = 5Private Const WS_CAPTION As Long = &HC00000Private Const WS_EX_APPWINDOW As Long = &H40000Dim hWndForm As Long, IStyle As LongDim hMin As Long, hBar As Long, hTaskbar As LongDim ADoc As Document, BDoc As Document, CDoc As DocumentDim HighlightFinder As BooleanDim started As BooleanPrivate Sub CommandButton8_Click()On Error GoTo ErrDim i As Long, icount As LongDim apage As LongDim Amap As New Collection, Bmap As New CollectionDim ftest As StringDim myFind As FindDim bfind As BooleanDim txtRange As RangeDim myStart As Long, myEnd As LongLabel4.Caption = "0%"If ADoc Is Nothing Then MsgBox "请选择并打开主文件!" Exit SubEnd IfIf Dir("c:\方案检查\行政区(不要删).txt") = Empty Then MsgBox "请检查c:\方案检查\行政区(不要删).txt是否存在!" Exit SubEnd Ifstarted = Not startedIf started Then CommandButton8.Caption = "正在检查,点击停止"Else CommandButton8.Caption = "检查行政区名"End IfOpen "c:\方案检查\行政区(不要删).txt" For Input As #1Do 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 IfLoopClose #1For 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.CountNextIf 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 IfExit SubErr: MsgBox "出错了!" & vbCrLf & "错误编号:" & Err.Number & " 错误描述:" & Err.Description Close #1 started = False CommandButton8.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, IStyleSetFocus hWndFormstarted = FalseEnd SubPrivate Sub UserForm_Terminate() ThisDocument.Application.Visible = TrueEnd SubFunction FindLB(ByVal test As String, apage As Long) As BooleanDim myFind As FindSet myFind = ADoc.Content.FindIf 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 IfElse 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 IfEnd IfEnd FunctionSub GMap()On Error GoTo ErrDim i As Long, icount As Long, p As Long, s As Long, ls As LongDim apage As Long, bpage As LongDim Bmap As New CollectionDim strRange As String, ftest As StringDim fRange As Range, iRange As Rangeicount = BDoc.Paragraphs.CountFor 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)) + "%"NextIf 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", vbNormalFocusEnd IfExit SubErr: MsgBox "出错了!" & vbCrLf & "错误编号:" & Err.Number & " 错误描述:" & Err.Description'Resume NextEnd SubFunction ExtractShape(Mdoc As Document) As BooleanOn Error GoTo ErrDim sDoc As DocumentDim Mshape As InlineShapeDim sRange As RangeDim i As Long, EndPos As Longi = 0If 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 = TrueElse ExtractShape = FalseEnd IfExit FunctionErr: ExtractShape = False MsgBox "出错了!" & vbCrLf & "错误编号:" & Err.Number & " 错误描述:" & Err.DescriptionEnd FunctionFunction ExtractTable(Mdoc As Document) As BooleanOn Error GoTo ErrDim sDoc As DocumentDim Mtable As TableDim sRange As RangeDim i As Long, EndPos As Longi = 0If 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 = TrueElse ExtractTable = FalseEnd IfExit FunctionErr: ExtractTable = False MsgBox "出错了!" & vbCrLf & "错误编号:" & Err.Number & " 错误描述:" & Err.DescriptionEnd 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 If End With If Trim(TextBox1.Text) <> "" Then Set BDoc = Documents.Open(FileName:=TextBox1.Text, Visible:=False) SetFocus hWndForm End IfEnd 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 If End With If Trim(TextBox2.Text) <> "" Then Set CDoc = Documents.Open(FileName:=TextBox2.Text, Visible:=False) SetFocus hWndForm End IfEnd SubPrivate 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 = TrueEnd 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 If End With If Trim(TextBox3.Text) <> "" Then Set ADoc = Documents.Open(FileName:=TextBox3.Text, Visible:=False) SetFocus hWndForm End IfEnd 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 If End With If Trim(TextBox4.Text) <> "" Then Set ADoc = Documents.Open(FileName:=TextBox3.Text, Visible:=False) SetFocus hWndForm End IfEnd SubPrivate Sub CommandButton6_Click() Application.ScreenUpdating = False If ExtractShape(ADoc) Or ExtractShape(BDoc) Then MsgBox "抽取完成,请查看对比图片文件" Else MsgBox "抽取没有正常完成!" End If Application.Visible = True Application.ScreenUpdating = TrueEnd SubPrivate 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