Text Differences - Side by Side

Category: Strings

Date: 03-28-2012

Return to Index


 
'It's a very common need to compare two strings, as well as to
'display the differences to the user. gbSnippets uses the following
'code for comparing snippets as part of the Server Synchronization
'features.
 
'Primary Code'
'The ShowDifference() procedure below starts with text in the left
'RichEdit control and compares it a line at a time with the text in
'the right RichEdit control. It performs a simple 10-line look ahead
'for matching text.  It works well for text with small differences
'and won't win any speed contests (though, for small strings it's
'more than adequately fast).
 
 
'Compilable Example:
'This example simply loads slightly different text into reach RichEdit
'control. Differences are noted with a line of asterisks, "*****".  The
'reset button restores the original text.
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#Include "win32api.inc"
#Include "richedit.inc"
#Include "commctrl.inc"
%ID_RELeft = 200  : %ID_RERight = 300 : %ID_Button = 400
Global hDlg As Dword, hRELeft As Dword, hRERight As Dword
Global txt1$, txt2$
 
Function PBMain () As Long
   Local Style&
   CreateSampleText txt2$, txt1$  'txt2 is the result of changing txt1$
   style& = %WS_Child Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll Or %ES_AutoHScroll _
      Or %WS_HScroll Or %ES_AutoVScroll Or %ES_WantReturn Or %ES_NoHideSel Or %WS_TabStop
   Dialog New Pixels, 0, "Compare Text Example",400,400,600,300, %WS_OverlappedWindow To hDlg
   Control Add Button, hDlg, %ID_Button, "Compare", 30,10,100,20
   LoadLibrary("riched32.dll") : InitCommonControls
   Control Add "RichEdit", hDlg, %ID_RELeft, txt1$,0,0,50,50, style&, %WS_Ex_ClientEdge
   Control Add "RichEdit", hDlg, %ID_RERight, txt2$,0,0,50,50, style&, %WS_Ex_ClientEdge
   Control Handle hDlg, %ID_RELeft To hRELeft
   Control Handle hDlg, %ID_RERight To hRERight
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Select Case CB.Msg
      Case %WM_Command
         If CB.Ctl = %ID_Button Then ShowDifference txt2$, txt1$
      Case %WM_Size
         'resizes controls when form is resized
         Dim w As Long, h As Long
         Dialog Get Client CB.Hndl To w,h
         Control Set Loc CB.Hndl, %ID_RELeft, 5,35
         Control Set Size CB.Hndl, %ID_RELeft, (w-20)/2, h-40
         Control Set Loc CB.Hndl, %ID_RERight, w/2+5, 35
         Control Set Size CB.Hndl, %ID_RERight, (w-20)/2, h-40
   End Select
End Function
 
Sub ShowDifference(A as String, B as String)
   Local Found As Long, iStep As Long, iPaint$, S() As String
   Local i As Long, j As Long, n As Long, Done As Long, r As Long, iCount&
   Local A1() As String, B1() As String, LText As String, RText As String, P as CharRange
 
   ReDim A1(ParseCount(A,$CrLf)-1), B1(ParseCount(B,$CrLf)-1)
   Parse A, A1(), $CrLf : Parse B, B1(), $CrLf
 
   LText = "" : RText = ""
   'start by comparing lines A1(0) and B1(0)
   Do While Not Done
      If i > UBound(A1) Then
         'no more A1() entries, so load all remaining B1() entries
         For n = j To UBound(B1)
            LText = LText + $CrLf + ""
            RText = RText + $CrLf + B1(n)
            Incr iCount : iPaint = iPaint & ":" & Str$(iCount)
         Next n
         Done = %True
         Exit Do
      End If
      If j > UBound(B1) Then
         'no more B1() entries, so load all remaining A1() entries
         For n = i To UBound(A1)
            LText = LText + $CrLf + A1(n)
            RText = RText + $CrLf + ""
            Incr iCount : iPaint = iPaint & ":" & Str$(iCount)
         Next n
         Done = %True
         Exit Do
      End If
      If A1(i) = B1(j) Then
         'they are equal so display them
         LText = LText + $CrLf + A1(i)
         RText = RText + $CrLf + B1(j)
         Incr iCount
         'go to next pair of lines
         i = i + 1
         j = j + 1
      Else
         'they are not equal, so check to see if B1(j) is
         'found within the next 10 lines of A1()
         Found = %False
         iStep = 20
         If i + iStep > UBound(A1) Then iStep = UBound(A1) - i
         For r = 1 To iStep
            If A1(i + r) = B1(j) Then
               Found = %True
               Exit For
            End If
         Next r
         If Found = %True Then
            'B1(j) was found within 10 lines of A()
            'print all of A1(i)-n/a up to the point it is found
            'then print A1(i)-B1(j)
            'If r > 1 Then
            For n = 0 To r - 1
               LText = LText + $CrLf + A1(i + n)
               RText = RText + $CrLf + String$(50, "*")
               Incr iCount& : iPaint = iPaint & ":" & Str$(iCount)
            Next n
            'End If
            LText = LText + $CrLf + A1(i + r)
            RText = RText + $CrLf + B1(j)
            Incr iCount
            i = i + r + 1
            j = j + 1
         Else
            'B1(j) was not found within 10 lines of A()
            'print n/a-B1(j)
            LText = LText + $CrLf + String$(50, "*")
            RText = RText + $CrLf + B1(j)
            Incr iCount& : iPaint = iPaint & ":" & Str$(-1*iCount)
            j = j + 1
         End If
      End If
   Loop
 
   'get rid of leading $crlf
   If Len(LText) > 0 Then LText = Right$(LText, Len(LText) - 2)
   If Len(RText) > 0 Then RText = Right$(RText, Len(RText) - 2)
 
   'show differences
   Control Set Text hDlg, %ID_RELeft, LText
   Control Set Text hDlg, %ID_RERight, RText
 
   '    'color lines
   If Left$(iPaint$, 1) = ":Then
      ReDim S(ParseCount(iPaint$,":")-1)
      Parse iPaint$, S(), ":"
      For i = 1 To UBound(S)
         SelectText %ID_RELeft, ABS(Val(s(i)))-1
         SelectText %ID_RERight, ABS(Val(s(i)))-1
         If Val(s(i)) < 0 Then
            SetRichTextColor hRELeft, %Red
            SetRichTextColor hRERight, %Red
         Else
            SetRichTextColor hRELeft, %Blue
            SetRichTextColor hRERight, %Blue
         End If
      Next i
 
      P.cpmin = 0 : P.cpmax = 0
      SendMessage(hRELeft, %EM_EXSetSel, 0, VarPTR(P))
      SendMessage(hRERight, %EM_EXSetSel, 0, VarPTR(P))
   End If
 
End Sub
 
Function SetRichTextColor(hRE As Dword, ByVal NewColor As LongAs Long
   Local cf As CHARFORMAT
   cf.cbSize      = Len(cf)       'Length of structure
   cf.dwMask      = %CFM_COLOR    'Set mask to colors only
   cf.crTextColor = NewColor      'Set the new color value
   Call SendMessage(hRE, %EM_SETCHARFORMAT, %SCF_SELECTION, VarPTR(cf))
End Function
 
Function SelectText(ID_RE&, m&)  as Long
   Local iLineLength&, P as CharRange, iResult&
   Control Send hDlg, ID_RE&, %EM_LineIndex, m&, 0 To P.cpmin   'position of 1st char in start line
   Control Send hDlg, ID_RE&, %EM_LineLength, P.cpmin, 0 TO iLineLength&   'length of last line
   P.cpmax = P.cpmin + iLineLength&
   Control Send hDlg, ID_RE&, %EM_EXSetSel, 0, VarPTR(P) To iResult&
   Function = iResult&
End Function
 
Sub CreateSampleText(a$, b$)
   a$ = "Private Function FileContents() As String" + $crlf
   a$ = a$ + "Dim fnum As Integer" + $crlf
   a$ = a$ + "Dim txt As String" + $crlf
   a$ = a$ + "" + $crlf
   a$ = a$ + "    On Error GoTo FileContentsError" + $crlf
   a$ = a$ + "" + $crlf
   a$ = a$ + "    fnum = FreeFile" + $crlf
   a$ = a$ + "    Open file_name For Input As fnum" + $crlf
   a$ = a$ + "    txt = Input$(Lof(fnum), #fnum)" + $crlf
   a$ = a$ + "    Close #fnum" + $crlf
   a$ = a$ + "    FileContents = txt" + $crlf
   a$ = a$ + "    " + $crlf
   a$ = a$ + "FileContentsError:" + $crlf
   b$ = "Private Function FileContents() As String" + $crlf
   b$ = b$ + "Dim txt As String" + $crlf
   b$ = b$ + "" + $crlf
   b$ = b$ + "    On Error GoTo FileContentsError" + $crlf
   b$ = b$ + "" + $crlf
   b$ = b$ + "    Open file_name For Input As 1" + $crlf
   b$ = b$ + "    txt = Input$(Lof(fnum), #1)" + $crlf
   b$ = b$ + "    Close #1" + $crlf
   b$ = b$ + "    FileContents = txt" + $crlf
   b$ = b$ + "    " + $crlf
   b$ = b$ + "FileContentsError:" + $crlf
End Sub
 
'gbs_00326
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm