...Text in einem TMemo hervorheben?

Autor: Gon Perez-Jimenez

Kategorie: Oberfläche

(**
  *  Highlight with TMemo Impossible?  try this...
  *                                                by Gon Perez-Jimenez May'04
  *
  *  This is a sample how to work with highlighting within TMemo component by
  *  using interjected class technique.
  *
  *  Of course, this code is still uncompleted but it works fine for my
  *  purposes, so, hope you can improve it and use it.
  *
  *  Drop onto your TForm (Form1), a TMemo (Memo1), a TLabel (Label1)
  *  and a TListBox (KeywordList)
  *
  *  Insert in the TListBox Items some Pascal keywords in lowercase !!!
  *
  *  That's all!  Enjoy
  *)

unit Unit1;

interface

uses
  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls;

type
  
// Interjected Class
  
TMemo = class(stdctrls.TMemo)
  private
    procedure 
WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
    procedure WMVScroll(var Message: TWMMove); message WM_VSCROLL;
    procedure WMMousewheel(var Message: TWMMove); message WM_MOUSEWHEEL;
  protected
    procedure 
Change; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
  public
    
PosLabel: TLabel;
    procedure Update_label;
    procedure GotoXY(mCol, mLine: Integer);
    function Line: Integer;
    function Col: Integer;
    function TopLine: Integer;
    function VisibleLines: Integer;
  end;


  TForm1 = class(TForm)
    Memo1: TMemo;
    Label1: TLabel;
    KeywordList: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure Memo1KeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    
{ Private declarations }
  
public
    
{ Public declarations }
  
end;

var
  
Form1: TForm1;

implementation

{$R *.DFM}

////////////////////////////////////////////////////////////////////////////////
// functions for managing keywords and numbers of each line of TMemo ///////////
////////////////////////////////////////////////////////////////////////////////
function IsSeparator(Car: Char): Boolean;
begin
  case 
Car of
    
