Fremhævvelse af udvalgte ord i text editor!

Oki... Det var måske et lidt tyndt svar, overhovedt ikke gennemarbejdet!!!

Så nu får du det HELE!!!

Dette skal stå i (general declarations)

Public Declare Function LockWindowUpdate Lib "user32" (ByVal hWnd As Long) As Long
Dim ColorColl As Collection

Dette er så functionerne og subs'ne

Public Sub HighLightSelection(mForm As Form, mRTF As RichTextBox, mHighLightColor As Long, Optional DontLock As Boolean)
    
    'This is trickier than the other Highlight functions because
    'we have to allow for existing highlighting in various colors
    Dim TempRTF As String
    Dim SelStart As Long
    Dim SelEnd As Long
    Dim SelectedText As String
    Dim BeforeHL As String
    Dim AfterHL As String
    Dim FirstSelHL As String
    Dim LastSelHL As String
    Dim StartReplaceHL As String
    Dim EndReplaceHL As String
    Dim TempNum As String
    Dim z As Long
    Dim st As Long
    Dim Found As Long
    Dim HLNum As Long
    Dim RepairCtbl As Boolean
    Dim OldCol As Long
    If mRTF.SelLength = 0 Then Exit Sub
    st = mRTF.SelStart
    Found = mRTF.SelLength
    If Not DontLock Then LockWindowUpdate mForm.hWnd
    'Locate the chosen color in the Colortable
    GetColorTable mRTF
    For z = 1 To ColorColl.Count
        If ColorColl(z) = mHighLightColor Then
            HLNum = z - 1
            Exit For
        End If
    Next
    'If we didn't find it then modify the content
    'to place the color in the Colortable
    If HLNum = 0 Then
        mRTF.SelStart = st
        mRTF.SelLength = 1
        OldCol = mRTF.SelColor
        mRTF.SelColor = mHighLightColor
        GetColorTable mRTF
        For z = 1 To ColorColl.Count
            If ColorColl(z) = mHighLightColor Then
                HLNum = z - 1
                Exit For
            End If
        Next
        RepairCtbl = True
    End If
    mRTF.SelStart = st
    mRTF.SelLength = 0
    'Place markers around the selection
    mRTF.SelText = "%%%ZSTART%%%"
    mRTF.SelStart = st + Found + 12
    mRTF.SelText = "%%%ZENDBB%%%"
    TempRTF = mRTF.TextRTF
    SelStart = InStr(1, TempRTF, "%%%ZSTART%%%")
    SelEnd = InStr(1, TempRTF, "%%%ZENDBB%%%") + 12
    'Place the selected text RTF code in a variable
    SelectedText = Mid(TempRTF, SelStart, SelEnd - SelStart)
    
    'inspect the preceding RTF code for any highlighting
    z = InStrRev(TempRTF, "\\highlight", SelStart)
    'If there's highlighting, record its number(color index)
    If z <> 0 Then BeforeHL = Mid(TempRTF, z + 10, 1)
    
    'inspect the RTF code after the selection for any highlighting
    z = InStr(SelEnd, TempRTF, "\\highlight")
    'If there's highlighting, record its number(color index)
    If z <> 0 Then AfterHL = Mid(TempRTF, z + 10, 1)
    
    'inspect the RTF code of the selection for any highlighting
    'find the first highlighting entry in the selection
    z = InStr(1, SelectedText, "\\highlight")
    'If there's highlighting, record the first highlighting entry's number(color index)
    If z <> 0 Then FirstSelHL = Mid(SelectedText, z + 10, 1)
    'find the last highlighting entry in the selection
    z = InStrRev(SelectedText, "\\highlight")
    If z <> 0 Then
        'if found record it's number(color index)
        LastSelHL = Mid(SelectedText, z + 10, 1)
        'Ok, we've got all the selections highlighting recorded
        'now we remove ALL highlighting from the selection
        Do
            TempNum = Mid(SelectedText, z + 10, 1)
            SelectedText = Replace(SelectedText, "\\highlight" & TempNum & " ", "", , 1)
            z = InStr(1, SelectedText, "\\highlight")
            If z = 0 Then Exit Do
        Loop
        'retuen the altered seleted RTF code back to the entire RTF code
        TempRTF = Left(TempRTF, SelStart - 1) & SelectedText & Right(TempRTF, Len(TempRTF) - SelEnd + 1)
    Else
        'If there was no highlighting in the selection then
        'use any highlighting data from BEFORE the selection
        If BeforeHL <> "" And BeforeHL <> "0" Then
            LastSelHL = BeforeHL
        End If
    End If
    
    'Now to replace our markers with the appropriate RTF tags according to
    'the highlighting tags found before/in/after the selection
    
    'Prepare the replacement strings
    StartReplaceHL = IIf(BeforeHL = "0" Or BeforeHL = "", "\\highlight" & HLNum & " ", "\\highlight0 " & "\\highlight" & HLNum & " ")
    EndReplaceHL = IIf(LastSelHL = "0" Or LastSelHL = "", "\\highlight0 ", "\\highlight0 " & "\\highlight" & LastSelHL & " ")
    'Do the replacing
    TempRTF = Replace(TempRTF, "%%%ZSTART%%%", StartReplaceHL)
    TempRTF = Replace(TempRTF, "%%%ZENDBB%%%", EndReplaceHL)
    'return the RTF code to the richtextbox
    mRTF.TextRTF = TempRTF
    'Return any adjustments back to what it was
    If RepairCtbl Then
        mRTF.SelStart = st
        mRTF.SelLength = 1
        mRTF.SelColor = OldCol
        mRTF.SelStart = 0
    End If
    mRTF.SelStart = st
    mRTF.Refresh
    If Not DontLock Then LockWindowUpdate 0
