Как выделить текст? - VB

Формулировка задачи:

Допустим, у меня есть строковая переменная, которая содержит текст,как можно выделить красным цветом содержание этой переменной?
Решение задачи: «Как выделить текст?»

textual
                            Листинг программы 
                        
 
                            
                        
Option Explicit
 
Private Type TColorWord
    Word        As String
    Color       As Long
End Type
 
Private Type TColorRange
    StartString   As String
    StopString    As String
    Color       As Long
End Type
 
Private Type POINTAPI
        X       As Long
        Y       As Long
End Type
 
Private Type RECT
        Left    As Long
        Top     As Long
        Right   As Long
        Bottom  As Long
End Type
 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Any) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As POINTAPI) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function HideCaret Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ShowCaret Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
 
Private Const GWL_WNDPROC = (-4), _
              WM_PAINT = &HF, _
              WM_MOUSEMOVE = &H200, _
              MK_LBUTTON = &H1, _
              WM_LBUTTONUP = &H202, _
              WM_PASTE = &H302, _
              WM_KILLFOCUS = &H8, _
              WM_SETFOCUS = &H7, _
              WM_HSCROLL = &H114, _
              WM_VSCROLL = &H115, _
              WM_MOUSEWHEEL = &H20A, _
              SB_ENDSCROLL = 8, _
              WM_KEYDOWN = &H100, _
              VK_BACK = &H8, _
              VK_TAB = &H9, _
              WM_CHAR = &H102, _
              VK_SHIFT = &H10, _
              EM_POSFROMCHAR = &HD6
Private Const EM_LINEFROMCHAR = &HC9, _
              WM_GETFONT = &H31, _
              EM_LINEINDEX = &HBB, _
              EM_LINELENGTH = &HC1, _
              EM_GETLINE = &HC4, _
              EM_CHARFROMPOS = &HD7, _
              EM_GETFIRSTVISIBLELINE = &HCE, _
              EM_GETRECT = &HB2, _
              PS_SOLID = 0, _
              DEFAULT_CHARSET = 1, _
              LOGPIXELSY = 90, _
              OUT_DEFAULT_PRECIS = 0, _
              CLIP_DEFAULT_PRECIS = 0, _
              DEFAULT_PITCH = 0, _
              FW_NORMAL = 400, _
              DEFAULT_QUALITY = 0, _
              WM_SETFONT = &H30, _
              COLOR_HIGHLIGHT = 13, _
              COLOR_HIGHLIGHTTEXT = 14, _
              COLOR_BTNFACE = 15, _
              EM_GETLINECOUNT = &HBA
 
Public PrevProc                 As Long
 
Private ColorTextBox            As TextBox, _
        ColorTextBoxParentForm  As Form, _
        CWord()                 As TColorWord, _
        CRange()                As TColorRange, _
        TexthDC                 As Long, _
        hFont                   As Long, _
        hPen                    As Long, _
        CharHeight              As Long, _
        CharWidth               As Long, _
        HLColor                 As Long, _
        NColor                  As Long, _
        HLTextColor             As Long, _
        NTextColor              As Long, _
        CurrentBkColor          As Long, _
        CurrentTextColor        As Long, _
        CColor                  As Long, _
        CTextColor              As Long
 
Private Sub PrepareTextBox()
Dim FontHeight As Long
ColorTextBox.ForeColor = vbBlack
ColorTextBox.BackColor = vbWhite
FontHeight = -MulDiv(10, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72)
hFont = CreateFont(FontHeight, 0, 0, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, "courier new")
SendMessage ColorTextBox.hwnd, WM_SETFONT, hFont, 0
TexthDC = GetDC(ColorTextBox.hwnd)
SelectObject TexthDC, hFont
hPen = CreatePen(PS_SOLID, 0, ColorTextBox.BackColor)
SelectObject TexthDC, hPen
End Sub
 
Private Sub PrepareVars()
Dim Size As POINTAPI
ReDim CWord(0)
ReDim CRange(0)
GetTextExtentPoint32 TexthDC, "x", 1, Size
CharHeight = Size.Y: CharWidth = Size.X
HLColor = GetSysColor(COLOR_HIGHLIGHT)
HLTextColor = GetSysColor(COLOR_HIGHLIGHTTEXT)
NColor = ColorTextBox.BackColor
NTextColor = vbBlue
CColor = ColorTextBox.BackColor
CTextColor = ColorTextBox.ForeColor
CurrentTextColor = 1
End Sub
 
Public Sub AddColorWord(Word As String, Color As Long)
Dim i As Long
For i = 0 To UBound(CWord)
    If CWord(i).Word = "" Or UCase(CWord(i).Word) = UCase(Word) Then
        With CWord(i)
            .Word = Word
            .Color = Color
        End With
        Exit Sub
    End If