'.', ';', ',', ':', '¡', '!', '·', '"', '''', '^', '+', '-', '*', '/', '\', '¨', ' ',
    '`', '[', ']', '(', ')', 'º', 'ª', '{', '}', '?', '¿', '%', '=': Result := True;
    else
      
Result := False;
  end;
end;
////////////////////////////////////////////////////////////////////////////////

function NextWord(var s: stringvar PrevWord: string): string;
begin
  
Result   := '';
  PrevWord := '';
  if s = '' then Exit;
  while (s <> '') and IsSeparator(s[1]) do 
  begin
    
PrevWord := PrevWord + s[1];
    Delete(s, 1,1);
  end;
  while (s <> '') and not IsSeparator(s[1]) do 
  begin
    
Result := Result + s[1];
    Delete(s, 1,1);
  end;
end;
////////////////////////////////////////////////////////////////////////////////

function IsKeyWord(s: string): Boolean;
begin
  
Result := False;
  if s = '' then Exit;
  Result := Form1.KeywordList.Items.IndexOf(lowercase(s)) <> -1;
end;
////////////////////////////////////////////////////////////////////////////////

function IsNumber(s: string): Boolean;
var 
  
i: Integer;
begin
  
Result := False;
  for i := 1 to Length(s) do
    case 
s[i] of
      
'0'..'9':;
      else 
        
Exit;
    end;
  Result := True;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// New or overrided methods and properties for TMemo using Interjected Class ///
// Technique ///////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

function TMemo.VisibleLines: Integer;
begin
  
Result := Height div (Abs(Self.Font.Height) + 2);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.GotoXY(mCol, mLine: Integer);
begin
  
Dec(mLine);
  SelStart  := 0;
  SelLength := 0;
  SelStart  := mCol + Self.Perform(EM_LINEINDEX, mLine, 0);
  SelLength := 0;
  SetFocus;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.Update_label;
begin
  if 
PosLabel = nil then Exit;
  PosLabel.Caption := '(' + IntToStr(Line + 1) + ',' + IntToStr(Col) + ')';
end;
////////////////////////////////////////////////////////////////////////////////

function TMemo.TopLine: Integer;
begin
  
Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end;
////////////////////////////////////////////////////////////////////////////////

function TMemo.Line: Integer;
begin
  
Result := SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0);
end;
////////////////////////////////////////////////////////////////////////////////

function TMemo.Col: Integer;
begin
  
Result := Self.SelStart - SendMessage(Self.Handle, EM_LINEINDEX,
    SendMessage(Self.Handle,
    EM_LINEFROMCHAR, Self.SelStart, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMVScroll(var Message: TWMMove);
begin
  
Update_label;
  Invalidate;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMSize(var Message: TWMSize);
begin
  
Invalidate;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMMove(var Message: TWMMove);
begin
  
Invalidate;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMMousewheel(var Message: TWMMove);
begin
  
Invalidate;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.Change;
begin
  
Update_label;
  Invalidate;
  inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);
begin
  
Update_label;
  inherited KeyDown(Key, Shift);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.KeyUp(var Key: Word; Shift: TShiftState);
begin
  
Update_label;
  inherited KeyUp(Key, Shift);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  
Update_label;
  inherited MouseDown(Button, Shift, X, Y);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  
Update_label;
  inherited MouseUp(Button, Shift, X, Y);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMPaint(var Message: TWMPaint);
var
  
PS: TPaintStruct;
  DC: HDC;
  Canvas: TCanvas;
  i: Integer;
  X, Y: Integer;
  OldColor: TColor;
  Size: TSize;
  Max: Integer;
  s, Palabra, PrevWord: string;
begin
  
DC := Message.DC;
  if DC = 0 then DC := BeginPaint(Handle, PS);
  Canvas := TCanvas.Create;
  try
    
OldColor         := Font.Color;
    Canvas.Handle    := DC;
    Canvas.Font.Name := Font.Name;
    Canvas.Font.Size := Font.Size;
    with Canvas do 
    begin
      
Max := TopLine + VisibleLines;
      if Max > Pred(Lines.Count) then Max := Pred(Lines.Count);

      //Limpio la sección visible
      
Brush.Color := Self.Color;
      FillRect(Self.ClientRect);
      Y := 1;
      for i := TopLine to Max do 
      begin
        
X := 2;
        s := Lines[i];

        //Detecto todas las palabras de esta línea
        
Palabra := NextWord(s, PrevWord);
        while Palabra <> '' do 
        begin
          
Font.Color := OldColor;
          TextOut(X, Y, PrevWord);
          GetTextExtentPoint32(DC, PChar(PrevWord), Length(PrevWord), Size);
          Inc(X, Size.cx);

          Font.Color := clBlack;
          if IsKeyWord(Palabra) then 
          begin
            
Font.Color := clHighlight;
            TextOut(X, Y, Palabra);
             {
             //Draw dot underline
             Pen.Color := clHighlight;
             Pen.Style := psDot;
             PolyLine([ Point(X,Y+13), Point(X+TextWidth(Palabra),Y+13)]);
             }
          
end 
          else if 
IsNumber(Palabra) then 
          begin
            
Font.Color := $000000DD;
            TextOut(X, Y, Palabra);
          end 
          else
            
TextOut(X, Y, Palabra);

          GetTextExtentPoint32(DC, PChar(Palabra), Length(Palabra), Size);
          Inc(X, Size.cx);

          Palabra := NextWord(s, PrevWord);
          if (s = '') and (PrevWord <> '') then 
          begin
            
Font.Color := OldColor;
            TextOut(X, Y, PrevWord);
          end;
        end;
        if (s = '') and (PrevWord <> '') then 
        begin
          
Font.Color := OldColor;
          TextOut(X, Y, PrevWord);
        end;

        s := 'W';
        GetTextExtentPoint32(DC, PChar(s), Length(s), Size);
        Inc(Y, Size.cy);
      end;
    end;
  finally
    if Message
.DC = 0 then EndPaint(Handle, PS);
  end;
  Canvas.Free;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Procedures for Form1 ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
  
Memo1.PosLabel := Label1;
  Memo1.Update_label;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if 
Key = VK_F1 then Memo1.Invalidate;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  
Action := caFree;
end;
////////////////////////////////////////////////////////////////////////////////

end.

 

printed from
www.swissdelphicenter.ch
developers knowledge base