End Sub

Private Sub GetColorTable(mRTF As RichTextBox)
    Dim z As Long, z1 As Long, temp As String, tmp() As String, tmpCol() As String
    Set ColorColl = New Collection
    ColorColl.Add 0
    'Parse the RTF code to extract the Colortable
    z = InStr(1, mRTF.TextRTF, "{\\colortbl")
    If z = 0 Then
        Exit Sub
    Else
        'Parse the Colortable to extract the colors used
        z1 = InStr(z, mRTF.TextRTF, "}")
        If z1 = 0 Then
            Exit Sub
        Else
            temp = Mid(mRTF.TextRTF, z, z1 - z + 1)
            tmp = Split(temp, ";")
            For z = 1 To UBound(tmp) - 1
                If tmp(z) <> "" Then
                    If Left(tmp(z), 1) = "\\" Then tmp(z) = Right(tmp(z), Len(tmp(z)) - 1)
                    tmpCol = Split(tmp(z), "\\")
                    'Dump the colors found into a collection
                    ColorColl.Add RGB(Val(Right(tmpCol(0), Len(tmpCol(0)) - 3)), Val(Right(tmpCol(1), Len(tmpCol(1)) - 5)), Val(Right(tmpCol(2), Len(tmpCol(2)) - 4)))
                End If
            Next
        End If
    End If
End Sub

Hvis jeg forstår dig ret skal du farve bagrundsfarven bag et ord (fremhæve et ord)...
Det er faktisk meget svært! MEGA SVÆRT!

Det er ikke så svært, når man først får det lært, man kan gør' hvad man vil... ej... fuck nu af krumme!

Her er en funktion som jeg selv har brugt...

Kode 

