unit HxMemof;

interface

uses
 SysUtils, Windows, Messages, Classes, Controls, StdCtrls, Graphics, Math,
 ComCtrls, ShellApi, Dialogs, Masks;

type
 TOnKeyWord = procedure(Sender: TObject; word: string;
   var AIsKeyWord: boolean) of object;

 THxMemo = class(TMemo)
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
 private
   { Private declarations }
   FOnKeyWord: TOnKeyWord;
   FImage:     TBitmap;
   FIsTelnet:  boolean;
   FHighlightURL: boolean;
   FAnnounceColor: TColor;
   FWWVColor: TColor;
   FMessagesColor: TColor;
   function GetRow: integer;
   procedure SetRow(Value: integer);
   function GetCol: integer;
   procedure SetCol(Value: integer);
   function GetPosn: longint;
   procedure SetPosn(Value: longint);
 protected
   { Protected declarations }
   procedure CreateWnd; override;
   procedure WMPaint(var message: TWMPaint); message WM_PAINT;
   procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
   procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
   procedure WMLBUTTONDBLCLK(var Message: TMessage); message WM_LBUTTONDBLCLK;
   procedure WMLButtonDown(var Message: TWMLButtonUp); message WM_LBUTTONDOWN;
   procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
   procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
   procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;

 public
   { Public declarations }
   FirstVisibleLine, VisibleLineCount: integer;
   property Row: integer Read GetRow Write SetRow;
   property Col: integer Read GetCol Write SetCol;
   property Posn: longint Read GetPosn Write SetPosn;
   procedure RedrawCaret;
   function GetXYFromPosn(Value: longint): TPoint;
   function GetCaretPosFromXY(P: TPoint): integer;
   function GetCaretIndex: integer;
   function GetTextHeight: integer;
   function IsURL(S: string): boolean;
 published
   { Published declarations }
   property OnKeyWord: TOnKeyWord Read FOnKeyWord Write FOnKeyWord;
   property IsTelnetMemo: boolean Read FIsTelnet Write FIsTelnet;
   property HighlightURL: boolean Read FHighlightURL Write FHighlightURL;
   property AnnounceColor: TColor Read FAnnounceColor Write FAnnounceColor;
   property WWVColor: TColor Read FWWVColor Write FWWVColor;
   property MessagesColor: TColor Read FMessagesColor Write FMessagesColor;
 end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents('HxComp', [THxMemo]);
end;

function WidthOf(R: TRect): integer;
begin
 Result := R.Right - R.Left;
end;

function HeightOf(R: TRect): integer;
begin
 Result := R.Bottom - R.Top;
end;

constructor THxMemo.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 // Уменьшение мерцания
 ControlStyle := ControlStyle + [csOpaque];
 WordWrap := True;
 DoubleBuffered := False;
 IsTelnetMemo := False;
 HighlightURL := False;
 FImage := TBitmap.Create;
 FAnnounceColor := clGreen;
 FWWVColor := clRed;
 FMessagesColor := clBlue;
end;

destructor THxMemo.Destroy;
begin
 FImage.Free;
 inherited Destroy;
end;

procedure THxMemo.CreateWnd;
begin
 inherited CreateWnd;
 Windows.HideCaret(Handle);
end;

