两个文本比对程序 （多行形式的文本）

'两个 .exe 程序都要放在文件夹 SYS 旁边。 '给出的VB源文件,是黑白程序的源文件。彩色程序的源文件没有给出。 Option Explicit '这是黑白程序的全部代码 Dim n1 As Integer, n2 As Integer Dim L1 As Integer, L2 As Integer Dim QS() As Integer, CD() As Integer, mnMAX%, mn% Dim zuichang%() Dim txt1 As String, txt2 As String, WA$ Dim RS$(), LS$() Dim fnL$, fnR$ Private Sub CmdOpL_Click() Dim xx$, n%, txt$ Dim fn$ CommonDialog1.DialogTitle = "打开左边文件" CommonDialog1.FileName = "" CommonDialog1.Filter = "打开左边文件|*.*" CommonDialog1.Action = 1 CommonDialog1.FilterIndex = 1 fn = CommonDialog1.FileName CommonDialog1.InitDir = CurDir fnL = CommonDialog1.FileTitle CmdOpL.Enabled = False If fn = "" Then Exit Sub n = 0 Open fn For Input As #1 Do While Not EOF(1) Line Input #1, xx n = n + 1 ReDim Preserve LS(n) LS(n) = xx txt = txt & xx & vbCrLf Loop Close #1 L1 = n DoEvents ReDim Preserve LS(n + 1) Label12.Caption = fnL End Sub Private Sub CmdOpR_Click() Dim fn$, xx$, n%, txt$ CommonDialog1.DialogTitle = "打开右边文件" CommonDialog1.FileName = "" CommonDialog1.Filter = "打开右边文件|*.*" CommonDialog1.Action = 1 CommonDialog1.FilterIndex = 1 fn = CommonDialog1.FileName CommonDialog1.InitDir = CurDir fnR = CommonDialog1.FileTitle CmdOpR.Enabled = False If fn = "" Then Exit Sub n = 0 Open fn For Input As #1 Do While Not EOF(1) Line Input #1, xx n = n + 1 ReDim Preserve RS(n) RS(n) = xx txt = txt & xx & vbCrLf Loop Close #1 L2 = n ReDim Preserve RS(n + 1) DoEvents Label13.Caption = fnR End Sub Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Label5.Visible = True Label7.Visible = True End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Label5.Visible = False Label7.Visible = False End Sub Private Sub Form_Load() Form1.Show Label12.Caption = "编辑前" Label13.Caption = "编辑后" WA = "单击关注的行，可以显示整行内容； 拖动【右边】滚动条【滑块】，可以两边同步上下滚动" Label5.Caption = WA End Sub Private Function LCS(ByVal aa As Integer, ByVal bb As Integer) As Integer '递归函数 Dim i%, j1%, k2%, m% Dim zn1$, zn2$, a1%, b2% Dim z1$ a1 = aa b2 = bb Do zn1 = LS(a1) zn2 = RS(b2) If zn1 = zn2 Then '① m = m + 1 a1 = a1 + 1 Else '②或③1或③2---除了① i = 1 Do If a1 + i > L1 Then Exit Do '【】 z1 = LS(a1 + i) If z1 = zn2 Then For j1 = a1 To a1 + i - 1 For k2 = b2 + 1 To L2 If RS(k2) = LS(j1) Then If zuichang(j1, k2) = 0 Then zuichang(j1, k2) = LCS(j1, k2) If zuichang(a1 + i, b2) = 0 Then zuichang(a1 + i, b2) = LCS(a1 + i, b2) If zuichang(j1, k2) > zuichang(a1 + i, b2) Then ' Exit Do ' ③2 End If Exit For End If Next k2 Next j1 m = m + 1 a1 = a1 + i + 1 i = 0 Exit Do '③1 End If i = i + 1 Loop Until a1 + i > L1 '②或③2 End If b2 = b2 + 1 '①②或③1或③2 Loop Until ((a1 > L1) Or (b2 > L2)) LCS = m End Function Private Sub CmdMain_Click() '搜索和储存“编辑位置QS”和“编辑长度CD” Dim zn1$, zn2 As String, Tot% Dim Tmp As Integer, j1 As Integer, k2 As Integer, r As Integer Dim z1$, L2max% ReDim zuichang(L1, L2) DoEvents Form1.MousePointer = 11 DoEvents Tot = LCS(1, 1) '计算LCS长度 DoEvents Form1.MousePointer = 0 ReDim Preserve QS(1, 0), CD(1, 0) mn = 0 n1 = 1 n2 = 1 Do zn1 = LS(n1) zn2 = RS(n2) If zn1 = zn2 Then '① n1 = n1 + 1 If Tmp > 0 Then CD(0, mn) = 0 CD(1, mn) = Tmp End If Tmp = 0 Else If Tmp = 0 Then mn = mn + 1 ReDim Preserve QS(1, mn) ReDim Preserve CD(1, mn) QS(0, mn) = n1 QS(1, mn) = n2 End If r = 1 Do If n1 = L1 Then Exit Do End If z1 = LS(n1 + r) If z1 = zn2 Then For j1 = n1 To n1 + r - 1 For k2 = n2 + 1 To L2 If RS(k2) = LS(j1) Then If zuichang(j1, k2) > zuichang(n1 + r, n2) Then Exit Do ' ③2 End If Exit For End If Next Next CD(0, mn) = r CD(1, mn) = Tmp n1 = n1 + r + 1 r = 0 Tmp = -1 Exit Do End If r = r + 1 Loop Until n1 + r > L1 '②或③2 Tmp = Tmp + 1 End If n2 = n2 + 1 '①②或③1或③2 Loop Until ((n1 > L1) Or (n2 > L2)) If n1 <= L1 Then If Tmp = 0 Then mn = mn + 1 ReDim Preserve QS(1, mn) ReDim Preserve CD(1, mn) QS(0, mn) = n1 QS(1, mn) = n2 End If CD(0, mn) = L1 - n1 + 1 CD(1, mn) = Tmp Tmp = 0 End If If n2 <= L2 Then mn = mn + 1 ReDim Preserve QS(1, mn) ReDim Preserve CD(1, mn) QS(0, mn) = n1 QS(1, mn) = n2 CD(0, mn) = 0 CD(1, mn) = L2 - n2 + 1 End If Form1.MousePointer = 0 mnMAX = mn CmdMain.Visible = False If mn = 0 Then Exit Sub ' End If DoEvents MarkLine '加分类标志、加行号、加“斜纹行” DoEvents Label5.Visible = True '帮助 End Sub Private Sub Command2_Click() Unload Me End Sub Private Sub List1_Click() List2.ListIndex = List1.ListIndex Label6.Caption = LTrim(Mid(List2.Text, 6)) Label3.Caption = LTrim(Mid(List1.Text, 6)) End Sub Private Sub List2_Click() List1.ListIndex = List2.ListIndex Label6.Caption = LTrim(Mid(List2.Text, 6)) Label3.Caption = LTrim(Mid(List1.Text, 6)) End Sub Private Sub MarkLine() '加分类标志、加行号、加“斜纹行” Dim cha$, sha$, cuo$, hh%, pp%, mn%, i%, j% Dim tx1$, tx2$, kh$, CCDD%, Lkh$, Rkh$, kh2$ kh = " ////////////////////////////" & vbCrLf kh2 = " <<<<<<<<<<<<<<<<<<<<<<<<<<<<" & vbCrLf cha = "+ " '* sha = "- " '* cuo = "! " '* mn = 1 hh = 1 pp = 1 Do If hh = QS(0, mn) And pp = QS(1, mn) Then If CD(0, mn) > 0 And CD(1, mn) > 0 Then CCDD = CD(0, mn) - CD(1, mn) If CCDD > 0 Then For i = 1 To CCDD Rkh = Rkh & kh2 Next i End If If CCDD < 0 Then For i = 1 To Abs(CCDD) Lkh = Lkh & kh Next i End If For i = 0 To CD(0, mn) - 1 LS(QS(0, mn) + i) = cuo & Right$(" " & Trim$(Str$(QS(0, mn) + i)), 3) & " " & LS(QS(0, mn)