Public Sub HighLightSelection(mForm As Form, mRTF As RichTextBox, mHighLightColor As Long, Optional DontLock As Boolean)
   
    'This is trickier than the other Highlight functions because
    'we have to allow for existing highlighting in various colors
    Dim TempRTF As String
    Dim SelStart As Long
    Dim SelEnd As Long
    Dim SelectedText As String
    Dim BeforeHL As String
    Dim AfterHL As String
    Dim FirstSelHL As String
    Dim LastSelHL As String
    Dim StartReplaceHL As String
    Dim EndReplaceHL As String
    Dim TempNum As String
    Dim z As Long
    Dim st As Long
    Dim Found As Long
    Dim HLNum As Long
    Dim RepairCtbl As Boolean
    Dim OldCol As Long
    If mRTF.SelLength = 0 Then Exit Sub
    st = mRTF.SelStart
    Found = mRTF.SelLength
    If Not DontLock Then LockWindowUpdate mForm.hWnd
    'Locate the chosen color in the Colortable
    GetColorTable mRTF
    For z = 1 To ColorColl.Count
        If ColorColl(z) = mHighLightColor Then
            HLNum = z - 1
            Exit For
        End If
    Next
    'If we didn't find it then modify the content
    'to place the color in the Colortable
    If HLNum = 0 Then
        mRTF.SelStart = st
        mRTF.SelLength = 1
        OldCol = mRTF.SelColor
        mRTF.SelColor = mHighLightColor
        GetColorTable mRTF
        For z = 1 To ColorColl.Count
            If ColorColl(z) = mHighLightColor Then
                HLNum = z - 1
                Exit For
            End If
        Next
        RepairCtbl = True
    End If
    mRTF.SelStart = st
    mRTF.SelLength = 0
    'Place markers around the selection
    mRTF.SelText = "%%%ZSTART%%%"
    mRTF.SelStart = st + Found + 12
    mRTF.SelText = "%%%ZENDBB%%%"
    TempRTF = mRTF.TextRTF
    SelStart = InStr(1, TempRTF, "%%%ZSTART%%%")
    SelEnd = InStr(1, TempRTF, "%%%ZENDBB%%%") + 12
    'Place the selected text RTF code in a variable
    SelectedText = Mid(TempRTF, SelStart, SelEnd - SelStart)
    
    'inspect the preceding RTF code for any highlighting
    z = InStrRev(TempRTF, "\\highlight", SelStart)
    'If there's highlighting, record its number(color index)
    If z <> 0 Then BeforeHL = Mid(TempRTF, z + 10, 1)
    
    'inspect the RTF code after the selection for any highlighting
    z = InStr(SelEnd, TempRTF, "\\highlight")
    'If there's highlighting, record its number(color index)
    If z <> 0 Then AfterHL = Mid(TempRTF, z + 10, 1)
    
    'inspect the RTF code of the selection for any highlighting
    'find the first highlighting entry in the selection
    z = InStr(1, SelectedText, "\\highlight")
    'If there's highlighting, record the first highlighting entry's number(color index)
    If z <> 0 Then FirstSelHL = Mid(SelectedText, z + 10, 1)
    'find the last highlighting entry in the selection
    z = InStrRev(SelectedText, "\\highlight")
    If z <> 0 Then
        'if found record it's number(color index)
        LastSelHL = Mid(SelectedText, z + 10, 1)
        'Ok, we've got all the selections highlighting recorded
        'now we remove ALL highlighting from the selection
        Do
            TempNum = Mid(SelectedText, z + 10, 1)
            SelectedText = Replace(SelectedText, "\\highlight" & TempNum & " ", "", , 1)
            z = InStr(1, SelectedText, "\\highlight")
            If z = 0 Then Exit Do
        Loop
        'retuen the altered seleted RTF code back to the entire RTF code
        TempRTF = Left(TempRTF, SelStart - 1) & SelectedText & Right(TempRTF, Len(TempRTF) - SelEnd + 1)
    Else
        'If there was no highlighting in the selection then
        'use any highlighting data from BEFORE the selection
        If BeforeHL <> "" And BeforeHL <> "0" Then
            LastSelHL = BeforeHL
        End If
    End If
    
    'Now to replace our markers with the appropriate RTF tags according to
    'the highlighting tags found before/in/after the selection
    
    'Prepare the replacement strings
    StartReplaceHL = IIf(BeforeHL = "0" Or BeforeHL = "", "\\highlight" & HLNum & " ", "\\highlight0 " & "\\highlight" & HLNum & " ")
    EndReplaceHL = IIf(LastSelHL = "0" Or LastSelHL = "", "\\highlight0 ", "\\highlight0 " & "\\highlight" & LastSelHL & " ")
    'Do the replacing
    TempRTF = Replace(TempRTF, "%%%ZSTART%%%", StartReplaceHL)
    TempRTF = Replace(TempRTF, "%%%ZENDBB%%%", EndReplaceHL)
    'return the RTF code to the richtextbox
    mRTF.TextRTF = TempRTF
    'Return any adjustments back to what it was
    If RepairCtbl Then
        mRTF.SelStart = st
        mRTF.SelLength = 1
        mRTF.SelColor = OldCol
        mRTF.SelStart = 0
    End If
    mRTF.SelStart = st
    mRTF.Refresh
    If Not DontLock Then LockWindowUpdate 0
