Gå til innhold

Farget tekst

are47

Anbefalte innlegg

are47

are47

Skrevet
Skrevet

Hei

 

Driver å leker litt med Vb :)

Har en RichTextBox som jeg har kalt rtb.

Dette er koden:

Dim Ord() As String
Ord = Split(rtb.Text, " ")

Dim I As Integer
For I = LBound(Ord) To UBound(Ord)
Select Case Ord(I)
   Case "bo"
       rtb.SelColor = vbBlue
       rtb.SelText = Ord(I)
   Case Else
       rtb.SelColor = vbBlack
End Select

Next

 

Dette blir helt feil, og jeg vet ikke hvordan jeg kan gjøre det anderledes...

Det jeg skal er at hvis RichTextBoxen min inneholder et spesielt ord, skal det, og kun det ordet få blå farge.

 

Har funnet massevis av eksempler på dette på pscode.com , men alle disse har på en måte en liten bit av hva jeg trenger, og som oftest tonnevis av unødvendig kode :p

 

Så kunne noen av dere si meg hva koden blir? :)

 

Are

Lenke til kommentar

Videoannonse

Videoannonse
Annonse
aadnk

aadnk

Skrevet
Skrevet

Hvis ordet skal bli denne fargen mens du skriver kan du bruke denne koden:

 

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

Private Sub rtb_Change()

On Error Resume Next
Dim Ord() As String
Dim I&, CurrentPosition&, Pos&

LockWindowUpdate rtb.hWnd

Pos = rtb.SelStart
Ord = Split(Replace(rtb.Text, vbNewLine, "  "), " ")

For I = LBound(Ord) To UBound(Ord)

   rtb.SelStart = CurrentPosition
   rtb.SelLength = Len(Ord(I))
   
   Select Case LCase(Ord(I))
   Case "if", "then", "end", "for", "to", "enum", "raiseevent"
       rtb.SelColor = vbBlue
   Case Else
       rtb.SelColor = vbBlack
   End Select
   
   CurrentPosition = CurrentPosition + Len(Ord(I)) + 1
Next

LockWindowUpdate False
rtb.SelStart = Pos

End Sub

 

Som du ser har jeg lagt inn en Replace i Split koden. Dette er for at programmet skal oppfatte ord i enden av en linje som er avsluttet av Enter.

Lenke til kommentar
are47

are47

Skrevet
  • Forfatter
Skrevet

hmm la merke til noe.

Selv om jeg bruke 

Case "bo"

 

så må jeg skrive bo og space for at "bo" blir blå.

Skriver jeg feks bomos så blir ikke "bo" blå.

Men dette skal det, hvordan må jeg redigere koden for det?

Takk

Lenke til kommentar
aadnk

aadnk

Skrevet
Skrevet (endret)

Det kan løses på denne måten:

 

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

Private Type Ord
Text As String
Color As Long
End Type

Private Sub rtb_Change()

On Error Resume Next

Dim Buff$, I&, n&
Dim Pos&, Ord() As Ord

LockWindowUpdate rtb.hWnd
Pos = rtb.SelStart

' Laster inn all data
ReDim Ord(3)
SetVar Ord(0), "bo", vbBlue
SetVar Ord(1), "ho", vbRed
SetVar Ord(2), "tøys", vbGreen
SetVar Ord(3), "nope", vbYellow

' Å hente informasjon direkte fra kontrollen er mye langsommere enn fra en variabel.
' Vi optimiserer koden ved å bruke en buffer.
Buff = LCase(rtb.Text)

For I = 1 To Len(Buff)

   For n = LBound(Ord) To UBound(Ord)
       If Mid(Buff, I, Len(Ord(n).Text)) = Ord(n).Text Then
           rtb.SelStart = I - 1
           rtb.SelLength = Len(Ord(n).Text)
           rtb.SelColor = Ord(n).Color
           
           I = I + Len(Ord(n).Text) - 1
           
           rtb.SelStart = I
           rtb.SelLength = 1
           rtb.SelColor = vbBlack
           
           Exit For
       End If
   Next