Next i
ReDim Preserve CWord(UBound(CWord) + 1)
With CWord(UBound(CWord))
    .Word = Word
    .Color = Color
End With
End Sub
 
Public Sub DeleteColorWord(Word As String)
Dim i As Long
For i = 0 To UBound(CWord)
    If UCase(CWord(i).Word) = UCase(Word) Then CWord(i).Word = ""
Next i
End Sub
 
Public Sub AddColorRange(StartString As String, StopString As String, Color As Long)
Dim i As Long
For i = 0 To UBound(CRange)
    If CRange(i).StartString = "" Or UCase(CRange(i).StartString) = UCase(StartString) Then
        With CRange(i)
            .StartString = StartString
            .StopString = StopString
            .Color = Color
        End With
        Exit Sub
    End If
Next i
ReDim Preserve CRange(UBound(CRange) + 1)
With CRange(UBound(CRange))
    .StartString = StartString
    .StopString = StopString
    .Color = Color
End With
End Sub
 
Public Sub DeleteColorRange(StartString As String)
Dim i As Long
For i = 0 To UBound(CRange)
    If UCase(CRange(i).StartString) = UCase(StartString) Then CRange(i).StartString = ""
Next i
End Sub
 
Private Sub PaintLine(LineIndex As Long, Selected As Boolean)
Dim s               As String, _
    ss              As String, _
    Chp             As Long, _
    Chp2            As Long, _
    MinChp          As Long, _
    MinChpIndex     As Long, _
    m               As Long, _
    X               As Long, _
    Y               As Long, _
    SChp            As Long, _
    PosFromChar     As Long, _
    chIndex         As Long, _
    SelLength       As Long, _
    i               As Long, _
    SelStart        As Long, _
    n               As Long, _
    OK              As Boolean, _
    WordForOut      As String, _
    CW              As Boolean, _
    WordForFinding  As String
SelStart = ColorTextBox.SelStart
SelLength = ColorTextBox.SelLength
chIndex = SendMessage(ColorTextBox.hwnd, EM_LINEINDEX, LineIndex, 0&)
s = Space(SendMessage(ColorTextBox.hwnd, EM_LINELENGTH, chIndex, 0&))
SendMessage ColorTextBox.hwnd, EM_GETLINE, LineIndex, ByVal s
HideCaret ColorTextBox.hwnd
CW = True
Do
    If CW Then WordForFinding = CWord(n).Word
    If WordForFinding <> "" Or Not CW Then
        Do
            OK = True
            If CW Then
                Chp = InStr(Chp + 1, UCase(s), UCase(WordForFinding))
                If Chp = 0 Then Exit Do
                If Chp = 1 Then
                    OK = True
                Else
                    If Mid(s, Chp - 1, 1) = " " Then
                        OK = True
                    Else
                        OK = False
                    End If
                End If
                If OK And Chp + Len(WordForFinding) - 1 <> Len(s) Then
                    ss = Mid(s, Chp + Len(WordForFinding), 1)
                    If ss <> " " And ss <> "," And ss <> "(" And ss <> ")" Then OK = False
                End If
            Else
                MinChpIndex = -1
                MinChp = Len(s)
                For m = 0 To UBound(CRange)
                    X = InStr(Chp2 + 1, UCase(s), UCase(CRange(m).StartString))
                    Y = IIf(CRange(m).StopString <> Chr(0), InStr(X + 1, UCase(s), UCase(CRange(m).StopString)), Len(s))
                    If X <> 0 And X < MinChp And Y <> 0 Then
                        MinChp = X
                        MinChpIndex = m
                        SChp = Y
                    End If
                Next m
                If MinChpIndex <> -1 Then
                    Chp = MinChp
                    Chp2 = SChp
                    OK = True
                Else
                    Exit Do
                End If
            End If
            If OK Then
                If CW Then
                    NTextColor = CWord(n).Color
                    WordForOut = WordForFinding
                Else
                    NTextColor = CRange(MinChpIndex).Color
                    WordForOut = Mid(s, Chp, Chp2 - Chp + 1)
                End If
                PosFromChar = SendMessage(ColorTextBox.hwnd, EM_POSFROMCHAR, chIndex + Chp - 1, 1)
                'если слово не выделено:
                If chIndex + Chp - 1 > SelStart + SelLength Or chIndex + Chp - 1 + Len(WordForOut) < SelStart Or Not Selected Then
                    If CurrentTextColor <> NTextColor Then
                        SetBkColor TexthDC, NColor
                        SetTextColor TexthDC, NTextColor
                        CurrentTextColor = NTextColor
                    End If
                    TextOut TexthDC, LoWord(PosFromChar), HiWord(PosFromChar), WordForOut, Len(WordForOut)
                Else
                    'если всё слово выделено:
                    If (chIndex + Chp - 1) >= SelStart And (chIndex + Chp - 1 + Len(WordForOut)) <= (SelStart + SelLength) Then
                        If CurrentTextColor <> HLTextColor Then
                            SetBkColor TexthDC, HLColor
                            SetTextColor TexthDC, HLTextColor
                            CurrentTextColor = HLTextColor
                        End If
                        TextOut TexthDC, LoWord(PosFromChar), HiWord(PosFromChar), WordForOut, Len(WordForOut)
                    Else
                        'полслова выделено, а полслова нет
                        For i = chIndex + Chp - 1 To chIndex + Chp - 1 + Len(WordForOut) - 1
                            If i >= SelStart And i < SelStart + SelLength Then
                                If CurrentTextColor <> HLTextColor Then
                                    SetBkColor TexthDC, HLColor
                                    SetTextColor TexthDC, HLTextColor
                                    CurrentTextColor = HLTextColor
                                End If
                            Else
                                If CurrentTextColor <> NTextColor Then
                                    SetBkColor TexthDC, NColor
                                    SetTextColor TexthDC, NTextColor
                                    CurrentTextColor = NTextColor
                                End If
                            End If
                            TextOut TexthDC, LoWord(PosFromChar) + (i - (chIndex + Chp - 1)) * CharWidth, HiWord(PosFromChar), Mid(WordForOut, i - (chIndex + Chp - 1) + 1, 1), 1
                        Next i
                    End If
                End If
            End If
        Loop
    End If
    n = n + 1
    If Not CW Then Exit Do
    If CW And n > UBound(CWord) Then CW = False
