Text Difference - Markup/Strikeout

Category: Strings

Date: 03-28-2012

Return to Index


 
'Primary Code:
'Credit: Rod Stephenson
 
 
'Compilable Example:
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#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 LongAs 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


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