Next

LockWindowUpdate False
rtb.SelStart = Pos

End Sub

Private Sub SetVar(Var As Ord, Text As String, Color As Long)

Var.Text = Text
Var.Color = Color

End Sub

 

Imidlertid er koden relativ treig ved store tekster ettersom den med hver endring må gå igjenom hele teksten. Men dette problemet hadde den andre koden også.

Endret av aadnk
Lenke til kommentar
are47

are47

Skrevet
  • Forfatter
Skrevet

Tusen Takk aadnk

 

Fått enda et problem, denne gangen skal all tekst mellom ordene "bø" og "bæ" blir i en spesiell farge. Uansett hvor mye tekst det er imellom, og hva teksten inneholder.

 

Blir vel mitt sitse farge spm :p

Takk skal dere ha

Lenke til kommentar
jonask

jonask

Skrevet
Skrevet (endret)

Genialt stykke kode, aadnk =) Her lærte jeg faktisk hele tre nye, veldig nyttige triks! at richboxen kan skille på textfarge, split kommandoen og denne LockWindowUpdate ATIen =) hehe, takk for den sweete koden!

Endret av jonask
Lenke til kommentar
aadnk

aadnk

Skrevet
Skrevet (endret)

Til Jonask: Jeg er bare glad for å være til hjelp.

 

Og så til spørsmålet ditt, are47. Jeg vil anta at en mulig løsning er å bruke en variabel som definerer fargen etter de respektive nøkkelordene. Dette kan gjøres med denne modifiserte koden:

 

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

Private Type Ord
Text As String
ExitColor As Long
Color As Long
End Type

Private Sub rtb_Change()

On Error Resume Next

Dim Buff$, I&, n&
Dim Pos&, Ord() As Ord

LockWindowUpdate rtb.hWnd
Pos = rtb.SelStart

' Laster inn all data
ReDim Ord(1)
SetVar Ord(0), "bø", vbBlue, vbMagenta
SetVar Ord(1), "bæ", vbRed, vbBlack

' Å hente informasjon direkte fra kontrollen er mye langsommere enn fra en variabel.
' Vi optimiserer koden ved å bruke en buffer.
Buff = LCase(rtb.Text)

For I = 1 To Len(Buff)

  For n = LBound(Ord) To UBound(Ord)
      If Mid(Buff, I, Len(Ord(n).Text)) = Ord(n).Text Then
          rtb.SelStart = I - 1
          rtb.SelLength = Len(Ord(n).Text)
          rtb.SelColor = Ord(n).Color
          
          I = I + Len(Ord(n).Text) - 1
          
          rtb.SelStart = I
          rtb.SelLength = 1
          rtb.SelColor = Ord(n).ExitColor
          
          Exit For
      End If
  Next
Next

LockWindowUpdate False
rtb.SelStart = Pos

End Sub

Private Sub SetVar(Var As Ord, Text As String, Color As Long, ExitColor As Long)

Var.Text = Text
Var.Color = Color
Var.ExitColor = ExitColor

End Sub

 

Men det avhenger selvsakt om denne fargen kun skal opptre hvis den er etterfølgt av nøkkelordet bæ. I så fall må du bruke InStr(I, Buff, "bæ") for å teste om dette er tillfellet.

Endret av aadnk
Lenke til kommentar
Atmozpheric

Atmozpheric

Skrevet
Skrevet

Har testa koden(e) pluss at eg har prøvd med Regular Expressions funksjonen. Dette duger jo ikkje vist det blir for masse tekst... maskina jobber så masse at det hakker når eg skriver.

 

Hadde det ikkje vært mulig å berre formatere teksten som er synlig?

Lenke til kommentar
aadnk

aadnk

Skrevet
Skrevet