End Sub

PS. Hvis du ikke kan finde ud af at bruge det så bare spørg!

det gør det ikke nemmer, at der vist nok mangle en fukntion lockwindowupdate

det gør det ikke nemmer, at der vist nok mangle en fukntion lockwindowupdate

Den finder man i sin API Viewer:

Private Declare Function LockWindowUpdate Lib "user32" Alias "LockWindowUpdate" _
            (ByVal hwndLock As Long) As Long

Det er straks værre med GetColorTable...

/ Bjarke

--------------------------------------------------
[THIS IS A SIGNATURE VIRUS! PLEASE COPY IT INTO YOUR OWN SIGNATURE(S)]
--------------------------------------------------
*** Matematisk Student anno 2003!! *** (Juhuu...)

Hvis jeg forstår dig ret skal du farve bagrundsfarven bag et ord (fremhæve et ord)...
Det er faktisk meget svært! MEGA SVÆRT!

Det er ikke så svært, når man først får det lært, man kan gør' hvad man vil... ej... fuck nu af krumme!

Her er en funktion som jeg selv har brugt...

Public Sub HighLightSelection(mForm As Form, mRTF As RichTextBox, mHighLightColor As Long, Optional DontLock As Boolean)
   
    'This is trickier than the other Highlight functions because
    'we have to allow for existing highlighting in various colors
    Dim TempRTF As String
    Dim SelStart As Long
    Dim SelEnd As Long
    Dim SelectedText As String
    Dim BeforeHL As String
    Dim AfterHL As String
    Dim FirstSelHL As String
    Dim LastSelHL As String
    Dim StartReplaceHL As String
    Dim EndReplaceHL As String
    Dim TempNum As String
    Dim z As Long
    Dim st As Long
    Dim Found As Long
    Dim HLNum As Long
    Dim RepairCtbl As Boolean
    Dim OldCol As Long
    If mRTF.SelLength = 0 Then Exit Sub
    st = mRTF.SelStart
    Found = mRTF.SelLength
    If Not DontLock Then LockWindowUpdate mForm.hWnd
    'Locate the chosen color in the Colortable
    GetColorTable mRTF
    For z = 1 To ColorColl.Count
        If ColorColl(z) = mHighLightColor Then
            HLNum = z - 1
            Exit For
        End If
    Next
    'If we didn't find it then modify the content
    'to place the color in the Colortable
    If HLNum = 0 Then
        mRTF.SelStart = st
        mRTF.SelLength = 1
        OldCol = mRTF.SelColor
        mRTF.SelColor = mHighLightColor
        GetColorTable mRTF
        For z = 1 To ColorColl.Count
            If ColorColl(z) = mHighLightColor Then
                HLNum = z - 1
                Exit For
            End If
        Next
        RepairCtbl = True
    End If
    mRTF.SelStart = st
    mRTF.SelLength = 0
    'Place markers around the selection
    mRTF.SelText = "%%%ZSTART%%%"
    mRTF.SelStart = st + Found + 12
    mRTF.SelText = "%%%ZENDBB%%%"
    TempRTF = mRTF.TextRTF
    SelStart = InStr(1, TempRTF, "%%%ZSTART%%%")
    SelEnd = InStr(1, TempRTF, "%%%ZENDBB%%%") + 12
    'Place the selected text RTF code in a variable
    SelectedText = Mid(TempRTF, SelStart, SelEnd - SelStart)
    
    'inspect the preceding RTF code for any highlighting
    z = InStrRev(TempRTF, "\\highlight", SelStart)
    'If there's highlighting, record its number(color index)
    If z <> 0 Then BeforeHL = Mid(TempRTF, z + 10, 1)
    
    'inspect the RTF code after the selection for any highlighting
    z = InStr(SelEnd, TempRTF, "\\highlight")
    'If there's highlighting, record its number(color index)
    If z <> 0 Then AfterHL = Mid(TempRTF, z + 10, 1)
    
    'inspect the RTF code of the selection for any highlighting
    'find the first highlighting entry in the selection
    z = InStr(1, SelectedText, "\\highlight")
    'If there's highlighting, record the first highlighting entry's number(color index)
    If z <> 0 Then FirstSelHL = Mid(SelectedText, z + 10, 1)
    'find the last highlighting entry in the selection
    z = InStrRev(SelectedText, "\\highlight")
    If z <> 0 Then
        'if found record it's number(color index)
        LastSelHL = Mid(SelectedText, z + 10, 1)
        'Ok, we've got all the selections highlighting recorded
        'now we remove ALL highlighting from the selection
        Do
            TempNum = Mid(SelectedText, z + 10, 1)
            SelectedText = Replace(SelectedText, "\\highlight" & TempNum & " ", "", , 1)
            z = InStr(1, SelectedText, "\\highlight")
            If z = 0 Then Exit Do
        Loop
        'retuen the altered seleted RTF code back to the entire RTF code
        TempRTF = Left(TempRTF, SelStart - 1) & SelectedText & Right(TempRTF, Len(TempRTF) - SelEnd + 1)
    Else
        'If there was no highlighting in the selection then
        'use any highlighting data from BEFORE the selection
        If BeforeHL <> "" And BeforeHL <> "0" Then
            LastSelHL = BeforeHL
        End If
    End If
    
    'Now to replace our markers with the appropriate RTF tags according to
    'the highlighting tags found before/in/after the selection
    
    'Prepare the replacement strings
    StartReplaceHL = IIf(BeforeHL = "0" Or BeforeHL = "", "\\highlight" & HLNum & " ", "\\highlight0 " & "\\highlight" & HLNum & " ")
    EndReplaceHL = IIf(LastSelHL = "0" Or LastSelHL = "", "\\highlight0 ", "\\highlight0 " & "\\highlight" & LastSelHL & " ")
    'Do the replacing
    TempRTF = Replace(TempRTF, "%%%ZSTART%%%", StartReplaceHL)
    TempRTF = Replace(TempRTF, "%%%ZENDBB%%%", EndReplaceHL)
    'return the RTF code to the richtextbox
    mRTF.TextRTF = TempRTF
    'Return any adjustments back to what it was
    If RepairCtbl Then
        mRTF.SelStart = st
        mRTF.SelLength = 1
        mRTF.SelColor = OldCol
        mRTF.SelStart = 0
    End If
    mRTF.SelStart = st
    mRTF.Refresh
    If Not DontLock Then LockWindowUpdate 0
