Solved

Syntax Coloring

Posted on 1998-11-01
6
199 Views
Last Modified: 2010-04-30

 Below, you will find the method I have used in order
 to do Syntax Coloring (HTML).
 It does have a few problems.
 It only works when the RTF starts a New File,
 if you open a HTML document with it, all is loss,
 it fails to color the current text as well as any text
 the user inputs.
 ...
' Form1.rtfTextBox
Private Sub rtfTextBox_Change()
ColorMeHtml
End Sub
 ...
 ' In a Module

Public Sub ColorMeHtml()
' Small Portion of Code
    With Form1.rtfTextBox
        If Right$(.Text, 6) = "<html>" Then
            .SelStart = Len(.Text) - 6
            .SelLength = 6
            .SelColor = &H8000&
            .SelStart = Len(.Text)
        ElseIf Right$(.Text, 7) = "<title>" Then
            .SelStart = Len(.Text) - 7
            .SelLength = 7
            .SelColor = vbBlue
            .SelStart = Len(.Text)
        'ElseIf and it goes on...
       End If
    End With
End Sub

 Experts, here is my Question.
 With the above code, how can I continue to do
 Syntax Coloring when I open a files.
 
 OR for the same amount of points,
 A better Function to do Syntax coloring.
 Must work on Opened files as well as new ones.

 NOTE: Please do NOT post an example DL file that
 searches for start "<" and end ">" and colors what is in   between.
 This is not what I wish to do.
 
 Thank you.
0
Comment
Question by:s_mccolgan
  • 3
  • 2
6 Comments
 
LVL 1

Expert Comment

by:kponder
ID: 1442741

With Form1.rtfTextBox
  .LoadFile FileToLoad
  For i = 1 To Len(.Text)
    If Mid(.Text, i, 6) = "<html>" Then
      .SelStart = i -1
      .SelLength = 6
      .SelColor = &H8000&
    End If
'other tags go here
  Next
End With

I hope this is usefull.
0
 

Author Comment

by:s_mccolgan
ID: 1442742

No, NOT at all.
I want to Color Syntax as I type, my example seems to work only on new
files. Fails to color when a file has already been opened.
Remember lads, this is not to be used in your form_load event.
Add my code to a sample project, then start typeing... All ok?
Now clear what you have done and copy paste some HTML or open one.
Now type, all is lost, no color. This is what I want fixed. OR a better function
to do it all.
kponder, thank you for trying but maybe you didn't read the Q. right, or
hey, I hope the above has clarified it.



0
 
LVL 2

Accepted Solution

by:
mkmccreary earned 310 total points
ID: 1442743
I think I got it.  Check it out, all you have to do is add other select case clauses for different tags.


Private Sub Command1_Click()

Me.RichTextBox1.LoadFile "h:\experts exchange\html\test.htm"
ProcessRTF Me.RichTextBox1

End Sub

Public Function GetColor(ByVal sString As String) As Long
   
sString = LCase(sString)

Select Case sString
    Case "<html>"
        GetColor = &H8000&
    Case "<title>"
        GetColor = vbBlue
    Case Else
        GetColor = vbBlack
End Select

End Function

Function ProcessRTF(oRTFBox As RichTextBox) As Boolean

Dim lStartPos As Long
Dim lRightEndPos As Long
Dim lLeftStartPos As Long
Dim sText As String

sText = oRTFBox.Text

lStartPos = InStr(sText, "<")
While lStartPos <> 0
    lRightEndPos = InStr(lStartPos + 1, sText, ">")
    lLeftStartPos = InStr(lStartPos + 1, sText, "<")
    If lRightEndPos > 0 Then
        If lLeftStartPos > 0 Then
            If lLeftStartPos > lRightEndPos Then
                lRightEndPos = lRightEndPos + 1
                oRTFBox.SelStart = lStartPos - 1
                oRTFBox.SelLength = lRightEndPos - lStartPos
                oRTFBox.SelColor = GetColor(Mid$(sText, lStartPos, lRightEndPos - lStartPos))
            End If
        Else
            lRightEndPos = lRightEndPos + 1
            oRTFBox.SelStart = lStartPos - 1
            oRTFBox.SelLength = lRightEndPos - lStartPos
            oRTFBox.SelColor = GetColor(Mid$(sText, lStartPos, lRightEndPos - lStartPos))
        End If
    End If
    lStartPos = InStr(lStartPos + 1, sText, "<")
Wend
oRTFBox.SelStart = Len(sText)
oRTFBox.SelLength = 0
oRTFBox.SelColor = vbBlack
oRTFBox.SetFocus

End Function

Private Sub RichTextBox1_KeyPress(KeyAscii As Integer)
Dim lStartPos As Long
Dim lEndPos As Long
Dim sCharToCheck As String
Dim boolContinue As Boolean
Dim sText As String