Jo, det er mulig å fraholde prosedyren å formatere tekst som er usynlig. Dette kan gjøres slik:

 

Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, wParam As Any, lParam As Any) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Private Enum EditMessages
   EM_GETFIRSTVISIBLELINE = &HCE
   EM_CHARFROMPOS = &HD7
End Enum

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type POINTAPI
x As Long
y As Long
End Type

Private Type Ord
Text As String
ExitColor As Long
Color As Long
End Type

Private Sub rtb_Change()

On Error Resume Next

Dim Buff$, I&, n&, FirstLineChar&, LastLineChar&
Dim Pos&, Ord() As Ord, LastColor&
Dim aPt As POINTAPI, rcWindow As RECT

' Å hente informasjon direkte fra kontrollen er mye langsommere enn fra en variabel.
' Vi optimiserer koden ved å bruke en buffer.
Buff = LCase(rtb.Text)

If Len(Buff) < 2 Then Exit Sub

Pos = rtb.SelStart
If Mid(Buff, Len(Buff) - 1, 2) <> vbNewLine Then rtb.Text = rtb.Text & vbNewLine

LockWindowUpdate rtb.hwnd

' Laster inn all data
ReDim Ord(1)
SetVar Ord(0), "bø", vbBlue, vbMagenta
SetVar Ord(1), "bæ", vbRed, vbBlack

' Henter bokstav-indeks til første synlige linje
FirstLineChar = GetCharFromLine(rtb, SendMessage(rtb.hwnd, EM_GETFIRSTVISIBLELINE, ByVal 0&, ByVal 0&))

' Henter bokstav-indeks til siste synlige linje
GetWindowRect hwnd, rcWindow
aPt.x = rcWindow.Right - rcWindow.Left - 2
aPt.y = rcWindow.Bottom - rcWindow.Top - 2

LastLineChar = SendMessage(rtb.hwnd, EM_CHARFROMPOS, ByVal 0&, ByVal aPt)
Debug.Print FirstLineChar & ", " & LastLineChar

For I = FirstLineChar + 1 To LastLineChar + 1

 For n = LBound(Ord) To UBound(Ord)
     If Mid(Buff, I, Len(Ord(n).Text)) = Ord(n).Text Then
         rtb.SelStart = I - 1
         rtb.SelLength = Len(Ord(n).Text)
         rtb.SelColor = Ord(n).Color
         
         I = I + Len(Ord(n).Text) - 1
         
         rtb.SelStart = I
         rtb.SelLength = 1
         rtb.SelColor = Ord(n).ExitColor
         LastColor = rtb.SelColor
         
         Exit For
     End If
     
     ' Fjern denne koden hvis du ikke vil at exit fargen skal forsette videre utenfor linjen.
     If Mid(Buff, I, 2) = vbNewLine Then
         rtb.SelStart = I
         rtb.SelLength = 2
         rtb.SelColor = LastColor
     End If
 Next
Next

LockWindowUpdate False
rtb.SelStart = Pos

End Sub

Public Function GetCharFromLine(aControl As Control, ByVal Line As Long) As Long

Dim Char&, Tmp&

Do Until Line = 0
   Char = InStr(Char + 1, aControl.Text, vbNewLine)
   Line = Line - 1
Loop

GetCharFromLine = Char

End Function

Private Sub SetVar(Var As Ord, Text As String, Color As Long, ExitColor As Long)

Var.Text = Text
Var.Color = Color
Var.ExitColor = ExitColor

End Sub

Lenke til kommentar

Opprett en konto eller logg inn for å kommentere

Du må være et medlem for å kunne skrive en kommentar

Opprett konto

Det er enkelt å melde seg inn for å starte en ny konto!

Start en konto

Logg inn

Har du allerede en konto? Logg inn her.

Logg inn nå
Gå til emneliste

  • Hvem er aktive   0 medlemmer

    • Ingen innloggede medlemmer aktive
×
×
  • Opprett ny...