fr_synmemo.pas

FASTREPORT报表工具,可以迅速制作报表.

{******************************************}
{                                          }
{             FastReport v3.0              }
{           Syntax memo control            }
{                                          }
{ Copyright (c) 1998-2002 by Tzyganenko A. }
{                                          }
{******************************************}

unit FR_SynMemo;

interface

{$I FR.inc}

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

type

{ Simple syntax highlighter. Supports Pascal and SQL syntax.

  Assign text to Text property.
  Assign desired value to SyntaxType property.
  Call SetPos to move caret.
  Call ShowMessage to display an error message at the bottom.
}

  TSyntaxType = (stPascal, stSQL, stText);
  TCharAttr = (caText, caBlock, caComment, caKeyword, caString);
  TCharAttributes = set of TCharAttr;

  TSyntaxMemo = class(TCustomControl)
  private
    FAllowLinesChange: Boolean;
    FBlockColor: TColor;
    FBlockFontColor: TColor;
    FBusy: Boolean;
    FCharHeight: Integer;
    FCharWidth: Integer;
    FCommentAttr: TFont;
    FDown: Boolean;
    FIsMonoType: Boolean;
    FKeywordAttr: TFont;
    FKeywords: String;
    FMaxLength: Integer;
    FMessage: String;
    FMoved: Boolean;
    FOffset: TPoint;
    FPos: TPoint;
    FReadOnly: Boolean;
    FSelEnd: TPoint;
    FSelStart: TPoint;
    FStringAttr: TFont;
    FSyn: String;
    FSyntaxType: TSyntaxType;
    FTempPos: TPoint;
    FText: TStringList;
    FTextAttr: TFont;
    FUndo: TStringList;
    FVScroll: TScrollBar;
    FWindowSize: TPoint;

    function GetText: TStrings;
    procedure SetText(Value: TStrings);
    procedure SetSyntaxType(Value: TSyntaxType);

    function GetCharAttr(Pos: TPoint; Pos1: Integer): TCharAttributes;
    function GetLineBegin(Index: Integer): Integer;
    function GetPlainTextPos(Pos: TPoint): Integer;
    function GetPosPlainText(Pos: Integer): TPoint;
    function GetSelText: String;
    function LineAt(Index: Integer): String;
    function LineLength(Index: Integer): Integer;
    function Pad(n: Integer): String;
    procedure AddSel;
    procedure AddUndo;
    procedure ClearSel;
    procedure CreateSynArray;
    procedure EnterIndent;
    procedure SetSelText(Value: String);
    procedure ShiftSelected(ShiftRight: Boolean);
    procedure ShowCaretPos;
    procedure TabIndent;
    procedure Undo;
    procedure UnIndent;
    procedure UpdateScrollBar;
    procedure UpdateSyntax;

    procedure DoLeft;
    procedure DoRight;
    procedure DoUp;
    procedure DoDown;
    procedure DoHome(Ctrl: Boolean);
    procedure DoEnd(Ctrl: Boolean);
    procedure DoPgUp;
    procedure DoPgDn;
    procedure DoChar(Ch: Char);
    procedure DoReturn;
    procedure DoDel;
    procedure DoBackspace;
    procedure DoCtrlI;
    procedure DoCtrlU;

    procedure ScrollClick(Sender: TObject);
    procedure ScrollEnter(Sender: TObject);
    procedure LinesChange(Sender: TObject);
  protected
    { Windows-specific stuff }
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    { End of stuff }

    procedure SetParent(AParent: TWinControl); override;
    function GetClientRect: TRect; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure Paint; override;

    procedure CopyToClipboard;
    procedure CutToClipboard;
    procedure PasteFromClipboard;
    procedure SetPos(x, y: Integer);
    procedure ShowMessage(s: String);

    property BlockColor: TColor read FBlockColor write FBlockColor;
    property BlockFontColor: TColor read FBlockFontColor write FBlockFontColor;
    property CommentAttr: TFont read FCommentAttr write FCommentAttr;
    property KeywordAttr: TFont read FKeywordAttr write FKeywordAttr;
    property StringAttr: TFont read FStringAttr write FStringAttr;
    property TextAttr: TFont read FTextAttr write FTextAttr;
    property Color;
    property Font;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property ReadOnly: Boolean read FReadOnly write FReadOnly;
    property SelText: String read GetSelText write SetSelText;
    property SyntaxType: TSyntaxType read FSyntaxType write SetSyntaxType;
    property Lines: TStrings read GetText write SetText;
  end;