Loop
ShowCaret ColorTextBox.hwnd
End Sub
 
Public Sub CreateColorTextBox(TextBox As TextBox, ParentForm As Form)
Set ColorTextBox = TextBox
Set ColorTextBoxParentForm = ParentForm
PrepareTextBox
PrepareVars
HookTextBox
End Sub
 
Public Sub DestroyColorTextBox()
UnHookTextBox
ReDim CWord(0)
ReDim CRange(0)
ReleaseDC ColorTextBox.hwnd, TexthDC
DeleteObject hPen
ColorTextBox.Refresh
Set ColorTextBox = Nothing
Set ColorTextBoxParentForm = Nothing
End Sub
 
Private Sub HookTextBox()
PrevProc = SetWindowLong(ColorTextBox.hwnd, GWL_WNDPROC, AddressOf TextBoxWindowProc)
End Sub
 
Private Sub UnHookTextBox()
SetWindowLong ColorTextBox.hwnd, GWL_WNDPROC, PrevProc
End Sub
 
Public Function TextBoxWindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim ReDraw As Boolean
If uMsg = WM_CHAR And wParam = VK_BACK Then
    If Back_Pressed Then
        uMsg = 0
        ReDraw = True
    End If
End If
If uMsg = WM_CHAR And wParam = VK_TAB Then
    If (GetKeyState(VK_SHIFT) And &HF0000000) Then
        ShiftTab_Pressed
    Else
        Tab_Pressed
    End If
    uMsg = 0
    ReDraw = True
End If
 
TextBoxWindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
If uMsg = WM_CHAR Then DrawCurrentLine
If uMsg = WM_PAINT _
   Or uMsg = WM_LBUTTONUP _
   Or uMsg = WM_PASTE _
   Or (uMsg = WM_MOUSEMOVE And wParam = MK_LBUTTON) _
   Or uMsg = WM_SETFOCUS _
   Or uMsg = WM_KILLFOCUS _
   Or ReDraw _
   Or uMsg = WM_KEYDOWN _
   Or uMsg = WM_CHAR _
Then PaintAllLines uMsg <> WM_KILLFOCUS
If uMsg = WM_KILLFOCUS Then SetTabStop True
If uMsg = WM_SETFOCUS Then SetTabStop False
If ((uMsg = WM_HSCROLL Or uMsg = WM_VSCROLL) And LoWord(wParam) = SB_ENDSCROLL) Or uMsg = WM_MOUSEWHEEL Then DrawVLines
End Function
 
Public Function LoWord(DWord As Long) As Integer
LoWord = IIf(DWord And &H8000&, DWord Or &HFFFF0000, DWord And &HFFFF&)
End Function
 
Public Function HiWord(DWord As Long) As Integer
HiWord = (DWord And &HFFFF0000) \ &H10000
End Function
 
Private Sub PaintAllLines(Selected As Boolean)
Dim FirstVisibleLine    As Long, _
    VisibleLineCount    As Long, _
    R                   As RECT, _
    i                   As Long, _
    LineCount           As Long