Select Case Chr$(KeyAscii)
    Case ">"
        Me.RichTextBox1.SelText = ">"
        lEndPos = Me.RichTextBox1.SelStart
        lStartPos = lEndPos - 1
        boolContinue = True
        While lStartPos > 0 And boolContinue
            sCharToCheck = Mid$(Me.RichTextBox1.Text, lStartPos, 1)
            Select Case sCharToCheck
                Case "<"
                    boolContinue = False
                Case ">"
                    lStartPos = 0
                    boolContinue = False
                Case Else
                    lStartPos = lStartPos - 1
            End Select
        Wend
        If lStartPos > 0 Then
            lEndPos = lEndPos + 1
            Me.RichTextBox1.SelStart = lStartPos - 1
            Me.RichTextBox1.SelLength = lEndPos - lStartPos
            sText = Me.RichTextBox1.SelText
            Me.RichTextBox1.SelColor = GetColor(sText)
            Me.RichTextBox1.SelStart = lEndPos - 1
            Me.RichTextBox1.SelColor = vbBlack
        End If
        KeyAscii = 0
    Case Else
        ' Do Nothing
End Select

End Sub

I have a command button to load and process the initial file, and something under the keypress event.

Enjoy,
Martin
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 2

Expert Comment

by:mkmccreary
ID: 1442744
An improved version:


Public Function GetColor(ByVal sString As String) As Long
   
sString = LCase(sString)

Select Case sString
    Case "<html>"
        GetColor = &H8000&
    Case "<title>"
        GetColor = vbBlue
    Case "<error>"
        GetColor = vbRed
    Case Else
        GetColor = vbBlack
End Select

End Function

Private Sub RichTextBox1_KeyPress(KeyAscii As Integer)

Dim lStartPos As Long
Dim lEndPos As Long
Dim sUChar As String

Select Case KeyAscii
    Case 8
        'Backspace Key
        lStartPos = Me.RichTextBox1.SelStart + 1
        lEndPos = InStr(lStartPos + 1, Me.RichTextBox1.Text, ">")
        If lEndPos > 0 Then
            SetTextColor Me.RichTextBox1, lStartPos, lEndPos
        End If
        Me.RichTextBox1.SelStart = lStartPos - 1
    Case 60
        ' < character
        lStartPos = Me.RichTextBox1.SelStart + 1
        Me.RichTextBox1.SelText = Chr$(KeyAscii)
        lEndPos = InStr(lStartPos + 1, Me.RichTextBox1.Text, ">")
        If lEndPos > 0 Then
            SetTextColor Me.RichTextBox1, lStartPos, lEndPos
        End If
        KeyAscii = 0
        Me.RichTextBox1.SelStart = lStartPos
    Case 32 To 126
        Me.RichTextBox1.SelText = Chr$(KeyAscii)
        lEndPos = Me.RichTextBox1.SelStart
        lStartPos = GetStartPos(Left$(Me.RichTextBox1.Text, lEndPos - 1))
        If lStartPos > 0 Then
            SetTextColor Me.RichTextBox1, lStartPos, lEndPos
        End If
        KeyAscii = 0
    Case Else
        ' Do Nothing
End Select

End Sub

Function GetStartPos(ByVal sString As String) As Long
   
Dim boolContinue As Boolean
Dim lStartPos As Long
Dim sCharToCheck As String

    lStartPos = Len(sString)
    boolContinue = True
   
    While lStartPos > 0 And boolContinue
        sCharToCheck = Mid$(sString, lStartPos, 1)
        Select Case sCharToCheck
            Case "<"
                boolContinue = False
            Case ">"
                lStartPos = 0
                boolContinue = False
            Case Else
                lStartPos = lStartPos - 1
        End Select
    Wend
   
    GetStartPos = lStartPos
End Function

Function SetTextColor(oRTF As RichTextBox, ByVal StartPos As Long, ByVal EndPos As Long) As Boolean

Dim sText As String

    EndPos = EndPos + 1
    oRTF.SelStart = StartPos - 1
    oRTF.SelLength = EndPos - StartPos
    sText = oRTF.SelText
    oRTF.SelColor = GetColor(sText)
    oRTF.SelStart = EndPos - 1
    oRTF.SelColor = vbBlack

    SetTextColor = True
   
End Function


I think this version works a little better.  Check it out.

Later,
Martin
0
 

Author Comment

by:s_mccolgan
ID: 1442745

Could you please tell me why your newer version is better?
What have you done that makes it better?

Thank you
0
 
LVL 2

Expert Comment

by:mkmccreary
ID: 1442746
The older version works great when you are just typing along, but if you backtrack and change something it doesn't work correctly.  Say you use the arrow keys to go back and change a tag so it is spelled correctly, I don't think the older verion will fix it.  The file processing of the old version doesn't work quite right, and I haven't been able to figure out why.

Have Fun,
Martin
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now