implementation

uses Clipbrd;

const
  PasKeywords =
     'and,array,as,begin,case,class,const,constructor,destructor,div,'+
     'do,downto,else,end,except,finally,for,forward,function,goto,if,'+
     'is,in,inherited,label,mod,nil,not,object,of,on,or,override,'+
     'private,procedure,program,property,protected,public,raise,record,'+
     'repeat,set,shl,shr,string,then,to,try,type,until,uses,var,'+
     'virtual,while,with,xor';

  SQLKeywords =
    'active,after,all,alter,and,any,as,asc,ascending,at,auto,' +
    'base_name,before,begin,between,by,cache,cast,check,column,commit,' +
    'committed,computed,conditional,constraint,containing,count,create,' +
    'current,cursor,database,debug,declare,default,delete,desc,descending,' +
    'distinct,do,domain,drop,else,end,entry_point,escape,exception,execute,' +
    'exists,exit,external,extract,filter,for,foreign,from,full,function,' +
    'generator,grant,group,having,if,in,inactive,index,inner,insert,into,is,' +
    'isolation,join,key,left,level,like,merge,names,no,not,null,of,on,only,' +
    'or,order,outer,parameter,password,plan,position,primary,privileges,' +
    'procedure,protected,read,retain,returns,revoke,right,rollback,schema,' +
    'select,set,shadow,shared,snapshot,some,suspend,table,then,to,' +
    'transaction,trigger,uncommitted,union,unique,update,user,using,view,' +
    'wait,when,where,while,with,work';

type
  THackScrollBar = class(TScrollBar)
  end;


{ TSyntaxMemo }

constructor TSyntaxMemo.Create(AOwner: TComponent);
begin
  inherited;
{$IFDEF Delphi4}
  DoubleBuffered := True;
{$ENDIF}
  FVScroll := TScrollBar.Create(Self);
  FVScroll.Parent := Self;
  FVScroll.Kind := sbVertical;
  FVScroll.OnChange := ScrollClick;
  FVScroll.OnEnter := ScrollEnter;

  FText := TStringList.Create;
  FUndo := TStringList.Create;
  FText.Add('');
  FText.OnChange := LinesChange;
  FMaxLength := 1024;
  SyntaxType := stPascal;
  FMoved := True;
  SetPos(1, 1);

  Cursor := crIBeam;
  Font.Size := 10;
  Font.Name := 'Courier New';

  FBlockColor := clHighlight;
  FBlockFontColor := clHighlightText;

  FCommentAttr := TFont.Create;
  FCommentAttr.Color := clNavy;
  FCommentAttr.Style := [fsItalic];

  FKeywordAttr := TFont.Create;
  FKeywordAttr.Color := clWindowText;
  FKeywordAttr.Style := [fsBold];

  FStringAttr := TFont.Create;
  FStringAttr.Color := clWindowText;
  FStringAttr.Style := [];

  FTextAttr := TFont.Create;
  FTextAttr.Color := clWindowText;
  FTextAttr.Style := [];
end;

destructor TSyntaxMemo.Destroy;
begin
  FCommentAttr.Free;
  FKeywordAttr.Free;
  FStringAttr.Free;
  FTextAttr.Free;
  FText.Free;
  FUndo.Free;
  inherited;
end;

{ Windows-specific stuff }

procedure TSyntaxMemo.CreateParams(var Params: TCreateParams);
begin
  inherited;
  with Params do
    ExStyle := ExStyle or WS_EX_CLIENTEDGE;
end;

procedure TSyntaxMemo.WMKillFocus(var Msg: TWMKillFocus);
begin
  inherited;
  HideCaret(Handle);
  DestroyCaret;
end;

procedure TSyntaxMemo.WMSetFocus(var Msg: TWMSetFocus);
begin
  inherited;
  CreateCaret(Handle, 0, 2, FCharHeight);
  ShowCaretPos;
end;

procedure TSyntaxMemo.ShowCaretPos;
begin
  SetCaretPos(FCharWidth * (FPos.X - 1 - FOffset.X) + 1,
    FCharHeight * (FPos.Y - 1 - FOffset.Y));
  ShowCaret(Handle);
end;

procedure TSyntaxMemo.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  Message.Result := DLGC_WANTARROWS or DLGC_WANTTAB;
end;

