Date: 02-16-2022
Return to Index
created by gbSnippets
'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: (Jose Includes)
'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
%Unicode=1
#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 Long) As 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
http://www.garybeene.com/sw/gbsnippets.htm