Keskustelu: Koodit: VB6: HTML koodin värikoodaus

' HTML_TagColoring moduuli versio 1.00 (13.7.2002)
'
' (c) Tero Pietilä  http://www.trinit.tk
'
'
' HTML_TagColoring moduuli on tarkoitettu HTML koodin värjäykseen
' jossa tagit, tagien määrittelyt, erikoismerkit ja kommenttirivit
' värjätään omilla väreillään. Funktio ei ota huomioon <SCRIPT></script>
' tageja, joten skriptit värjäytyvät HTML värikoodauksen mukaan

Public colTAG As Long
Public colDEF As Long
Public colTEXT As Long
Public colENTITY As Long
Public colCOMMENT As Long


Public Function ColorTAGS(ctrl As Control) As String
' Funktiolle annetaan kaksi parametriä: strTextToColor sekä ctrl
'
' - strTextToColor sisältää merkkijonon josta etsitään värjättäviä kohteita
' - ctrl on viittaus siihen tekstikenttään jossa värjättävä teksti sijaitsee
'
' Esimerkki funktion käytöstä:
'
'   ColorTags RichTextBox1
'
' jossa RichTextBox1 tarkoittaa tekstikentän kooditason nimeä. Esimerkissä 1
' on annettu värjättäväksi tekstiksi tekstikentän kaikki tekstit.
'
' HUOM! funktion käyttämät komennot joilla vaihdetaan tekstin väriä
'       toimivat ainoastaan RichTextBox -kontrollilla!


    colTAG = RGB(0, 0, 255)                ' Tagien väri
    colDEF = RGB(0, 128, 128)              ' Määrittelyn (definition) väri
    colTEXT = RGB(0, 0, 0)                 ' Muun tekstin väri
    colENTITY = RGB(255, 0, 0)             ' Erikoismerkkien väri
    colCOMMENT = RGB(128, 128, 128)        ' Kommenttien väri


    Dim TAG_StartPos As Long
    Dim TAG_EndPos As Long
    Dim TAG_Length As Long
    Dim ReadPos As Long
    Dim CursorPos As Long

    Dim tmp1 As Long
    Dim tmp2 As Long
    Dim tmp3 As Long

    TAG_StartPos = 0
    TAG_EndPos = -1
    TAG_Length = -1
    ReadPos = 1

    tmp1 = -1
    tmp2 = -1
    tmp3 = -1

    strTextToColor = ctrl.Text          ' Luetaan kontrollin kaikki tekstit muistiin
    CursorPos = ctrl.SelStart           ' Otetaan talteen kursorin sijainti

    ctrl.Visible = False

    ' Värjätään kaikki < ja > merkkien välissä olevat
    ' tekstit colTAG värillä
    Do

        TAG_StartPos = InStr(ReadPos, strTextToColor, "<"): ReadPos = TAG_StartPos

        If TAG_StartPos > 0 Then

            TAG_EndPos = InStr(ReadPos, strTextToColor, ">"): ReadPos = TAG_EndPos
            TAG_Length = TAG_EndPos - TAG_StartPos + 1

            If TAG_Length > 0 Then
                ctrl.SelStart = TAG_StartPos - 1
                ctrl.SelLength = TAG_Length
                ctrl.SelColor = colTAG
                ctrl.SelLength = 0
                ctrl.SelStart = CursorPos
            End If

        End If

    Loop Until ReadPos <= 0

    TAG_StartPos = 0
    TAG_EndPos = -1
    TAG_Length = -1
    ReadPos = 1

    ' Värjätään kaikki <!-- ja --> merkkien välissä olevat
    ' tekstit colCOMMENT värillä
    Do

        TAG_StartPos = InStr(ReadPos, strTextToColor, "<!--"): ReadPos = TAG_StartPos

        If TAG_StartPos > 0 Then

            TAG_EndPos = InStr(ReadPos, strTextToColor, "-->"): ReadPos = TAG_EndPos
            TAG_Length = TAG_EndPos - TAG_StartPos + 3

            If TAG_Length > 0 Then
                ctrl.SelStart = TAG_StartPos - 1
                ctrl.SelLength = TAG_Length
                ctrl.SelColor = colCOMMENT
                ctrl.SelLength = 0
                ctrl.SelStart = CursorPos
            End If

        End If

    Loop Until ReadPos <= 0

    TAG_StartPos = 0
    TAG_EndPos = -1
    TAG_Length = -1
    ReadPos = 1

    ' Värjätään tagien määrittelyosat colDEF värillä
    Do

        TAG_StartPos = InStr(ReadPos, strTextToColor, "="): ReadPos = TAG_StartPos

        If TAG_StartPos > 0 Then

            tmp1 = InStr(ReadPos, strTextToColor, " ")
            tmp2 = InStr(ReadPos, strTextToColor, Chr$(34))
            tmp3 = InStr(ReadPos, strTextToColor, ">")


            If tmp2 > 0 And tmp2 < tmp3 Then
                ' Jos määrittely on suljettu lainausmerkkien sisään
                TAG_EndPos = InStr(tmp2 + 1, strTextToColor, Chr$(34)): ReadPos = TAG_EndPos
            Else
                ' Määrittelyä ei ole suljettu lainausmerkkien sisään

                If tmp1 < tmp3 Then
                    TAG_EndPos = tmp1: ReadPos = TAG_EndPos
                Else
                    TAG_EndPos = tmp3 - 1: ReadPos = TAG_EndPos
                End If

            End If

            TAG_Length = TAG_EndPos - TAG_StartPos + 1

            If TAG_Length > 0 Then
                ctrl.SelStart = TAG_StartPos - 1
                ctrl.SelLength = TAG_Length

                ' Värjätään vain jos rivi ei ole kommentissa
                If ctrl.SelColor <> colCOMMENT Then
                    ctrl.SelColor = colDEF
                End If

                ctrl.SelLength = 0
                ctrl.SelStart = CursorPos
            End If

        End If

    Loop Until ReadPos <= 0

    TAG_StartPos = 0
    TAG_EndPos = -1
    TAG_Length = -1
    ReadPos = 1


    ' Värjätään kaikki erikoismerkit colENTITY värillä
    Do

        TAG_StartPos = InStr(ReadPos, strTextToColor, "&"): ReadPos = TAG_StartPos

        If TAG_StartPos > 0 Then

            TAG_EndPos = InStr(ReadPos, strTextToColor, ";"): ReadPos = TAG_EndPos
            TAG_Length = TAG_EndPos - TAG_StartPos + 1

            If TAG_Length > 0 Then
                ctrl.SelStart = TAG_StartPos - 1
                ctrl.SelLength = TAG_Length

                ' Värjätään vain jos rivi ei ole kommentissa
                If ctrl.SelColor <> colCOMMENT Then
                    ctrl.SelColor = colENTITY
                End If

                ctrl.SelLength = 0
                ctrl.SelStart = CursorPos
            End If

        End If

    Loop Until ReadPos <= 0

    ctrl.Visible = True

End Function

Private Sub Form_Load()

    rtBox.RightMargin = 65535

    cd.Filter = "HTML tiedostot (*.html *.htm)|*.html;*.htm|Kaikki tiedostot (*.*)|*.*"
    cd.ShowOpen

    rtBox.FileName = cd.FileName

End Sub

Private Sub Form_Resize()

    If Me.WindowState <> 1 Then
        With rtBox
            .Left = 0
            .Top = 0
            .Width = Me.ScaleWidth
            .Height = Me.ScaleHeight
        End With
    End If

End Sub

Private Sub rtBox_Click()

    Dim ctrl As Control     ' Luodaan uusi muuttuja viittaamaan kontrolliin
    Set ctrl = rtBox

    ColorTAGS ctrl

End Sub