Link to home
Start Free TrialLog in
Avatar of Randy T
Randy TFlag for Canada

asked on

Using ANSI in a Rich Text Box

Here is my code:

Dim stCodes(1 To 3) As String

Private Sub Command1_Click()
    Dim pos As Long
    Dim m As Integer
    Dim temp As String
    Dim strng As String
    strng = RichText1.Text
    For m = 1 To 3
        pos = InStr(strng, stCodes(m))
        If pos > 0 Then
            temp = Mid$(strng, 1, pos - 1)
            temp = temp & Mid$(strng, pos + Len(stCodes(m)))
            strng = temp
            m = 0
        End If
    Next m
    RichText1.Text = strng
End Sub

Private Sub Form_Load()
    stCodes(1) = "[37;40;0m"
    stCodes(2) = "[31m"
    stCodes(3) = "[34m"
    RichText1.Text = "This text should be normal" & vbCrLf & _
        "[31mThis text should be red" & vbCrLf & _
        "[34mThis text should be blue" & vbCrLf & _
        "This text should be normal too"
End Sub


I want the strings to turn red and blue accordingly, by finding the [31m and [34m codes, then removing the [31m and [34m codes from the RichTextBox. I do not want to use RichTextBox.Find as it doesn't help. I need to use InStr() to find these codes and remove them. I've tried using SelStart, SelLength and SelColor but they don't seem to like to work if the SelStart isn't 0. Any help would be appreciated. This is just a smaller problem I have, if this helps solve my bigger problem I will award more points.

Thanks,
Skippy
Avatar of GivenRandy
GivenRandy

For a function that adds text of a specified color, use AddColorText:

---
Public Sub AddColorText(RTB As RichTextBox, Color As Long, Text As String)
    Dim R As Long
    Dim G As Long
    Dim B As Long
   
    R = Color Mod &H100
    G = (Color \ &H100) Mod &H100
    B = (Color \ &H10000) Mod &H10000
    RTB.SelRTF = "{{\colortbl;\red" & CStr(R) & "\green" & CStr(G) & "\blue" & CStr(B) & ";}" & "{\cf1 " & Text & "}}"
End Sub
---
Avatar of Brendt Hess
Let's look at it a different way.

All of your codes start with '[' (in fact, all start with '[3', but let's make the simplest assumption)

Colors continue until either (a) a new code or (from your example) (b) an end of line (vbCrLf)

Type ColorInfo
    Code as String
    Value as Long
End Type
 
Dim stCodes(0 To 3) As ColorInfo

Private Sub Command1_Click()
    Dim pos As Long
    Dim ColorBlocks() as Long
    Dim m As Integer
    Dim temp As String
    Dim strng As String
    Dim cCt as Integer

    strng = RichText1.Text
    Redim ColorBlocks(0 to 2, 0 to 0)
    cCt = 0
    Pos = InStr(Pos + 1, strng, "[")
    Do While Pos > 0
        For m = 1 to ubound(stCodes)
            If Mid(strng, pos, len(stCodes(m).Code)) = stCodes(m).Code Then
                cCt = cCt + 1
                Redim Preserve ColorBlocks(0 to 1, 0 to cCt)
                ColorBlocks(0, cCt) = Pos   ' save start pos of color
                ColorBlocks(1, cCt - 1) = Pos   ' Max pos of previous color
                ColorBlocks(2, cCt) = m  ' Save reference to block color
                Exit For    ' No more - found one
            End If
        Next m
        If Pos = Len(strng) then Exit Do
        Pos = InStr(Pos + 1, strng, "[")
    Loop

' check for vbCrLf to see if terminated earlier than next code
    If UBound(ColorBlocks,2) > 0 Then ' there are codes to convert
        For m = UBound(ColorBlocks, 2) to 1 step -1
            Pos = InStr(ColorBlocks(0, m), strng, vbCrLf)
            If Pos > 0 And Pos < ColorBlocks(1, m) Then ColorBlocks(1, m) = Pos
            If ColorBlocks(1, m) < ColorBlocks(0, m) Then ColorBlocks(1, m) = Len(strng)
            RichText1.SelStart = ColorBlocks(0, m) + Len(stCodes(m).Code)
            RichText1.SelLength = ColorBlocks(1, m) - RichText1.SelStart
            RichText1.SelColor = stCodes(m).Value
            RichText1.SelStart = ColorBlocks(0, m)
            RichText1.SelLength = Len(stCodes(m).Code)
            RichText1.SelText = ""   ' Remove code
        Next m
    End If        

End Sub

Private Sub Form_Load()
    stCodes(0).Value = QBColor(0)  ' Black - use as default
    stCodes(1).Code = "[37;40;0m"
    stCodes(1).Value = QBColor(5) ' Magenta - I don't know what you want here
    stCodes(2).Code = "[31m"
    stCodes(2).Value = QBColor(4) ' Red
    stCodes(3) = "[34m"
    stCodes(3).Value = QBColor(1) ' Blue
    RichText1.Text = "This text should be normal" & vbCrLf & _
        "[31mThis text should be red" & vbCrLf & _
        "[34mThis text should be blue" & vbCrLf & _
        "This text should be normal too"
End Sub
Avatar of Randy T

ASKER

I don't understand your answer at all GivenRandy, it doesn't help me locate the [31m or [34m and apply colors when they are found.

I tried your answer bhess1 and I got a subscript out of range on this line

ReDim Preserve ColorBlocks(0 To 1, 0 To cCt)

Skippy
Avatar of Randy T

ASKER

Also I noticed you have RichText1.SelStart equal to something other than 0. It doesn't work if it is bigger than 0 I've tried. I tried setting SelStart to 1, what I thought should happen is everything except the first character would change color. Wrong answer, nothing changed.
Oops - the Redim Preserve should be:

ReDim Preserve ColorBlocks(0 To 2, 0 To cCt)
Avatar of Randy T

ASKER

Ok, that's close :)
This is what happened.



This text should be normal    <- Normal
[ext should be red            <- Magenta
[his text should be blue      <- Red(looks like maroon)
This text should be normal too <- Red (looks like maroon)


Almost, I now need it to not delete the "This t" of the second line and the "T" of the third line and get rid of both the "[" things.
Avatar of Randy T

ASKER

And I did this just to see what would happen

This text should be normal
[31mThis text should be red
[34mThis text should be blue
This text should be normal too
[31mThis text should be red

Then pressed the Command1 button
I expected the second "[31mThis text should be red" to do exactly as the first one. The top 4 lines were the same as I indicted before, just the 5th line turned blue and lost did this

[his text should be red (in blue, I figured it would turn magenta).

I don't get it? I need the program to find these "[#m" codes and turn the following text it's correct colour and then eliminate the "[#m" code from the RTB.

Thanks
Okay - brain cramps obviously were the problem here.  Change this block of code:

    If UBound(ColorBlocks,2) > 0 Then ' there are codes to convert
        For m = UBound(ColorBlocks, 2) to 1 step -1
            Pos = InStr(ColorBlocks(0, m), strng, vbCrLf)
            If Pos > 0 And Pos < ColorBlocks(1, m) Then ColorBlocks(1, m) = Pos
            If ColorBlocks(1, m) < ColorBlocks(0, m) Then ColorBlocks(1, m) = Len(strng)
            RichText1.SelStart = ColorBlocks(0, m) + Len(stCodes(ColorBlocks(2, m)).Code)
            RichText1.SelLength = ColorBlocks(1, m) - RichText1.SelStart
            RichText1.SelColor = stCodes(ColorBlocks(2, m)).Value
            RichText1.SelStart = ColorBlocks(0, m)
            RichText1.SelLength = Len(stCodes(ColorBlocks(0, m)).Code)
            RichText1.SelText = ""   ' Remove code
        Next m
    End If        

---------------

I forgot to refer to the stCodes array by the values I had stored in the ColorBlocks array.  DOH!

Avatar of Randy T

ASKER

Okay we're getting some where, this is looking promising. Few bugs still.

This text should be normal
[his text should be red         <- Red (good) and missing "T", need the "T" not the "["
[his text should be blue        <- Blue (good) and missing "T", need the "T" not the "["
This text should be normal too  <- Blue, should be normal :)

And on this line:

RichText1.SelLength = Len(stCodes(ColorBlocks(0, m)).Code)

The 0 should be a 2 I think, had a subscript outta range, put the 2 and it worked. ;)
Avatar of Randy T

ASKER

Okay I solved the problem of the missing "T" and the "[", just need to stop that last line from being blue now. ;)
You're correct om the SelLength line.

Let's see....

Let's modify the code a bit:


    If UBound(ColorBlocks,2) > 0 Then ' there are codes to convert
        For m = UBound(ColorBlocks, 2) to 1 step -1
            Pos = InStr(ColorBlocks(0, m), strng, vbCrLf)
            If Pos > 0 And Pos < ColorBlocks(1, m) Then ColorBlocks(1, m) = Pos
            If UBound(ColorBlocks, 2) = m Then
               If ColorBlocks(1, m) < ColorBlocks(0, m) Then
                  ColorBlocks(1, m) = Len(strng)
               Else
                  If Len(strng) < ColorBlocks(1, m) Then
                     RichText1.SelStart = ColorBlocks(1, m) + 1
                     RichText1.SelLength = Len(strng) - RichText1.SelStart + 1
                     RichText1.SelColor = stCodes(ColorBlocks(2, 0)).Value ' set default
                  End If
              End If
            End If
            RichText1.SelStart = ColorBlocks(0, m) + Len(stCodes(ColorBlocks(2, m)).Code)
            RichText1.SelLength = ColorBlocks(1, m) - RichText1.SelStart
            RichText1.SelColor = stCodes(ColorBlocks(2, m)).Value
            RichText1.SelStart = ColorBlocks(0, m)
            RichText1.SelLength = Len(stCodes(ColorBlocks(0, m)).Code)
            RichText1.SelText = ""   ' Remove code
        Next m
    End If          
Avatar of Randy T

ASKER

This code works fine except for if the last line is normal it changes to a color if there is a colored line before it.

Here's what I am testing right now.

This text should be normal
This text should be red
This text should be normal
This text should be blue
This text should be normal too
This text should be magenta
This text should be normal

All lines are right on except for that last line, it's magenta. I've got everything else working except that. If you can stop that from turning magenta, then that's exactly what I want. :)
Avatar of Randy T

ASKER

Whoops. Forgot the code.

    If UBound(ColorBlocks, 2) > 0 Then ' there are codes to convert
        For m = UBound(ColorBlocks, 2) To 1 Step -1
            pos = InStr(ColorBlocks(0, m), strng, vbCrLf)
            If pos > 0 And pos < ColorBlocks(1, m) Then ColorBlocks(1, m) = pos
            If ColorBlocks(1, m) < ColorBlocks(0, m) Then ColorBlocks(1, m) = Len(strng)
            RichText1.SelStart = ColorBlocks(0, m) + Len(stCodes(ColorBlocks(2, m)).Code) - 1
            RichText1.SelLength = ColorBlocks(1, m) - RichText1.SelStart
            RichText1.SelColor = stCodes(ColorBlocks(2, m)).Value
            RichText1.SelStart = ColorBlocks(0, m) - 1
            RichText1.SelLength = Len(stCodes(ColorBlocks(2, m)).Code)
            RichText1.SelText = ""   ' Remove code
        Next m
    End If
ASKER CERTIFIED SOLUTION
Avatar of Brendt Hess
Brendt Hess
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Randy T

ASKER

Comment accepted as answer
Avatar of Randy T

ASKER

Thanks a ton. Now I have an even bigger problem that would be worth even more points, I'm gonna screw with it a bit using your code and see if I can get it to work if not I'll re-post the problem here and see if you can help. Thanks you've been of great help.
Avatar of Randy T

ASKER

Okay here's my bigger problem. I am trying to create a MUD Client that will, as the data arrives (via Winsock), will check for these codes, change the colors and then remove these codes. Basically like the code we just did, just on a bigger level.


Here's mt code:

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim code, buffer, strng, trig, temp As String
    Dim chru
    Dim m, n, X As Integer
    Dim isFound As Boolean
    Dim pos As Long
   
    Winsock1.GetData buffer, vbString
    isFound = False
    strng = ""
    For X = 1 To Len(buffer)
        chru = Mid(buffer, X, 1)
        If Asc(chru) = 13 Then
            RichTextBox1.Text = RichTextBox1.Text & strng & vbCrLf
            strng = RichTextBox1.Text
                For m = 1 To 34
                pos = InStr(strng, stCodes(m).stName)
                If pos > 0 Then
                   
                    RichTextBox1.SelStart = pos + Len(stCodes(m).stName)
                    RichTextBox1.SelLength = Len(strng)
                    RichTextBox1.SelColor = vbRed
                    RichTextBox1.SelStart = pos + Len(strng)
                    RichTextBox1.SelColor = vbBlack
                   
                    temp = Mid$(strng, 1, pos - 1)
                    temp = temp & Mid$(strng, pos + Len(stCodes(m).stName))
                    strng = temp
                    m = 0
                End If
                Next m
            RichTextBox1.Text = strng
           
            If hasFocus = True Then
                RichTextBox1.SelStart = Len(RichTextBox1.Text)
            Else
            End If
           
            If frmLogging.chkLog.Value = vbChecked Then
                If frmLogging.chkOverWrite.Value = vbChecked Then
                    Open frmLogging.Text1 For Output As #1
                    Print #1, strng
                    Close #1
                Else
                    Open frmLogging.Text1 For Append As #1
                    Print #1, strng
                    Close #1
                End If
            Else
            End If
           
            strng = ""
        ElseIf Asc(chru) < 31 Or Asc(chru) > 126 Then
        Else
            For m = 1 To 34
            pos = InStr(strng, stCodes(m).stName)
            If pos > 0 Then
                temp = Mid$(strng, 1, pos - 1)
                temp = temp & Mid$(strng, pos + Len(stCodes(m).stName))
                strng = temp
                m = 0
            Else
            End If
            Next m
           
            temp = ""
            strng = strng & chru
            trig = InStr(strng, frmTriggers.lstTrigger.List(n))
                       
            If isFound = False Then
                If trig > 0 Then
                    Winsock1.SendData frmTriggers.lstAction.List(n) & vbCrLf
                    isFound = True
                End If
            Else
            End If
        End If
    Next X

Ignore anything that looks useless. Basically all I need is for the code you just showed me, to work in this. I just needed to get something working to know it was possible to do (which you have showed me). Now the problem with this is...this.

    stCodes(1).stName = "[37;40;0m"
    stCodes(2).stName = "[0m"
    stCodes(3).stName = "[1m"
    stCodes(4).stName = "[2m"
    stCodes(5).stName = "[3m"
    stCodes(6).stName = "[4m"
    stCodes(7).stName = "[5m"
    stCodes(8).stName = "[6m"
    stCodes(9).stName = "[7m"
    stCodes(10).stName = "[1;30m"
    stCodes(11).stName = "[1;31m"
    stCodes(12).stName = "[1;32m"
    stCodes(13).stName = "[1;33m"
    stCodes(14).stName = "[1;34m"
    stCodes(15).stName = "[1;35m"
    stCodes(16).stName = "[1;36m"
    stCodes(17).stName = "[1;37m"
    stCodes(18).stName = "[30m"
    stCodes(19).stName = "[31m"
    stCodes(20).stName = "[32m"
    stCodes(21).stName = "[33m"
    stCodes(22).stName = "[34m"
    stCodes(23).stName = "[35m"
    stCodes(24).stName = "[36m"
    stCodes(25).stName = "[37m"
    stCodes(26).stName = "[40m"
    stCodes(27).stName = "[41m"
    stCodes(28).stName = "[42m"
    stCodes(29).stName = "[43m"
    stCodes(30).stName = "[44m"
    stCodes(31).stName = "[45m"
    stCodes(32).stName = "[46m"
    stCodes(33).stName = "[47m"
    stCodes(34).stName = "[1;7m"

These are all the codes that come in from the place I'm connecting to. (Probably more I've missed). If you think you can help me, I would gladly give you tons of points if I can get this working properly. :)

Thanks again.
Yep, I could probably do that.

You'll need to define what each of the codes do, though.  It's been a long time since I worked with the ANSI codes.

Start by building that 2-dimensional strCodes array.  If there is anything that is other than a color code, you'll need a three dimensional array:  

Type CodeList
   Code as String
   FunctionType as Integer
   Info as Long
End Type

Const typColorCode = 0
Const typFontBold = 1
Const typFontBlink = 2
.... etc ...
Avatar of Randy T

ASKER

Okay, I'm not worried about blinking. Only things I'm worried about are Bolded Colors and Normal Colors.

I don't really need the background ones, those are the "[4#m" ones. I only really need the ones with the bold and normal foreground colors.

And this one, "[37;40;0m" this one is important, I think it changes the color back to normal.

Okay, I've got a few references to the ANSI sequences.  Now, unless I'm mistaken, the data coming in will also have an Escape [Chr(27)] in front of the '['.  These should also be included in the comparison, don't you think?

So, let's do some simple, quick coding.

The basic structure of the sequences is:

{ESC}[#(;#;#)m

That is, Escape, Bracket, one or more Numbers separated by semicolons, and a lowercase 'm'.

Our parsing routine should take the information, and look for the {Esc}[ (or, if the {Esc} code is already filtered out, then just look for '[')

Here's what I have for attributes:

            <TABLE BORDER="1" CELLSPACING="1" CELLPADDING="6">
            <TR ALIGN="center">
                  <TD COLSPAN="2"><U>Attribute</U></TD><TD><U>Color</U></TD><TD><U>(Foreground)</U></TD><TD><U>(Background)</U></TD>
            </TR>
            <TR>
                  <TD>None</TD><TD>0</TD><TD>Black</TD><TD>30</TD><TD>40</TD>
            </TR>
            <TR>
                  <TD>High Intensity</TD><TD>1</TD><TD>Red</TD><TD>31</TD><TD>41</TD>
            </TR>
            <TR>
                  <TD>Underline</TD><TD>4</TD><TD>Green</TD><TD>32</TD><TD>42</TD>
            </TR>
            <TR>
                  <TD>Blink</TD><TD>5</TD><TD>Yellow</TD><TD>33</TD><TD>43</TD>
            </TR>
            <TR>
                  <TD>Reverse</TD><TD>7</TD><TD>Blue</TD><TD>34</TD><TD>44</TD>
            </TR>
            <TR>
                  <TD>Invisible</TD><TD>8</TD><TD>Magenta</TD><TD>35</TD><TD>45</TD>
            </TR>
            <TR>
                  <TD><BR></TD><TD><BR></TD><TD>Cyan</TD><TD>36</TD><TD>46</TD>
            </TR>
            <TR>
                  <TD><BR></TD><TD><BR></TD><TD>White</TD><TD>37</TD><TD>47</TD>
            </TR>
            </TABLE>
Let's try the attributes again, without HTML:

Attribute          Color   (Foreground)   (Background)
None        0      Black              30              40
High Intensity 1   Red                31              41
Underline      4   Green              32              42
Blink          5   Yellow             33              43
Reverse        7   Blue               34              44
Invisible      8   Magenta            35              45
                   Cyan               36              46
                   White              37              47


I don't have definitions for the other codes.

--------------------

Here's a try at the coding.  Let's see what we can do:

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim code, buffer, strng, trig, temp As String
    Dim chru
    Dim EscWait as Boolean
    Dim CodeBuild as Boolean
    Dim CodeHold as String
    Dim m, n, X As Integer
    Dim isFound As Boolean
    Dim pos As Long
     
    Winsock1.GetData buffer, vbString
    isFound = False
    strng = "" 
    For X = 1 To Len(buffer)
      chru = Mid(buffer, X, 1)
SkipCodeBuild:
      If CodeBuild Then
        CodeHold = CodeHold & chru
        If chru = "m" Then
           ' Parse codes here
           CodeBuild = False
           CodeHold = ""
           chru = Chr(1)  ' Set to ignored code
        ElseIf Not(IsNumeric(chru) OR (chru = ";") Then  ' Not valid ANSI sequence
           CodeBuild = False  ' Invalid code - do not parse
           strng = strng & Left(CodeHold, Len(CodeHold) - 1)
           CodeBuild = ""
           Goto SkipCodeBuild
         End If
      End If
      If Asc(chru) = 27 Then
        EscWait = True
      Else
        If Asc(chru) = 13 Then
            RichTextBox1.Text = RichTextBox1.Text & strng & vbCrLf
            strng = RichTextBox1.Text
                For m = 1 To 34
                pos = InStr(strng, stCodes(m).stName)
                If pos > 0 Then
                   
                    RichTextBox1.SelStart = pos + Len(stCodes(m).stName)
                    RichTextBox1.SelLength = Len(strng)
                    RichTextBox1.SelColor = vbRed
                    RichTextBox1.SelStart = pos + Len(strng)
                    RichTextBox1.SelColor = vbBlack
                     
                    temp = Mid$(strng, 1, pos - 1)
                    temp = temp & Mid$(strng, pos + Len(stCodes(m).stName))
                    strng = temp
                    m = 0
                End If
                Next m
            RichTextBox1.Text = strng
             
            If hasFocus = True Then
                RichTextBox1.SelStart = Len(RichTextBox1.Text)
            Else
            End If
             
            If frmLogging.chkLog.Value = vbChecked Then
                If frmLogging.chkOverWrite.Value = vbChecked Then
                    Open frmLogging.Text1 For Output As #1
                    Print #1, strng
                    Close #1
                Else
                    Open frmLogging.Text1 For Append As #1
                    Print #1, strng
                    Close #1
                End If
            Else
            End If
             
            strng = "" 
        ElseIf Asc(chru) < 31 Or Asc(chru) > 126 Then
        Else
          If EscWait Then
            If chru = "[" Then
            For m = 1 To 34
            pos = InStr(strng, stCodes(m).stName)
            If pos > 0 Then
                temp = Mid$(strng, 1, pos - 1)
                temp = temp & Mid$(strng, pos + Len(stCodes(m).stName))
                strng = temp
                m = 0
            Else
            End If
            Next m
             
            temp = "" 
            strng = strng & chru
            trig = InStr(strng, frmTriggers.lstTrigger.List(n))
                         
            If isFound = False Then
                If trig > 0 Then
                    Winsock1.SendData frmTriggers.lstAction.List(n) & vbCrLf
                    isFound = True
                End If
            Else
            End If
        End If
        EscWait = False
     End If
    Next X

---------------

Now, all we have to do is write the parse code.  Next block
Oops - forgot a section of code:


        Else
          If EscWait Then
            If chru = "[" Then
              CodeBuild = True
              CodeHold = chru
            Else
              temp = "" 
              strng = strng & chru
              trig = InStr(strng, frmTriggers.lstTrigger.List(n))
                         
              If isFound = False Then
                If trig > 0 Then
                    Winsock1.SendData frmTriggers.lstAction.List(n) & vbCrLf
                    isFound = True
                End If
              Else
              End If
            End If
         End If
Now, if you'll indicate which codes you want to use, we can code the parsing.
Avatar of Randy T

ASKER

Sorry, work was over there. Uhm, one problem with the code so far. Next without For, I probably have it in the wrong spot where should I place that second block of code?
Avatar of Randy T

ASKER

For now, let's just use these codes:

"[37;40;0m" - White on Black Background, normal
"[0m" - Black
"[1m" - Red
"[2m" - Green
"[3m" - Yellow
"[4m" - Blue
"[5m" - Magenta
"[6m" - Cyan
"[7m" - White
"[30m" - Foreground Black
"[31m" - Foreground Red
"[32m" - Foreground Green
"[33m" - Foreground Yellow
"[34m" - Foreground Blue
"[35m" - Foreground Magenta
"[36m" - Foreground Cyan
"[37m" - Foreground White

I don't know the difference between "[0m" and "[30m", "[1m" and "[31m", etc. They seem the same to me. But both of them are used in the MUD so if we could get those to work it would be an excellent start.
Avatar of Randy T

ASKER

Okay I have an idea, it's not really mine I got it off another PAQ. How would I do it if I were to send the information coming in to another RichTextBox that would use the previous code (we used to test the color changes) to convert the colors and remove the ansi codes, then send the newly colored/codeless text back to the other RTB?

If this is confusing I can try and explain it better.
Avatar of Randy T

ASKER

Ok change of plans.

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim buffer As String
    Dim chru
    Dim x As Integer
    Dim strng As String
    Dim pos As Long
    Dim ColorBlocks() As Long
    Dim m As Integer
    Dim cCt As Integer
     
    Winsock1.GetData buffer, vbString
    strng = ""
    For x = 1 To Len(buffer)
        chru = Mid(buffer, x, 1)
        If Asc(chru) = 13 Then
            RichTextBox1.Text = RichTextBox1.Text & strng & vbCrLf
            RichTextBox1.SelStart = Len(RichTextBox1.Text)
            strng = ""
        ElseIf Asc(chru) < 31 Or Asc(chru) > 126 Then
        Else
            strng = strng & chru
        End If
    Next x

    strng = RichTextBox1.Text
    ReDim ColorBlocks(0 To 2, 0 To 0)
    cCt = 0
    pos = InStr(pos + 1, strng, "[")
    Do While pos > 0
        For m = 1 To UBound(stCodes)
            If Mid(strng, pos, Len(stCodes(m).stName)) = stCodes(m).stName Then
                cCt = cCt + 1
                ReDim Preserve ColorBlocks(0 To 2, 0 To cCt)
                ColorBlocks(0, cCt) = pos   ' save start pos of color
                ColorBlocks(1, cCt - 1) = pos   ' Max pos of previous color
                ColorBlocks(2, cCt) = m  ' Save reference to block color
                ColorBlocks(1, cCt) = Len(strng)    ' Default to end of string
                Exit For    ' No more - found one
            End If
        Next m
        If pos = Len(strng) Then Exit Do
        pos = InStr(pos + 1, strng, "[")
    Loop

' check for vbCrLf to see if terminated earlier than next code
    If UBound(ColorBlocks, 2) > 0 Then ' there are codes to convert
        For m = UBound(ColorBlocks, 2) To 1 Step -1
            pos = InStr(ColorBlocks(0, m), strng, vbCrLf)
            If pos > 0 And pos < ColorBlocks(1, m) Then ColorBlocks(1, m) = pos
            RichTextBox1.SelStart = ColorBlocks(0, m) + Len(stCodes(ColorBlocks(2, m)).stName) - 1
            RichTextBox1.SelLength = ColorBlocks(1, m) - RichTextBox1.SelStart
            RichTextBox1.SelColor = stCodes(ColorBlocks(2, m)).stColor
            RichTextBox1.SelStart = ColorBlocks(0, m) - 1
            RichTextBox1.SelLength = Len(stCodes(ColorBlocks(2, m)).stName)
            RichTextBox1.SelText = ""   ' Remove code
        Next m
    End If
End Sub


This "almost" works. It changes the colors perfectly, only one teensy problem. The colors are gone once new data arrives. If you could help me to get it to stay, using the code above, there'd be lots of points in it for you. :)
Try this block of code - it should work.

Note:  If you use SelStart, SelColor, and SelText, then additions to the RTBox will be in the last color specified.  As an example, this code will add multicolored code to an RTBox named RT1:

RT1.SelColor = QBColor(0)
RT1 = "This is a "
RT1.SelStart = Len(RT1.Text)
RT1.SelColor = QBColor(4)
RT1.SelText = "Test "
RT1.SelStart = Len(RT1.Text)
RT1.SelColor = QBColor(2)
RT1.SelText = "Of Multicolor text"


-------------------------
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim code, buffer, strng, trig, temp As String
    Dim chru
    Dim EscWait as Boolean
    Dim CodeBuild as Boolean
    Dim CodeHold as String
    Dim m, n, X As Integer
    Dim isFound As Boolean
    Dim pos As Long
     
    Winsock1.GetData buffer, vbString
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
    isFound = False
    strng = "" 
    For X = 1 To Len(buffer)
        chru = Mid(buffer, X, 1)
SkipCodeBuild:
        If CodeBuild Then
            CodeHold = CodeHold & chru
            If chru = "m" Then
               ' Parse codes here
               SetColor(RichTextBox1, CodeHold)
               CodeBuild = False
               CodeHold = "" 
               chru = Chr(1)  ' Set to ignored code
            ElseIf Not(IsNumeric(chru) OR (chru = ";") Then  ' Not valid ANSI sequence
               CodeBuild = False  ' Invalid code - do not parse
               strng = strng & Left(CodeHold, Len(CodeHold) - 1)
               CodeBuild = "" 
               Goto SkipCodeBuild
            End If
        End If
        If Asc(chru) = 27 Then
            EscWait = True
        Else
            If Asc(chru) = 13 Then
                If CodeBuild Then CodeBuild = False
                RichTextBox1.SelText = strng & vbCrLf
                RichTextBox1.SelStart = Len(RichTextBox1.Text)
                RichTextBox1.SelColor = QBColor(7) ' white text by default
             
                If hasFocus = True Then
                    RichTextBox1.SelStart = Len(RichTextBox1.Text)
                Else
                End If
             
                If frmLogging.chkLog.Value = vbChecked Then
                    If frmLogging.chkOverWrite.Value = vbChecked Then
                        Open frmLogging.Text1 For Output As #1
                        Print #1, strng
                        Close #1
                    Else
                        Open frmLogging.Text1 For Append As #1
                        Print #1, strng
                        Close #1
                    End If
                Else
                End If
             
                strng = "" 
            ElseIf Asc(chru) < 31 Or Asc(chru) > 126 Then ' ignore it

            Else
              If EscWait Then
                If chru = "[" Then
                  CodeBuild = True
                  CodeHold = chru
                  RichTextBox1.SelText = strng
                  RichTextBox1.SelStart = Len(RichTextBox1.Text)
                End If
              End If
              If Not CodeBuild Then
                  strng = strng & chru

                  If isFound = False Then
                    trig = InStr(strng, frmTriggers.lstTrigger.List(n))
                    If trig > 0 Then
                        Winsock1.SendData frmTriggers.lstAction.List(n) & vbCrLf
                        isFound = True
                    End If
                  Else
                  End If
               End If
            End If
         End If
         EscWait = False
    Next X


Sub SetColor(Rtb as RichTextBox, CC as String)

Dim I as Integer
For I = 1 to ubound(stCodes)
   If stCodes(I).Code = CC Then
       RTB.SelStart = Len(RTB.Text)
       RTB.SelColor = stCodes(I).Color
       Exit For
   End If
Next I

Exit Sub
---------------------

Codes that are not in your list of valid codes will be ignored and removed from the text stream
Oops - I had the page up too long.  Missed your rewrite.  One moment....
This should do what you need.  As long as SelStart / SelText is used, you can work with it.  Also, only process the new additions.  Note:  My previous code should also work, after debugging....

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim buffer As String
    Dim chru
    Dim x As Integer
    Dim strng As String
    Dim pos As Long
    Dim ColorBlocks() As Long
    Dim m As Integer
    Dim cCt As Integer
    Dim tStart as Long
     
    Winsock1.GetData buffer, vbString
    strng = "" 
    tStart = Len(RichTextBox1.Text)
    RichTextBox1.SelStart = tStart
    For x = 1 To Len(buffer)
        chru = Mid(buffer, x, 1)
        If Asc(chru) = 13 Then
          RichTextBox1.SelText = strng & vbCrLf
            RichTextBox1.SelStart = Len(RichTextBox1.Text)
            RichTextBox1.SelColor = QBColor(7) ' white text by default
        ElseIf Asc(chru) < 31 Or Asc(chru) > 126 Then
        Else
            strng = strng & chru
        End If
    Next x

    RichTextBox1.SelStart = tStart
    RichTextBox1.SelLength = Len(RichTextBox1.Text) - tStart + 1
    strng = RichTextBox1.SelText
    ReDim ColorBlocks(0 To 2, 0 To 0)
    cCt = 0
    pos = InStr(pos + 1, strng, "[")
    Do While pos > 0
        For m = 1 To UBound(stCodes)
            If Mid(strng, pos, Len(stCodes(m).stName)) = stCodes(m).stName Then
                cCt = cCt + 1
                ReDim Preserve ColorBlocks(0 To 2, 0 To cCt)
                ColorBlocks(0, cCt) = pos   ' save start pos of color
                ColorBlocks(1, cCt - 1) = pos   ' Max pos of previous color
                ColorBlocks(2, cCt) = m  ' Save reference to block color
                ColorBlocks(1, cCt) = Len(strng)    ' Default to end of string
                Exit For    ' No more - found one
            End If
        Next m
        If pos = Len(strng) Then Exit Do
        pos = InStr(pos + 1, strng, "[")
    Loop

' check for vbCrLf to see if terminated earlier than next code
    If UBound(ColorBlocks, 2) > 0 Then ' there are codes to convert
        For m = UBound(ColorBlocks, 2) To 1 Step -1
            pos = InStr(ColorBlocks(0, m) + tStart, strng, vbCrLf)
            If pos > 0 And pos < ColorBlocks(1, m) + tStart Then ColorBlocks(1, m) = pos - tStart
            RichTextBox1.SelStart = ColorBlocks(0, m) + Len(stCodes(ColorBlocks(2, m)).stName) - 1 + tStart
            RichTextBox1.SelLength = ColorBlocks(1, m) + tStart - RichTextBox1.SelStart
            RichTextBox1.SelColor = stCodes(ColorBlocks(2, m)).stColor
            RichTextBox1.SelStart = ColorBlocks(0, m) + tStart - 1
            RichTextBox1.SelLength = Len(stCodes(ColorBlocks(2, m)).stName)
            RichTextBox1.SelText = ""   ' Remove code
        Next m
    End If
End Sub


Avatar of Randy T

ASKER

Hehe, the second one went ballistic on me :) Sent a bunch of //// things and stuff. The first one didn't get rid of the codes or put the colours in. But I guess that's cuz of the 'Parse Code Here line? :)

I think that first one might work, how would I do it if I wanted to check for this code:

"[1;31m"

If it finds that code, turn the stuff red.

Man I feel like I'm really working you here. :)
okay - I faked up a test of this code, so it should work for you as well.  Let's see....

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim Code, buffer, strng, trig, temp As String
    Dim chru
    Dim EscWait As Boolean
    Dim CodeBuild As Boolean
    Dim CodeHold As String
    Dim m, n, X As Integer
    Dim isFound As Boolean
    Dim pos As Long

    Winsock1.GetData buffer, vbString
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
    isFound = False
    strng = ""
    For X = 1 To Len(buffer)
        chru = Mid(buffer, X, 1)
SkipCodeBuild:
        If CodeBuild Then
            CodeHold = CodeHold & chru
            If chru = "m" Then
               ' Parse codes here
               SetColor RichTextBox1, CodeHold
               CodeBuild = False
               CodeHold = ""
               chru = Chr(1)  ' Set to ignored code
            ElseIf Not (IsNumeric(chru) Or (chru = ";")) Then ' Not valid ANSI sequence
               CodeBuild = False  ' Invalid code - do not parse
               strng = strng & Left(CodeHold, Len(CodeHold) - 1)
               CodeBuild = ""
               GoTo SkipCodeBuild
            End If
        End If
        If Asc(chru) = 27 Then
            EscWait = True
        Else
            If Asc(chru) = 13 Then
                If CodeBuild Then CodeBuild = False
                RichTextBox1.SelText = strng & vbCrLf
                RichTextBox1.SelStart = Len(RichTextBox1.Text)
                RichTextBox1.SelColor = QBColor(7) ' white text by default
               
'                If hasFocus = True Then
'                    RichTextBox1.SelStart = Len(RichTextBox1.Text)
'                Else
'                End If
               
                If frmLogging.chkLog.Value = vbChecked Then
                    If frmLogging.chkOverWrite.Value = vbChecked Then
                        Open frmLogging.Text1 For Output As #1
                        Print #1, strng
                        Close #1
                    Else
                        Open frmLogging.Text1 For Append As #1
                        Print #1, strng
                                               
                        Close #1
                    End If
                Else
                End If
               
                strng = ""
            ElseIf Asc(chru) < 31 Or Asc(chru) > 126 Then ' ignore it

            Else
              If EscWait Then
                If chru = "[" Then
                  CodeBuild = True
                  CodeHold = chru
                  RichTextBox1.SelText = strng
                  RichTextBox1.SelStart = Len(RichTextBox1.Text)
                End If
              End If
              If Not CodeBuild Then
                  strng = strng & chru

                  If isFound = False Then
                    trig = InStr(strng, frmTriggers.lstTrigger.List(n))
                    If trig > 0 Then
                        Winsock1.SendData frmTriggers.lstAction.List(n) & vbCrLf
                        isFound = True
                    End If
                  Else
                  End If
               End If
            End If
            EscWait = False
         End If
    Next X
End Sub

Sub SetColor(Rtb As RichTextBox, CC As String)

Dim I As Integer
For I = 1 To UBound(stCodes)
   If stCodes(I).Code = CC Then
       Rtb.SelStart = Len(Rtb.Text)
       Rtb.SelColor = stCodes(I).Value
       Exit For
   End If
Next I

End Sub
Avatar of Randy T

ASKER

That is perfect man. I owe you. How many points do you want?

Is 1000 enough?
Avatar of Randy T

ASKER

Also curious, it works fine. But if it isn't too much trouble, how would I do this if I wanted the color to continue until it found the "[37,40,0m" code? If it's too much code manipulation, forget it this works fine enough.
Well, there's an alternate way to parse the codes.

Let's just isolate out the numeric values that will affect the colors that we are concerned about.  For example, "[3;40m" - we are only concerned about the 3 - we have decided to ignore the 40 (background color) code.

So, once we get the code, we have an alternate parsing routine, based on the QBColor function.

First, in Form_Load, build an array of 0-7 with the equivalent QBColor numbers:

Dim ColorValue(0 to 7)

' Note - for values 1 - 7, experiment with value + 8 for the Light version of the color

ColorValue(0) = 0  ' black
ColorValue(1) = 4  ' Red  (can use 12 - light red)
ColorValue(2) = 2  ' Green
ColorValue(3) = 6  ' Yellow
ColorValue(4) = 1  ' Blue
ColorValue(5) = 5  ' Magenta
ColorValue(6) = 3  ' Cyan
ColorValue(7) = 7  ' White

----------------------

Replace the previous SetColor routine with this one:

-------------------------

Sub SetColor(Rtb As RichTextBox, CC As String)

Dim I As Integer
Dim pos as Integer
Dim cd as Integer

' assumes that only values 0 to 7 and 30 to 37 are valid
' CC has a string of the format "[#(;#;#...)m
' We only need to handle the last color change

pos = Len(CC) - 1
For I = Len(CC)-1 to 1 Step -1
    If Not IsNumeric(Mid(CC,I,1)) Then ' must be ";" or "["
        cd = val(Mid(CC, I + 1, pos - I + 1))
        If cd >= 30 then cd = cd - 30  '(30 codes = 0 based codes)
        If (cd >= 0 AND cd < 8) Then  ' valid code
           Rtb.SelStart = Len(Rtb.Text)
           Rtb.SelColor = QBColor(ColorValue(cd))
           Exit For
        End If
     End If
Next I

End Sub
If you want it to continue, then you don't reset it at each vbCrLf insertion.  Comment out the line commented out below:


            If Asc(chru) = 13 Then
                If CodeBuild Then CodeBuild = False
                RichTextBox1.SelText = strng & vbCrLf
                RichTextBox1.SelStart = Len(RichTextBox1.Text)
' Comment out this line
'                RichTextBox1.SelColor = QBColor(7) ' white text by default
' comment out above line

As for points - you decide.  Don't deprive yourself for asking future questions.  (IMO, however, no more than 3 * Hard-Question should be given)

Have fun