procedure THxMemo.WMPaint(var Message: TWMPaint);
var
 LineNumerOut, j, dy, dx: integer;
 // Начало и длинна выделения в строке
 SStart, SLength: integer;
 PS: TPaintStruct;
 DC: HDC;
 str, StrWord: string;
 IsKeyWord: boolean;

 procedure SelectText;
 var
   S1, S2: string;
 begin
   S1 := copy(str, 1, SStart);
   S2 := copy(str, Sstart + 1, SLength);

   with FImage.Canvas do
   begin
     Brush.Color := clHighlight;
     Font.Color  := clWhite;
     //Font.Style := [];
     TextOut(1 + FImage.Canvas.TextWidth(S1), dy, S2);
     Brush.Color := (Self as THxMemo).Color;
     Font := (Self as THxMemo).Font;
   end;
 end;

 procedure GetSelStartSelLength(PS, PE: TPoint);
 begin
   // Если это строка совпадает с линией начала выделения
   if PS.Y = LineNumerOut then
   begin
     SStart := PS.X;
     // Если выделение оканчивается на этой строке
     if PE.Y = LineNumerOut then
       SLength := PE.X - PS.X
     else
       SLength := Length(str) - PS.X;
   end
   else
   begin
     SStart := 0;
     // Если выделение оканчивается на этой строке
     if PE.Y = LineNumerOut then
       SLength := PE.X
     else
       SLength := Length(str);
   end;
 end;

 function SelInLine: boolean;
 var
   PS, PE: TPoint;
 begin
   if SelLength = 0 then
     Result := False
   else
   begin
     PS := GetXYFromPosn(SelStart);
     PE := GetXYFromPosn(SelStart + SelLength);
     if LineNumerOut in [(PS.Y)..(PE.Y)] then
     begin
       GetSelStartSelLength(PS, PE);
       Result := True;
     end
     else
       Result := False;
   end;
 end;

 procedure HeightlightingURL(TypeURL: string);
 var
   URLStart, URLEnd, FromStartStr: integer;
   URLStr, S1, S2: string;
 begin
   S2 := str;
   FromStartStr := 1;
   // Если встроке много URL
   while Length(S2) > 3 do
   begin
     URLStart := Pos(TypeURL, S2);
     // Получаем строку с URL
     if URLStart > 0 then
     begin
       URLStr := '';
       URLEnd := URLStart;
       while (Length(S2) >= URLEnd) and (S2[URLEnd] <> ' ') and
         (S2[URLEnd] <> Chr(10)) and (S2[URLEnd] <> Chr(13)) do
       begin
         URLStr := URLStr + S2[URLEnd];
         Inc(URLEnd);
       end;

       // Строка перед URL
       S1 := copy(S2, 1, URLStart - 1);
       // Оставшаяся часть строки
       S2 := copy(S2, URLEnd, Length(S2) - URLEnd + 1);
       with FImage.Canvas do
       begin
         Brush.Color := (Self as THxMemo).Color;
         Font.Color  := clBlue;
         Font.Style  := Font.Style + [fsUnderline];
         TextOut(FromStartStr + FImage.Canvas.TextWidth(S1), dy, URLStr);
         Brush.Color  := (Self as THxMemo).Color;
         Font := (Self as THxMemo).Font;
         // Перемещаемся в конец выведеного URL для вывода следующего URL
         FromStartStr :=
           FromStartStr + FImage.Canvas.TextWidth(S1) +
           FImage.Canvas.TextWidth(URLStr);
       end;
     end
     else
       Exit;
   end;
 end;

 function IsMessage(S: string): boolean;
 var
   Mask: TMask;
 begin
   result := false;
   if Pos('WWV', S) = 1 then
     Exit;
   Mask := TMask.Create('* DE *:*');
   result := Mask.Matches(S);
   Mask.Free;
 end;

begin
 DC := Message.DC;
 if DC = 0 then
   DC := BeginPaint(Handle, PS);
 try
   FImage.Handle := CreateCompatibleBitmap(DC,
     WidthOf(ClientRect), HeightOf(ClientRect));

   FImage.Canvas.Brush.Color := Color;

   FImage.Canvas.FillRect(ClientRect);
   FImage.Canvas.Font.Assign(Font);

   // Первая видимая строка
   FirstVisibleLine := Self.Perform(EM_GETFIRSTVISIBLELINE, 0, 0);
   // Всего видимых строк
   VisibleLineCount := Height div FImage.Canvas.TextHeight('X');

   with FImage.Canvas do
   begin
     dy := 1;
     for LineNumerOut :=
       FirstVisibleLine to Math.Min(Lines.Count - 1, FirstVisibleLine + VisibleLineCount - 1) do

       //Перебираем строки Memo
     begin
       HideCaret(Handle);
       str := Lines[LineNumerOut];

       // Если это телнет
       if IsTelnetMemo then
       begin
         StrWord := copy(str, 0, 5);
         if (StrWord = 'DX de') and (Length(str) > 39) then
         begin
           dx := 1;

           StrWord     := copy(str, 0, 26);
           Brush.Color := (Self as THxMemo).Color;
           Font := (Self as THxMemo).Font;
           TextOut(dx, dy, StrWord);
           dx := dx + TextWidth(StrWord);

           StrWord     := copy(str, 27, 13);
           Brush.Color := clYellow;
           Font.Color  := clRed;
           Font.Style  := [fsBold];
           TextOut(dx, dy, StrWord);
           dx := dx + TextWidth(StrWord);

           StrWord     := copy(str, 40, Length(str) - 39);
           Brush.Color := (Self as THxMemo).Color;
           Font := (Self as THxMemo).Font;
           TextOut(dx, dy, StrWord);
         end
         else if Pos('To ALL', str) = 1 then
         begin
           Brush.Color := (Self as THxMemo).Color;
           Font := (Self as THxMemo).Font;
           Font.Color := FAnnounceColor;
           TextOut(1, dy, str);
         end
         else if Pos('WWV', str) = 1 then
         begin
           Brush.Color := (Self as THxMemo).Color;
           Font := (Self as THxMemo).Font;
           Font.Color := FWWVColor;
           TextOut(1, dy, str);
         end
         else if IsMessage(str) then
         begin
           Brush.Color := (Self as THxMemo).Color;
           Font := (Self as THxMemo).Font;
           Font.Color := FMessagesColor;
           TextOut(1, dy, str);
         end
         else
         begin
           Brush.Color := (Self as THxMemo).Color;
           Font := (Self as THxMemo).Font;
           TextOut(1, dy, str);
         end;
       end
       // иначе просто выводим
       else
       begin
         StrWord := '';
         dx := 1;
         j := 1;
         while j <= Length(str) do
         begin
           // Если не пробел и не окончание строки - добавляем в слово
           while (j <= Length(str)) and (str[j] <> ' ') do
           begin
             StrWord := StrWord + str[j];
             Inc(j);
           end;

           // Проверка на ключевое слово
           if Assigned(FOnKeyWord) then
             FOnKeyWord(Self, StrWord, IsKeyWord)
           else
             IsKeyWord := False;

           if IsKeyWord then
           begin
             Font.Color := clRed;
             //Font.Style := [];
           end
           else
           begin
             Font.Color := (Self as THxMemo).Font.Color;
             //Font.Style := [];
           end;
           // Выводим слово
           TextOut(dx, dy, StrWord);
           // Перемещаемся на следующую позицию
           dx      := dx + TextWidth(StrWord);
           // Восстанавливаем основной цвет
           Font.Color := (Self as THxMemo).Font.Color;
           StrWord := '';

           // Если символ - пробел, выводим его
           if (j <= Length(str)) and (str[j] = ' ') then
           begin
             TextOut(dx, dy, ' ');
             dx := dx + TextWidth(' ');
             Inc(j);
           end;
         end;
       end;
       // Окончание вывода

       // Подсветка URL
       if HighlightURL then
       begin
         HeightlightingURL('http://');
         HeightlightingURL('www.');
         HeightlightingURL('ftp://');
         HeightlightingURL('ftp.');
       end;
       // Проверка на выделение
       if (SelLength <> 0) and SelInLine then
         SelectText;
       // Перемещаемся на следующую строку
       dy := dy + TextHeight('X');
     end;
   end;
   BitBlt(DC, 0, 0, FImage.Width, FImage.Height, FImage.Canvas.Handle,
     0, 0, SRCCOPY);
 finally
   if Message.DC = 0 then
     EndPaint(Handle, PS);
 end;
end;