Randy T
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
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
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
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
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
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
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)
ReDim Preserve ColorBlocks(0 To 2, 0 To cCt)
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.
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.
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
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!
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,
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,
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!
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. ;)
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,
The 0 should be a 2 I think, had a subscript outta range, put the 2 and it worked. ;)
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
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,
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,
RichText1.SelText = "" ' Remove code
Next m
End If
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. :)
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. :)
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
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,
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,
RichText1.SelText = "" ' Remove code
Next m
End If
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Comment accepted as answer
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.
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.Va lue = 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.Lis t(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.
Here's mt code:
Private Sub Winsock1_DataArrival(ByVal
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.Va
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.Lis
If isFound = False Then
If trig > 0 Then
Winsock1.SendData frmTriggers.lstAction.List
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 ...
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 ...
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.
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><T D><U>(Fore ground)</U ></TD><TD> <U>(Backgr ound)</U>< /TD>
</TR>
<TR>
<TD>None</TD><TD>0</TD><TD >Black</TD ><TD>30</T D><TD>40</ TD>
</TR>
<TR>
<TD>High Intensity</TD><TD>1</TD><T D>Red</TD> <TD>31</TD ><TD>41</T D>
</TR>
<TR>
<TD>Underline</TD><TD>4</T D><TD>Gree n</TD><TD> 32</TD><TD >42</TD>
</TR>
<TR>
<TD>Blink</TD><TD>5</TD><T D>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</T D><TD>Mage nta</TD><T D>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>4 7</TD>
</TR>
</TABLE>
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</
</TR>
<TR>
<TD>None</TD><TD>0</TD><TD
</TR>
<TR>
<TD>High Intensity</TD><TD>1</TD><T
</TR>
<TR>
<TD>Underline</TD><TD>4</T
</TR>
<TR>
<TD>Blink</TD><TD>5</TD><T
</TR>
<TR>
<TD>Reverse</TD><TD>7</TD>
</TR>
<TR>
<TD>Invisible</TD><TD>8</T
</TR>
<TR>
<TD><BR></TD><TD><BR></TD>
</TR>
<TR>
<TD><BR></TD><TD><BR></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.Va lue = 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.Lis t(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
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
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.Va
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.Lis
If isFound = False Then
If trig > 0 Then
Winsock1.SendData frmTriggers.lstAction.List
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.Lis t(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
Else
If EscWait Then
If chru = "[" Then
CodeBuild = True
CodeHold = chru
Else
temp = ""
strng = strng & chru
trig = InStr(strng, frmTriggers.lstTrigger.Lis
If isFound = False Then
If trig > 0 Then
Winsock1.SendData frmTriggers.lstAction.List
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.
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?
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.
"[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.
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.
If this is confusing I can try and explain it better.
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. :)
Private Sub Winsock1_DataArrival(ByVal
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,
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,
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.Va lue = 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.Lis t(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
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
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.Va
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.Lis
If trig > 0 Then
Winsock1.SendData frmTriggers.lstAction.List
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
Private Sub Winsock1_DataArrival(ByVal
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,
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,
RichTextBox1.SelText = "" ' Remove code
Next m
End If
End Sub
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. :)
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.Va lue = 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.Lis t(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
Private Sub Winsock1_DataArrival(ByVal
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.Va
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.Lis
If trig > 0 Then
Winsock1.SendData frmTriggers.lstAction.List
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
ASKER
That is perfect man. I owe you. How many points do you want?
Is 1000 enough?
Is 1000 enough?
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
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
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
---
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
---