Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0670: Hintergrundfarbe einzelner Zeichen einer RichTextBox festlegen

VB 5/6-Tipp 0670: Hintergrundfarbe einzelner Zeichen einer RichTextBox festlegen

 von David Cannings

Schwierigkeitsgrad:

Verwendete API-Aufrufe: OleTranslateColor, SendMessageA (SendMessage)

Download: Download des Beispielprojektes [4,42 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
' Die Komponente 'Microsoft Rich Textbox Control 6.0 (richtx32.ocx)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "cmdQueryColor"
' Steuerelement: RichTextBox "RichTextBox1"
' Steuerelement: Schaltfläche "cmdColor"


' Der Source stammt ursprünglich von David Cannings und wurde auf
' http://edeca.net/site/code:rtbhighlight
' veröffentlicht

Option Explicit

Private Sub cmdColor_Click()
    Dim x As Long
    With RichTextBox1
        ' jedem Zeichen eine zufällige Hintergrundfarbe zuweisen
        For x = 0 To Len(.Text)
            .SelStart = x
            .SelLength = 1
            SetSelBackColor .hwnd, RGB(Rnd * 255, Rnd * 255, Rnd * 255)
        Next
    End With
End Sub

Private Sub cmdQueryColor_Click()
    MsgBox "Farbe des markierten Bereichs: " & _
        Hex(GetSelBackColor(RichTextBox1.hwnd))
End Sub

Private Sub Form_Load()
    cmdColor_Click
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------- Anfang Modul "modRTBAPI" alias modRTBAPI.bas -------


' Der Source stammt ursprünglich von David Cannings und wurde auf
' http://edeca.net/site/code:rtbhighlight
' veröffentlicht

Option Explicit

' Win32 API Deklarationen
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal _
    lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long

' Konstanten:
Private Const LF_FACESIZE = 32
Private Const SCF_SELECTION = 1
Private Const CFM_BACKCOLOR = &H4000000
Private Const CFE_AUTOBACKCOLOR = CFM_BACKCOLOR
Private Const WM_USER = &H400
Private Const EM_SETCHARFORMAT = (WM_USER + 68)
Private Const EM_GETCHARFORMAT = (WM_USER + 58)

' CharFormat Struktur, die mittels SendMessage an das Control übergeben wird:
Private Type CHARFORMAT2
    cbSize As Integer
    wPad1 As Integer
    dwMask As Long
    dwEffects As Long
    yHeight As Long
    yOffset As Long
    crTextColor As Long
    bCharSet As Byte
    bPitchAndFamily As Byte
    szFaceName(0 To LF_FACESIZE - 1) As Byte
    wPad2 As Integer
    wWeight As Integer
    sSpacing As Integer
    crBackColor As Long
    lLCID As Long
    dwReserved As Long
    sStyle As Integer
    wKerning As Integer
    bUnderlineType As Byte
    bAnimation As Byte
    bRevAuthor As Byte
    bReserved1 As Byte
End Type


Public Function GetSelBackColor(ByVal RTFhwnd As Long) As OLE_COLOR
    ' ermitteln der Hintergrundfarbe des selektierten Bereichs der RichTextBox
    Dim udtChar As CHARFORMAT2

    ' initialisieren der CharFormat Struktur:
    udtChar.cbSize = LenB(udtChar)
    
    ' über den dwMask Member der Struktur wird bestimmt welche Informationen
    ' in die Struktur übertragen werden sollen:
    udtChar.dwMask = CFM_BACKCOLOR  'wir wollen die Back Color
    
    ' Nun schicken wir dem Control eine EM_GETCHARFORMAT Message, und
    ' bekommen im crBackColor Member des udtChar die Farbe zurück:
    SendMessage RTFhwnd, EM_GETCHARFORMAT, SCF_SELECTION, udtChar

    GetSelBackColor = udtChar.crBackColor
End Function

Public Function SetSelBackColor(ByVal RTFhwnd As Long, _
    ByVal NewSelFontBackColor As OLE_COLOR)
    
    ' setzen der Hintergrundfarbe des selektierten Bereichs der RichTextBox
    Dim udtChar As CHARFORMAT2
    
    ' initialisieren der CharFormat Struktur:
    udtChar.cbSize = LenB(udtChar)
    
    ' über den dwMask Member der Struktur wird bestimmt welche Informationen
    ' aus der Struktur übernommen werden sollen:
    udtChar.dwMask = CFM_BACKCOLOR  'wir wollen die Back Color

    ' wurde als NewSelFontBackColor -1 übergeben, so setzen wir die
    ' RichTextBox Backcolor auf "auto"
    If NewSelFontBackColor = -1 Then
        udtChar.dwEffects = CFE_AUTOBACKCOLOR
        udtChar.crBackColor = -1
    Else
        ' der crBackColor Member bestimmt die Farbe:
        udtChar.crBackColor = TranslateColor(NewSelFontBackColor)
    End If
    
    ' Nun schicken wir dem Control eine EM_SETCHARFORMAT Message, und
    ' das Control übernimmt die farbe aus dem udtChar
    SendMessage RTFhwnd, EM_SETCHARFORMAT, SCF_SELECTION, udtChar
End Function

' Diese Funktion wird nur von der SetSelBackColor Funktion verwendet um
' eine RGB Farbe in eine Paletten Farbe umzuwandeln
Private Function TranslateColor(ByVal clr As OLE_COLOR, Optional hPal As Long = 0) As Long
    If OleTranslateColor(clr, hPal, TranslateColor) Then
        TranslateColor = -1
    End If
End Function
'-------- Ende Modul "modRTBAPI" alias modRTBAPI.bas --------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.