Как выделить текст? - 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
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д