LineCount = SendMessage(ColorTextBox.hwnd, EM_GETLINECOUNT, 0, 0)
FirstVisibleLine = SendMessage(ColorTextBox.hwnd, EM_GETFIRSTVISIBLELINE, 0, 0)
SendMessage ColorTextBox.hwnd, EM_GETRECT, 0, R
VisibleLineCount = Int((R.Bottom - R.Top) / CharHeight)
Debug.Print CStr(VisibleLineCount)
For i = FirstVisibleLine To FirstVisibleLine + VisibleLineCount
    If i >= VisibleLineCount + FirstVisibleLine Then Exit For
    PaintLine i, Selected
Next i
End Sub
 
Private Sub DrawLine(LineIndex As Long)
Dim s           As String, _
    PosFromChar As Long, _
    chIndex     As Long
chIndex = SendMessage(ColorTextBox.hwnd, EM_LINEINDEX, LineIndex, 0&)
s = Space(SendMessage(ColorTextBox.hwnd, EM_LINELENGTH, chIndex, 0&))
SendMessage ColorTextBox.hwnd, EM_GETLINE, LineIndex, ByVal s
HideCaret ColorTextBox.hwnd
PosFromChar = SendMessage(ColorTextBox.hwnd, EM_POSFROMCHAR, chIndex, 1)
If CurrentTextColor <> CTextColor Then
    SetBkColor TexthDC, CColor
    SetTextColor TexthDC, CTextColor
    CurrentTextColor = CTextColor
End If
TextOut TexthDC, LoWord(PosFromChar), HiWord(PosFromChar), s, Len(s)
ShowCaret ColorTextBox.hwnd
End Sub
 
Private Sub DrawCurrentLine()
DrawLine SendMessage(ColorTextBox.hwnd, EM_LINEFROMCHAR, ColorTextBox.SelStart, 0)
End Sub
 
Private Sub DrawVLines()
Dim ret As Long, _
    R   As RECT
SendMessage ColorTextBox.hwnd, EM_GETRECT, 0, R
MoveToEx TexthDC, 0, 0, ret
LineTo TexthDC, 0, R.Bottom
MoveToEx TexthDC, R.Right, 0, ret
LineTo TexthDC, R.Right, R.Bottom
End Sub
 
Private Sub SetTabStop(Value As Boolean)
Dim i As Long
On Error Resume Next
For i = 0 To ColorTextBoxParentForm.Controls.Count - 1
   ColorTextBoxParentForm.Controls(i).TabStop = Value
Next
End Sub
 
Private Sub Tab_Pressed()
Dim i           As Long, _
    SelLength   As Long, _
    k           As Long, _
    s()         As String, _
    SelStart    As Long
SelLength = ColorTextBox.SelLength
If SelLength = 0 Then
    ColorTextBox.SelText = "    "
Else
    SelStart = ColorTextBox.SelStart
    s = Split(ColorTextBox.SelText, vbCrLf)
    For i = 0 To UBound(s)
        If s(i) <> "" Then
            s(i) = "    " + s(i)
            k = k + 4
        End If
    Next i
    ColorTextBox.SelText = Join(s, vbCrLf)
    ColorTextBox.SelStart = SelStart
    ColorTextBox.SelLength = SelLength + k
End If
End Sub
 
Private Function Back_Pressed() As Boolean
Dim SelStart    As Long, _
    s           As String
SelStart = ColorTextBox.SelStart
s = ColorTextBox.Text
If SelStart < 4 Then
    Back_Pressed = False
    Exit Function
End If
If Mid(s, SelStart - 3, 4) = "    " Then
    s = Mid(s, 1, SelStart - 4) + Mid(s, SelStart + 1)
    ColorTextBox.SelStart = SelStart - 4
    ColorTextBox.SelLength = 4
    ColorTextBox.SelText = ""
    Back_Pressed = True
Else
    Back_Pressed = False
End If
End Function
 
Private Sub ShiftTab_Pressed()
Dim i           As Long, _
    SelLength   As Long, _
    k           As Long, _
    s()         As String, _
    n           As Long, _
    m           As Long, _
    SelStart    As Long
SelLength = ColorTextBox.SelLength
If SelLength = 0 Then Exit Sub
SelStart = ColorTextBox.SelStart
s = Split(ColorTextBox.SelText, vbCrLf)
For i = 0 To UBound(s)
    If s(i) <> "" Then
        m = Len(s(i))
        n = m - Len(LTrim(s(i))) 'количество левых пробелов
        If n <> 0 Then
            If n >= 4 Then
                s(i) = Space(n - 4) + LTrim(s(i))
            Else
                s(i) = LTrim(s(i))
            End If
            k = k + m - Len(s(i))
        End If
    End If
Next i
ColorTextBox.SelText = Join(s, vbCrLf)
ColorTextBox.SelStart = SelStart
ColorTextBox.SelLength = SelLength - k
End Sub