procedure TSyntaxMemo.CMFontChanged(var Message: TMessage);
var
  b: TBitmap;
begin
  b := TBitmap.Create;
  with b.Canvas do
  begin
    Font.Assign(Self.Font);
    Font.Style := [fsBold];
    FCharHeight := TextHeight('Wg');
    FCharWidth := TextWidth('W');
    FIsMonoType := Pos('COURIER NEW', AnsiUppercase(Canvas.Font.Name)) <> 0;
  end;
  b.Free;
end;

{ End of stuff }

procedure TSyntaxMemo.SetParent(AParent: TWinControl);
begin
  inherited;
  if (Parent = nil) or (csDestroying in ComponentState) then Exit;

  FVScroll.Ctl3D := False;
  Color := clWindow;
  TabStop := True;
end;

function TSyntaxMemo.GetClientRect: TRect;
begin
  if FVScroll.Visible then
    Result := Bounds(0, 0, Width - FVScroll.Width - 4, Height) else
    Result := inherited GetClientRect;
end;

procedure TSyntaxMemo.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited;
  if FCharWidth = 0 then exit;

  FWindowSize := Point((ClientWidth - 2) div FCharWidth, (Height - 4) div FCharHeight);
  FVScroll.SetBounds(Width - FVScroll.Width - 4, 0, FVScroll.Width, Height - 4);
  UpdateScrollBar;
end;

procedure TSyntaxMemo.UpdateSyntax;
begin
  CreateSynArray;
  Repaint;
end;

procedure TSyntaxMemo.UpdateScrollBar;
begin
  with FVScroll do
  begin
// prevent OnScroll event
    FBusy := True;

    Position := 0;
{$IFDEF Delphi4}
    PageSize := 0;
{$ENDIF}
    Max := FText.Count;
    SmallChange := 1;
    if FWindowSize.Y < Max then
    begin
      Visible := True;
{$IFDEF Delphi4}
      PageSize := FWindowSize.Y;
{$ENDIF}
    end
    else
      Visible := False;
    LargeChange := FWindowSize.Y;
    Position := FOffset.Y;

// need to do this due to bug in the VCL
    THackScrollBar(FVScroll).RecreateWnd;
    FBusy := False;
  end;
end;

function TSyntaxMemo.GetText: TStrings;
var
  i: Integer;
begin
  for i := 0 to FText.Count - 1 do
    FText[i] := LineAt(i);
  Result := FText;
  FAllowLinesChange := True;
end;

procedure TSyntaxMemo.SetText(Value: TStrings);
begin
  FAllowLinesChange := True;
  FText.Assign(Value);
end;

procedure TSyntaxMemo.SetSyntaxType(Value: TSyntaxType);
begin
  FSyntaxType := Value;
  if Value = stPascal then
    FKeywords := PasKeywords
  else if Value = stSQL then
    FKeywords := SQLKeywords
  else
    FKeywords := '';
  UpdateSyntax;
end;

procedure TSyntaxMemo.LinesChange(Sender: TObject);
begin
  if FAllowLinesChange then
  begin
    FAllowLinesChange := False;
    if FText.Count = 0 then
      FText.Add('');
    FMoved := True;
    FUndo.Clear;
    FPos := Point(1, 1);
    FOffset := Point(0, 0);
    ClearSel;
    ShowCaretPos;
    UpdateSyntax;
  end;
end;

procedure TSyntaxMemo.ShowMessage(s: String);
begin
  FMessage := s;
  Repaint;
end;

procedure TSyntaxMemo.CopyToClipboard;
begin
  if FSelStart.X <> 0 then
    Clipboard.AsText := SelText;
end;

procedure TSyntaxMemo.CutToClipboard;
begin
  if not FReadOnly then
    if FSelStart.X <> 0 then
    begin
      Clipboard.AsText := SelText;
      SelText := '';
    end;
end;

procedure TSyntaxMemo.PasteFromClipboard;
begin
  if not FReadOnly then
    SelText := Clipboard.AsText;
end;

function TSyntaxMemo.LineAt(Index: Integer): String;
begin
  Result := TrimRight(FText[Index]);
end;

function TSyntaxMemo.LineLength(Index: Integer): Integer;
begin
  Result := Length(LineAt(Index));
end;

function TSyntaxMemo.Pad(n: Integer): String;
begin
  Result := '';
  while Length(Result) < n do
    Result := Result + ' ';
end;