End Sub

PS. Hvis du ikke kan finde ud af at bruge det så bare spørg!

[Redigeret d. 23/06-03 10:49:34 af Thomas Christensen]

Og hvis du også gerne vil kunne fjerne farverne igen skal indsætte noget mere:

dette også stå i (general declarations)

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

og dette er så 2 subs mere

Public Sub UnHighLight(mForm As Form, mRTF As RichTextBox, Optional mHighLightColor As Long, Optional AllHighlighting As Boolean, Optional DontLock As Boolean)
    Dim tmpRTF As String, z As Long
    Dim curvl As Long, HLNum As Long
    curvl = SendMessage(mRTF.hWnd, EM_GETFIRSTVISIBLELINE, ByVal 0&, ByVal 0&)
    If InStr(1, mRTF.TextRTF, "\\highlight") = 0 Then Exit Sub
    If Not DontLock Then LockWindowUpdate mForm.hWnd
    If Not AllHighlighting Then
        'find the color index in the Colortable
        'of the desired color
        GetColorTable mRTF
        For z = 1 To ColorColl.Count
            If ColorColl(z) = mHighLightColor Then
                HLNum = z - 1
                Exit For
            End If
        Next
        'remove such entries from the RTF code
        tmpRTF = mRTF.TextRTF
        tmpRTF = Replace(tmpRTF, "\\highlight" & HLNum & " ", "")
    Else
        'color doesn't matter - just remove any highlighting
        tmpRTF = Replace(mRTF.TextRTF, "\\highlight0 ", "")
        tmpRTF = Replace(tmpRTF, "\\highlight0", "")
        z = 1
        If InStr(1, tmpRTF, "\\highlight") <> 0 Then
            Do
                If InStr(1, tmpRTF, "\\highlight" & z) <> 0 Then
                    tmpRTF = Replace(tmpRTF, "\\highlight" & z & " ", "")
                    tmpRTF = Replace(tmpRTF, "\\highlight" & z & "", "")
                End If
                If InStr(1, tmpRTF, "\\highlight") = 0 Then Exit Do
                z = z + 1
            Loop
        End If
    End If
    'return the adjusted RTF code to the richtextbox
    mRTF.TextRTF = tmpRTF
    SetScrollPos mForm, mRTF, curvl, True
    If Not DontLock Then LockWindowUpdate 0
End Sub

Public Sub SetScrollPos(mForm As Form, mRTF As RichTextBox, mPos As Long, Optional DontLock As Boolean)
    Dim CurLineCount As Long, curvl As Long, lastvl As Long
    'how many lines?
    CurLineCount = SendMessage(mRTF.hWnd, EM_GETLINECOUNT, ByVal 0&, ByVal 0&)
    'what's the current top line?
    curvl = SendMessage(mRTF.hWnd, EM_GETFIRSTVISIBLELINE, ByVal 0&, ByVal 0&)
    If Not DontLock Then LockWindowUpdate mForm.hWnd
    'use a "PageUp" or "PageDown" for a few big jumps to get close to our target line
    If mPos < curvl Then
        Do Until curvl < mPos
            SendMessage mRTF.hWnd, EM_SCROLL, 2, 0
            curvl = SendMessage(mRTF.hWnd, EM_GETFIRSTVISIBLELINE, ByVal 0&, ByVal 0&)
            If curvl = 0 Or curvl = CurLineCount Then Exit Do
        Loop
    Else
        Do Until curvl > mPos
            SendMessage mRTF.hWnd, EM_SCROLL, 3, 0
            curvl = SendMessage(mRTF.hWnd, EM_GETFIRSTVISIBLELINE, ByVal 0&, ByVal 0&)
            If curvl = 0 Or curvl = CurLineCount Or lastvl = curvl Then Exit Do
            lastvl = curvl
        Loop
    End If
    'Now do some fine adjustment line by line to get
    'it exactly right
    Do Until curvl = mPos
        If mPos < curvl Then
            SendMessage mRTF.hWnd, EM_SCROLL, 0, 0
        Else
            SendMessage mRTF.hWnd, EM_SCROLL, 1, 0
        End If
        curvl = SendMessage(mRTF.hWnd, EM_GETFIRSTVISIBLELINE, ByVal 0&, ByVal 0&)
        If curvl = 0 Or curvl = CurLineCount Or lastvl = curvl Then
            If curvl = 0 Then SendMessage mRTF.hWnd, EM_SCROLL, 0, 0
            Exit Do
        End If
        lastvl = curvl
    Loop
    If Not DontLock Then LockWindowUpdate 0
End Sub