Date: 02-16-2022
Return to Index
created by gbSnippets
'Primary Code:
'Credit: Rod Stephenson
'Compilable Example: (Jose Includes)
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#Include "win32api.inc"
#Include "RichEdit.inc"
#Include "CommCtrl.inc"
Global hDlg As Dword, hRichEdit As Dword, txt1$, txt2$, hFont as Dword
%ID_RichEdit = 500
%ID_RichEditR = 501
%ID_RichEditL = 502
%COST_ADD1 = 1
%COST_ADD2 = 1
%COST_REPL = 1
%move_NoChange = 0
%move_Replace = 1
%move_Add1 = 2
%move_Add2 = 3
Function PBMain () As Long
Local style&
CreateSampleText txt2$, txt1$ 'txt2 is the result of changing txt1$
Font New "Courier new", 10, 1 To hFont
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, "Test Code",300,300,1180,400, %WS_OverlappedWindow To hDlg
Control Add Button, hDlg, 100,"Push", 30,10,140,20
Control Add Label, hDlg, 110,"Actions needed to convert Left to Middle are shown on Right. Black - same on both. Red - remove from left. Blue - new in Middle", 200,10,800,20
LoadLibrary("riched32.dll") : InitCommonControls
Control Add "RichEdit", hDlg, %ID_RichEditL, "",5,40,380,350, style&, %WS_Ex_ClientEdge
Control Add "RichEdit", hDlg, %ID_RichEditR, "",390,40,380,350, style&, %WS_Ex_ClientEdge
Control Add "RichEdit", hDlg, %ID_RichEdit, "",775,40,380,350, style&, %WS_Ex_ClientEdge
Control Set Text hDlg, %ID_RichEditL, $CrLf + txt1$
Control Set Text hDlg, %ID_RichEditR, $CrLf + txt2$
Control Set Font hDlg, %ID_RichEdit, hFont
Control Set Font hDlg, %ID_RichEditL, hFont
Control Set Font hDlg, %ID_RichEditR, hFont
Control Handle hDlg, %ID_RichEdit To hRichEdit
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Select Case CB.Msg
Case %WM_InitDialog
EditDistanceLines
Case %WM_Command
If CB.Msg = %WM_Command AND CB.Ctl = 100 AND CB.Ctlmsg = %BN_Clicked Then
EditDistanceLines
End If
End Select
End Function
Function EditDistanceLines() As Integer
' Costs for adding or replacing lines.
Dim lines1() As String, lines2() As String
Dim temp$, cf As CHARFORMAT, P as CharRange
Dim len1 As Integer, len2 As Integer
Dim distances() As Integer
Dim moves() As Long 'MoveType
Dim i1 As Integer, i2 As Integer
Dim line1 As String, line2 As String
Dim dist_repl As Integer
Dim dist_add1 As Integer
Dim dist_add2 As Integer
Dim move_sequence() As Long
Dim num_moves As Integer
Dim i As Integer
' Split the strings into arrays of lines.
' We add a vbCrLf at the front so we get an
' extra blank string in array entry 0.
Dim lines1 (1 to ParseCount(txt1,$CrLf))
Dim lines2 (1 to ParseCount(txt2,$CrLf))
Parse txt1$, lines1(), $CrLf 'Split(vbCrLf & txt1, vbCrLf)
Parse txt2$, lines2(), $CrLf 'Split(vbCrLf & txt2, vbCrLf)
' Allocate space for the distances
' and moves arrays.
len1 = UBound(lines1)
len2 = UBound(lines2)
ReDim distances(0 To len1, 0 To len2)
ReDim moves(0 To len1, 0 To len2)
' Initialize the arrays.
moves(0, 0) = %move_NoChange
For i1 = 1 To len1
distances(i1, 0) = distances(i1 - 1, 0) + %COST_ADD1
moves(i1, 0) = %move_Add1
Next i1
For i2 = 1 To len2
distances(0, i2) = distances(0, i2 - 1) + %COST_ADD2
moves(0, i2) = %move_Add2
Next i2
' Fill in the rest of the arrays.
For i1 = 1 To len1
line1 = lines1(i1)
For i2 = 1 To len2
line2 = lines2(i2)
' See how much it would cost to start
' from the (i1 - 1, i2 - 1) entry.
If line1 = line2 Then
dist_repl = distances(i1 - 1, i2 - 1)
Else
dist_repl = distances(i1 - 1, i2 - 1) + %COST_REPL
End If
' See how much it would cost to start
' from the (i1 - 1, i2) and (i1, i2 - 1)
' entries.
dist_add1 = distances(i1 - 1, i2) + %COST_ADD1
dist_add2 = distances(i1, i2 - 1) + %COST_ADD2
' See which method is cheapest.
If (dist_repl <= dist_add1) AND (dist_repl <= dist_add2) Then
distances(i1, i2) = dist_repl
If line1 = line2 Then
moves(i1, i2) = %move_NoChange
Else
moves(i1, i2) = %move_Replace
End If
ElseIf (dist_add1 <= dist_repl) AND (dist_add1 <= dist_add2) Then
distances(i1, i2) = dist_add1
moves(i1, i2) = %move_Add1
Else
distances(i1, i2) = dist_add2
moves(i1, i2) = %move_Add2
End If
Next i2
Next i1
' Set the return edit distance value.
EditDistanceLines = distances(len1, len2)
' Make a list of the moves we took
' (in reverse order).
i1 = len1
i2 = len2
Do While (i1 > 0) Or (i2 > 0)
' Save the move.
num_moves = num_moves + 1
ReDim Preserve move_sequence(1 To num_moves)
move_sequence(num_moves) = moves(i1, i2)
' Go to the previous position in the array.
Select Case moves(i1, i2)
Case %move_NoChange
i1 = i1 - 1
i2 = i2 - 1
Case %move_Replace
i1 = i1 - 1
i2 = i2 - 1
Case %move_Add1
i1 = i1 - 1
Case %move_Add2
i2 = i2 - 1
End Select
Loop
' Use the moves to build the result string.
i1 = 1
i2 = 1
' LockWindowUpdate hRichEdit 'rchDifference.hWnd
Control Set Text hDlg, %ID_RichEdit, "" 'rchDifference.Text = ""
For i = num_moves To 1 Step -1
Select Case move_sequence(i)
Case %move_Add1
AddToEndAndSelect $CrLf + lines1(i1)
SetRichTextColor %Red 'set format of selection + StrikeThru
i1 = i1 + 1
Case %move_Add2
AddToEndAndSelect $CrLf + lines2(i2)
SetRichTextColor %Blue 'set format of selection
i2 = i2 + 1
Case %move_Replace
AddToEndAndSelect $CrLf + lines1(i1)
SetRichTextColor %Red 'set format of selection + StrikeThru
AddToEndAndSelect $CrLf + lines2(i2)
SetRichTextColor %Blue 'set format of selection
i1 = i1 + 1
i2 = i2 + 1
Case %move_NoChange
AddToEndAndSelect $CrLf + lines2(i2)
SetRichTextColor %Black 'set format of selection
i1 = i1 + 1
i2 = i2 + 1
End Select
Next i
'unselect all
P.cpmin = -1 : P.cpmax = 0
SendMessage(hRichEdit, %EM_EXSetSel, 0, VarPTR(p))
' LockWindowUpdate 0
End Function
Function SetRichTextColor( ByVal NewColor As Long) As Long
' setRichTextColor sets the textcolor for selected text in a Richedit control.
Local cf As CHARFORMAT
cf.cbSize = Len(cf) 'Length of structure
cf.dwMask = %CFM_COLOR Or %CFM_STRIKEOUT 'Set mask to colors only
If NewColor = %Red Then cf.dwEffects = %CFE_StrikeOut Else cf.dwEffects = 0
cf.crTextColor = NewColor 'Set the new color value
SendMessage(hRichEdit, %EM_SETCHARFORMAT, %SCF_SELECTION, VarPTR(cf))
End Function
Function AddToEndAndSelect(ByVal buf$) As Long
Local D As GetTextLengthEX, T As TextRange, iTextLength&, iResult&, P As CharRange, temp$
'get length of all text
D.flags = %GTL_Default
iTextLength& = SendMessage(hRichEdit, %EM_GetTextLengthEX, VarPTR(D),0)
'put cursor at end of control
P.cpmin = iTextLength& : P.cpmax = P.cpmin
SendMessage hRichEdit, %EM_EXSetSel, 0, VarPTR(P) To iResult& 'put cursor at end of control
'put text at cursor
SendMessage(hRichEdit, %EM_ReplaceSel, %True, StrPTR(buf$)) 'only replace if selection exists.
'select last line
P.cpmin = iTextLength& + 2 : P.cpmax = P.cpmin + Len(buf$)
SendMessage hRichEdit, %EM_EXSetSel, 0, VarPTR(P) To 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_00335
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm