DBR Delphi-Ecke

// Getestet mit D4 unter WinME

// Textstellen in einem Richedit hervorheben:

// Variante 1: Nachdem sich der Text im Richedit befindet

// Der folgende Quelltest hebt auf Knopfdruck Textstellen ab einer bestimmten
// Startposition in einem TRichEdit hervor. Man kann auch ganze Wörter markieren
// lassen, die eine bestimmte Silbe enthalten (ImmerGanzesWort = True). Bei
// Angabe der Zeichenfolge "es" wird dann beispielsweise "Test", "Wespe",
// "Schwester" usw. markiert. Der Wert von Wieviel legt fest, ob alle Vorkommen
// (Wieviel = -1) oder nur eine bestimmte Anzahl von Wörtern markiert wird.

uses Richedit; 
 
procedure TForm1.RichEdit1KeyDown(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
begin 
  with RichEdit1 do begin 
    SelAttributes.Color := DefAttributes.Color; 
    SelAttributes.style := DefAttributes.style; 
  end; 
end; 
 
function work(RE: TCustomRichedit; Txt: string; 
  Start, lg, gesamt: integer; Farbe: TColor; Stil: TFontStyles; 
  Art: TSearchTypes; Wieviel, Gefunden, Anfang: integer; 
  ImmerGanzesWort: boolean): integer; 
var i: integer; 
begin 
  result := gefunden; 
  with RE do begin 
    i := findtext(txt, start, gesamt - start, art); 
    if i < 0 then exit; 
    if immerganzeswort then begin 
      selstart := perform(EM_FINDWORDBREAK, WB_MOVEWORDLEFT, i + 1); 
      sellength := perform(EM_FINDWORDBREAK, WB_MOVEWORDRIGHT, 
        selstart) - selstart; 
    end else begin 
      selstart := i; 
      sellength := lg; 
    end; 
    if anfang <> selstart then begin 
      inc(result); 
      with SelAttributes do begin 
        Color := farbe; 
        Style := stil; 
      end; 
    end; 
  end; 
  if wieviel > 0 then dec(wieviel); 
  if wieviel <> 0 then 
    result := work(RE, txt, i + lg, lg, gesamt, farbe, stil, art, 
      wieviel, result, RE.selstart, ImmerGanzesWort); 
end; 
 
function Hervorheben(RE: TCustomRichedit; Txt: string; 
  Start: integer; Farbe: TColor; Stil: TFontStyles; Art: TSearchTypes; 
  Wieviel: integer; ImmerGanzesWort: boolean): integer; 
var gefunden: integer; 
begin 
  gefunden := 0; 
  result := work(RE, txt, start, length(txt), length(RE.text), farbe, stil, 
    art, wieviel, gefunden, -1, ImmerGanzesWort); 
  RE.selstart := RE.selstart + RE.sellength; 
  RE.setfocus; 
  RE.perform(EM_SCROLLCARET, 0, 0); 
end; 
 

// Beispielaufruf 

procedure TForm1.Button3Click(Sender: TObject); 
var 
  x: integer; 
  s: string; 
begin 
  x := hervorheben(richedit1, 'es', 0, clred, [fsBold], 
    [stMatchCase], -1, true); 
// [stMatchCase] = Groß- u. Kleinschreibung beachten 
// [stWholeWord] = nur ganze Wörter 
// [stWholeWord,stMatchCase] = beides beachten 
// [] = alles was gefunden wird, egal wie geschrieben 
  s := 'Textstelle'; 
  case x of 
    0: s := 'Keine ' + s; 
    1: s := 'Eine ' + s; 
  else s := inttostr(x) + #32 + s + 'n'; 
  end; 
  s := s + ' markiert.'; 
  showmessage(s); 
end;

// --------------------------------------------------------------

// Variante 1.1:

// Eine interessante Variante ist, die Buchstaben einzeln durchzugehen und
// zu entscheiden, zu welche Farbe sie gehören. Das bietet sich beispielsweise
// an, wenn viele Wörter eingefärbt werden müssen. Im Beispiel wird die Syntax
// eines HTML-Quellcode farbig gestaltet. Allerdings ist diese Methode langsam
// und Dateien ab 50 KB machen keinen Spaß mehr.

var 
  KommentarFarbe: TColor = clGray; 
  ScriptFarbe: TColor = clMaroon; 
  WertFarbe: TColor = clGreen; 
  TextFarbe: TColor = clBlack; 
  TagFarbe: TColor = clBlue; 
  stop: boolean; 
 
procedure HTMLSyntax(RE: TRichEdit; pgbr: TProgressBar); 
var 
  s: string; 
  isScr: byte; 
  Farbe: TColor; 
  i, lg: Integer; 
  isTag, isWert, isKomm, isGl, isFr: boolean; 
begin 
  lg := Length(RE.Text); 
  Farbe := TextFarbe; 
  pgbr.max := lg; 
  isKomm := false; 
  isWert := false; 
  isTag := false; 
  isGl := false; 
  isFr := false; 
  isScr := 0; 
  for i := 0 to lg - 1 do begin 
    pgbr.position := i; 
    Application.Processmessages; 
    if Application.terminated or stop then break; 
    RE.SelStart := i; 
    RE.SelLength := 1; 
    s := RE.SelText; 
    if not isKomm and (s = '<') then begin 
      if RE.Text[i + 2] = '?' 
        then begin 
        isScr := 2; 
        isFr := true; 
        Farbe := ScriptFarbe; 
      end else 
        if (lowercase(copy(RE.Text, i + 2, 6)) = 'script') 
          and (isScr < 2) then isScr := 1 else 
          if (lowercase(copy(RE.Text, i + 2, 7)) = '/script') 
            and not isFR then isScr := 0; 
      isKomm := copy(RE.Text, i + 2, 3) = '!--'; 
      isTag := not isKomm; 
    end; 
    if isScr < 2 then begin 
      if not isWert then begin 
        if isTag then Farbe := TagFarbe 
        else if isKomm then Farbe := KommentarFarbe 
        else Farbe := TextFarbe; 
      end; 
      if not isKomm then begin 
        if isGL and isTag then Farbe := WertFarbe; 
        if (s = '"') and (Farbe <> TextFarbe) then isWert := not isWert; 
        if isTag and isGL and ((s = ' ') or (RE.Text[i] = #13)) then begin 
          isGl := false; 
          Farbe := TagFarbe; 
        end else if isWert 
          then Farbe := WertFarbe; 
      end; 
    end; 
    if (s = '>') then begin 
      if not isKomm and (isScr < 2) then Farbe := TagFarbe; 
      if isFr and (RE.Text[i] = '?') then isScr := 0; 
      if isScr > 0 then isScr := 2; 
      isTag := false; 
      isWert := false; 
      isGl := false; 
      if isKomm and (copy(RE.Text, i - 1, 2) = '--') 
        then isKomm := false; 
    end; 
    RE.SelAttributes.Color := Farbe; 
    if isScr = 2 then Farbe := ScriptFarbe; 
    if (s = '=') and isTag then isGl := true; 
  end; 
  RE.SelLength := 0; 
  pgbr.position := 0; 
end; 
 
// --- Beispielaufruf --- 
 
// Laden eines HTML-Dokumentes 
 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  if OpenDialog1.execute then begin 
    Richedit1.scrollbars := ssBoth; 
    Richedit1.WordWrap := false; 
    Richedit1.Font.Name := 'Courier New'; 
    Richedit1.Font.Size := 10; 
    RichEdit1.Lines.BeginUpdate; 
    Richedit1.Lines.clear; 
    RichEdit1.DefAttributes.Color := TextFarbe; 
    RichEdit1.Lines.Loadfromfile(OpenDialog1.FileName); 
    RichEdit1.Lines.EndUpdate; 
  end; 
end; 
 
// Syntax highlight 
 
procedure TForm1.Button6Click(Sender: TObject); 
begin 
  TButton(Sender).enabled := false; 
  stop := false; 
  RichEdit1.Lines.BeginUpdate; 
  HTMLSyntax(RichEdit1, ProgressBar1); 
  RichEdit1.Lines.EndUpdate; 
  TButton(Sender).enabled := true; 
end; 
 
// abbrechen 
 
procedure TForm1.Button7Click(Sender: TObject); 
begin 
  stop := true; 
end;

// --------------------------------------------------------------

// Variante 1.2:

// Wesentlich schneller als Variante 1.1 arbeitet der folgende Code, obwohl
// sogar noch eine zusätzliche Farbe aufgenommen wurde. Die Prozedur
// manipuliert direkt den RTF-Quellcode. Allerdings könnte es eventl. zu
// Problemen kommen, wenn der Code mehrmals durchlaufen wird. Deshalb wird der
// HTML-Quellcode jedesmal neu geladen.

var 
  KommentarFarbe: TColor = clGray; 
  BezeichnerFarbe: TColor = clRed; 
  ScriptFarbe: TColor = clMaroon; 
  TagFarbe: TColor = clPurple; 
  TextFarbe: TColor = clBlack; 
  WertFarbe: TColor = clBlue; 
 
procedure SyntaxHTML(RE: TRichedit; Datei: string); 
const 
  tbl: array[0..11] of char = '{\colortbl ;'; 
  escrpt: array[0..8] of char = '</script>'; 
  scrpt: array[0..6] of char = '<script'; 
  kmm: array[0..3] of char = '<!--'; 
  ekmm: array[0..2] of char = '-->'; 
  efr: array[0..1] of char = '?>'; 
  fr: array[0..1] of char = '<?'; 
var 
  isScr, isWert, isTag, isDop: boolean; 
  farbstring: array[0..5] of string; 
  farbstrlg: array[0..5] of integer; 
  source, dest: TMemoryStream; 
  s, s2: string; 
  fi: integer; 
  p: PChar; 
  function StrColor(f: TColor): string; 
  begin 
    F := ColorToRGB(F); 
    result := '\red' + inttostr(getRvalue(F)) + 
      '\green' + inttostr(getGvalue(F)) + 
      '\blue' + inttostr(getBvalue(F)) + ';'; 
    farbstring[fi] := '\cf' + inttostr(succ(fi)) + #32; 
    farbstrlg[fi] := length(farbstring[fi]); 
    inc(fi); 
  end; 
  function Tabelle: boolean; 
  var 
    s: string; 
  begin 
    dest.writebuffer(tbl, 12); 
    s := StrColor(TextFarbe) + StrColor(TagFarbe) + StrColor(WertFarbe) + 
      StrColor(ScriptFarbe) + StrColor(KommentarFarbe) + 
      StrColor(BezeichnerFarbe); 
    dest.writebuffer(s[1], length(s)); 
    while not (p^ in ['}', #0]) do inc(p); 
    result := p^ = #0; 
  end; 
  function KommScrpt(fs, lg: integer; a: string; b: boolean): boolean; 
  begin 
    dest.writebuffer(farbstring[fs][1], farbstrlg[fs]); 
    setlength(s2, lg); 
    repeat 
      if p^ = #0 then break; 
      dest.writebuffer(p^, 1); 
      inc(p); 
      copymemory(@s2[1], p, lg); 
      if lowercase(s2) = a then begin 
        if b then dest.writebuffer(farbstring[1][1], farbstrlg[1]); 
        dest.writebuffer(p^, lg); 
        inc(p, lg); 
        break; 
      end; 
    until p^ = #0; 
    result := p^ = #0; 
    if not result then begin 
      if not b and comparemem(p, @kmm, 4) then 
        KommScrpt(4, 3, ekmm, false) 
      else if (p^ = '<') then 
        dest.writebuffer(farbstring[1][1], farbstrlg[1]) else 
        dest.writebuffer(farbstring[0][1], farbstrlg[0]); 
    end; 
  end; 
  function script: boolean; 
  begin 
    isScr := false; 
    dest.writebuffer(p^, 1); 
    inc(p); 
    result := p^ = #0; 
    if not result 
      then result := KommScrpt(3, 9, escrpt, true); 
  end; 
  function Frgzchn: boolean; 
  begin 
    result := KommScrpt(3, 2, efr, false); 
  end; 
  function kommentar: boolean; 
  begin 
    result := KommScrpt(4, 3, ekmm, false); 
  end; 
begin 
  isScr := false; 
  isTag := false; 
  isWert := false; 
  isDop := false; 
  setlength(s, 7); 
  RE.Lines.BeginUpdate; 
  RE.Lines.clear; 
  RE.DefAttributes.Color := TextFarbe; 
  RE.Lines.Loadfromfile(Datei); 
  RE.PlainText := false; 
  source := TMemoryStream.create; 
  dest := TMemoryStream.create; 
  RE.Lines.SaveToStream(source); 
  dest.size := source.size; 
  p := source.Memory; 
  fi := 0; 
  repeat 
    if p^ = #0 then break; 
    if comparemem(p, @tbl, 12) then 
      if tabelle then break; 
    if p^ = '<' then begin 
      copymemory(@s[1], p, 7); 
      if lowercase(s) = scrpt then begin 
        dest.writebuffer(farbstring[1][1], farbstrlg[1]); 
        isScr := true; 
        isTag := true; 
      end else 
        if comparemem(p, @fr, 2) then begin 
          if Frgzchn then break; 
        end else 
          if not isScr and comparemem(p, @kmm, 4) then begin 
            if kommentar then break; 
            copymemory(@s[1], p, 7); 
            if lowercase(s) = scrpt then begin 
              isScr := true; 
              isTag := true; 
            end; 
          end else begin 
            dest.writebuffer(farbstring[1][1], farbstrlg[1]); 
            isTag := true; 
          end; 
    end else 
      if isTag and (p^ = '=') then begin 
        dest.writebuffer(p^, 1); 
        inc(p); 
        if p^ = #0 then break; 
        dest.writebuffer(farbstring[2][1], farbstrlg[2]); 
        isWert := true; 
        if p^ = '"' then begin 
          isDop := not isDop; 
          dest.writebuffer(p^, 1); 
          inc(p); 
          if p^ = #0 then break; 
        end; 
      end else 
        if (p^ = '"') and isTag then begin 
          isDop := not isDop; 
          if not isWert then 
            dest.writebuffer(farbstring[2][1], farbstrlg[2]); 
          dest.writebuffer(p^, 1); 
          inc(p); 
          if p^ = #0 then break; 
          if (p^ = ' ') and not isDop then 
            dest.writebuffer(farbstring[5][1], farbstrlg[5]) else 
            if isWert then 
              dest.writebuffer(farbstring[1][1], farbstrlg[1]); 
          isWert := false; 
        end else 
          if isTag and (p^ = ' ') and ((p - 1)^ <> ' ') 
            then begin 
            if not isDop then 
              dest.writebuffer(farbstring[5][1], farbstrlg[5]); 
            isWert := false; 
          end; 
    if p^ = '>' then begin 
      dest.writebuffer(farbstring[1][1], farbstrlg[1]); 
      if isScr then begin 
        if script then break; 
      end else begin 
        isScr := false; 
        isTag := false; 
        isWert := false; 
        dest.writebuffer(p^, 1); 
        inc(p); 
        if p^ = #0 then break; 
        if p^ <> '<' then 
          dest.writebuffer(farbstring[0][1], farbstrlg[0]) 
        else continue; 
      end; 
    end; 
    dest.writebuffer(p^, 1); 
    inc(p); 
  until false; 
  source.free; 
  RE.MaxLength := dest.size; 
  dest.position := 0; 
  RE.Lines.LoadFromStream(dest); 
  dest.free; 
  RE.Lines.EndUpdate; 
end; 


// Beispielaufruf  

procedure TForm1.Button7Click(Sender: TObject); 
begin 
  if OpenDialog1.execute then begin 
    Screen.cursor := crHourGlass; 
    TButton(Sender).enabled := false; 
    Richedit1.scrollbars := ssBoth; 
    Richedit1.WordWrap := false; 
    Richedit1.Font.Name := 'Courier New'; 
    Richedit1.Font.Size := 10; 
    SyntaxHTML(Richedit1, OpenDialog1.Filename); 
    TButton(Sender).enabled := true; 
    Screen.cursor := crDefault; 
  end; 
end;

// --------------------------------------------------------------

// Variante 2: Ganze Wörter während des Schreibens hervorheben

// Dieser Code ändert die Farbe bestimmter Wörter während des
// Schreibvorganges, wenn die Variable Farbe = True ist.
// Ich habe zur Demonstration die Syntax von SQL-Befehlen verwendet.

uses Richedit; 
 
const 
  gruppenzahl = 4; 
  Farben: array[0..pred(gruppenzahl)] of TColor = 
  (clBlue, clGreen, clRed, clMaroon); 
  Standard = clBlack; 
 
var 
  Farbe: boolean = true; 
 
  gruppe: array[0..pred(gruppenzahl)] of TStringlist; 
  start, ende: integer; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  x: integer; 
begin 
  Richedit1.Lines.Clear; 
  Richedit1.Color := clWhite; 
  Richedit1.DefAttributes.Color := Standard; 
  for x := 0 to pred(gruppenzahl) do gruppe[x] := TStringlist.create; 
  gruppe[0].add('SELECT'); 
  gruppe[0].add('FROM'); 
  gruppe[0].add('WHERE'); 
  gruppe[0].add('IS'); 
  gruppe[0].add('IN'); 
  gruppe[0].add('AS'); 
  gruppe[0].add('NOT'); 
  gruppe[0].add('AND'); 
  gruppe[0].add('OR'); 
  gruppe[0].add('ORDER'); 
  gruppe[0].add('BY'); 
 
  gruppe[1].add('COUNT'); 
  gruppe[1].add('UPPER'); 
  gruppe[1].add('LOWER'); 
  gruppe[1].add('AVG'); 
  gruppe[1].add('MIN'); 
  gruppe[1].add('MAX'); 
  gruppe[1].add('SUM'); 
  gruppe[1].add('AUTOINC'); 
  gruppe[1].add('CHAR'); 
  gruppe[1].add('CHARACTER'); 
  gruppe[1].add('SMALLINT'); 
  gruppe[1].add('INTEGER'); 
  gruppe[1].add('BYTES'); 
  gruppe[1].add('FLOAT'); 
  gruppe[1].add('MONEY'); 
  gruppe[1].add('BOOLEAN'); 
  gruppe[1].add('DATE'); 
  gruppe[1].add('TIME'); 
  gruppe[1].add('EXTRACT'); 
  gruppe[1].add('MONTH'); 
  gruppe[1].add('YEAR'); 
  gruppe[1].add('DAY'); 
  gruppe[1].add('HOUR'); 
  gruppe[1].add('MINUTE'); 
  gruppe[1].add('SECONDS'); 
 
  gruppe[2].add('UPDATE'); 
  gruppe[2].add('SET'); 
  gruppe[2].add('DELETE'); 
  gruppe[2].add('INSERT'); 
  gruppe[2].add('INTO'); 
  gruppe[2].add('VALUES'); 
  gruppe[2].add('='); 
  gruppe[2].add('>'); 
  gruppe[2].add('<'); 
  gruppe[2].add('!'); 
 
  gruppe[3].add('CREATE'); 
  gruppe[3].add('TABLE'); 
  gruppe[3].add('INDEX'); 
  gruppe[3].add('ON'); 
  gruppe[3].add('ALTER'); 
  gruppe[3].add('ADD'); 
  gruppe[3].add('DROP'); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  x: integer; 
begin 
  for x := 0 to pred(gruppenzahl) do gruppe[x].free; 
end; 
 
function GetColor(s: string): TColor; 
var 
  x: integer; 
begin 
  if Farbe then 
    for x := 0 to pred(gruppenzahl) do 
      if gruppe[x].IndexOf(s) >= 0 then 
      begin 
        Result := Farben[x]; 
        exit; 
      end; 
  Result := Standard; 
end; 
 
function GetTextRange(RE: TRichEdit; Max: Integer): string; 
var 
  TextRange: TTextRange; 
  p: integer; 
begin 
  if Max > 0 then 
  begin 
    SetLength(Result, Max); 
    with TextRange do 
    begin 
      chrg.cpMin := start; 
      chrg.cpMax := start + Max; 
      lpstrText := PChar(Result); 
    end; 
    SetLength(Result, 
      SendMessage(RE.Handle, EM_GETTEXTRANGE, 0, longint(@TextRange))); 
    Result := Trim(Result); 
    p := lastdelimiter(#13, Result); 
    if p > 0 then begin 
      delete(Result, 1, p + 1); 
      inc(start, p + 1); 
    end; 
  end else Result := ''; 
end; 
 
function GetWord(RE: TRichedit; versatz: integer): string; 
begin 
  start := RE.Perform(EM_FINDWORDBREAK, WB_LEFT, pred(RE.Selstart) - versatz); 
  ende := RE.Perform(EM_FINDWORDBREAK, WB_MOVEWORDRIGHT, RE.Selstart - versatz); 
  Result := GetTextRange(RE, ende - start); 
end; 
 
procedure MakeColor(RE: TRichedit; f: TColor); 
var 
  merk: integer; 
begin 
  merk := RE.Selstart; 
  RE.Selstart := start; 
  RE.Sellength := ende - start; 
  RE.SelAttributes.Color := f; 
  RE.Selstart := merk;                         
  RE.Sellength := 0; 
  RE.SelAttributes.Color := Standard; 
end; 
 
procedure space(RE: TRichedit); 
var 
  p: TPoint; 
begin 
  p := RE.CaretPos; 
  if RE.lines[p.y][p.x + 1] > #32 then 
    MakeColor(RE, GetColor(GetWord(RE, 1))); 
end; 
 
procedure TForm1.RichEdit1KeyUp(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
begin 
  MakeColor(TRichedit(sender), GetColor(GetWord(TRichedit(sender), 0))); 
  if key = 32 then space(TRichedit(sender)); 
end;