fqbsynmemo.pas

这个是功能强大的报表软件

{*******************************************}
{                                           }
{          FastQueryBuilder 1.03            }
{           Syntax memo control             }
{                                           }
{     (c) 2003 by Alexander Tzyganenko,     }
{             Fast Reports, Inc             }
{                                           }
{*******************************************}

{$I fqb.inc}

unit fqbSynmemo;

interface

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

type

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

  TfqbSyntaxMemo = class(TCustomControl)
  private
    FAllowLinesChange: Boolean;
    FCharHeight: Integer;
    FCharWidth: Integer;
    FDoubleClicked: Boolean;
    FDown: Boolean;
    FGutterWidth: Integer;
    FFooterHeight: Integer;
    FIsMonoType: Boolean;
    FKeywords: String;
    FMaxLength: Integer;
    FMessage: String;
    FModified: Boolean;
    FMoved: Boolean;
    FOffset: TPoint;
    FPos: TPoint;
    FReadOnly: Boolean;
    FSelEnd: TPoint;
    FSelStart: TPoint;
    FSynStrings: TStrings;
    FSyntaxType: TSyntaxType;
    FTempPos: TPoint;
    FText: TStringList;
    FKeywordAttr: TFont;
    FStringAttr: TFont;
    FTextAttr: TFont;
    FCommentAttr: TFont;
    FBlockColor: TColor;
    FBlockFontColor: TColor;
    FUndo: TStringList;
    FUpdating: Boolean;
    FUpdatingSyntax: Boolean;
    FVScroll: TScrollBar;
    FWindowSize: TPoint;
    FPopupMenu: TPopupMenu;
{$IFDEF Delphi4}
    KWheel: Integer;
{$ENDIF}
    LastSearch: String;
    FShowGutter: boolean;
    FShowFooter: boolean;
{$IFDEF Delphi4}
    Bookmarks: array of Integer;
{$ELSE}
    Bookmarks: array [0..10] of Integer;
{$ENDIF}
    FActiveLine: Integer;
    function GetText: TStrings;
    procedure SetText(Value: TStrings);
    procedure SetSyntaxType(Value: TSyntaxType);
    procedure SetShowGutter(Value: boolean);
    procedure SetShowFooter(Value: boolean);
    function FMemoFind(Text: String; var Position : TPoint): boolean;
    function GetCharAttr(Pos: TPoint): 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 DoChange;
    procedure EnterIndent;
    procedure SetSelText(Value: String);
    procedure ShiftSelected(ShiftRight: Boolean);
    procedure ShowCaretPos;
    procedure TabIndent;
    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 DoCtrlR;
    procedure DoCtrlL;
    procedure ScrollClick(Sender: TObject);
    procedure ScrollEnter(Sender: TObject);
    procedure LinesChange(Sender: TObject);
    procedure ShowPos;
    procedure BookmarkDraw(Y :integer; line : integer);
    procedure ActiveLineDraw(Y :integer; line : integer);
    procedure CorrectBookmark(Line : integer; delta : integer);
    procedure SetKeywordAttr(Value: TFont);
    procedure SetStringAttr(Value: TFont);
    procedure SetTextAttr(Value: TFont);
    procedure SetCommentAttr(Value: TFont);

  protected
    { Windows-specific stuff }
    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(Value: TWinControl); override;
    function GetClientRect: TRect; override;
    procedure DblClick; 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;
    procedure CopyPopup(Sender: TObject);
    procedure PastePopup(Sender: TObject);
    procedure CutPopup(Sender: TObject);
{$IFDEF Delphi4}
    procedure MouseWheelUp(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure MouseWheelDown(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
{$ENDIF}
    procedure DOver(Sender, Source: TObject; X, Y: Integer;
         State: TDragState; var Accept: Boolean);
    procedure DDrop(Sender, Source: TObject; X, Y: Integer);

  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);
    procedure Undo;
    procedure UpdateView;
    function GetPos: TPoint;
    function Find(Text: String): boolean;
    property Modified: Boolean read FModified write FModified;
    property SelText: String read GetSelText write SetSelText;
    function  IsBookmark(Line : integer): integer;
    procedure AddBookmark(Line, Number : integer);
    procedure DeleteBookmark(Number : integer);
    procedure GotoBookmark(Number : integer);
    procedure SetActiveLine(Line : Integer);
    function GetActiveLine: Integer;

  published
    property Align;
{$IFDEF Delphi4}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
{$ENDIF}
    property Color;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Width;
    property Height;
    property Visible;
    property BlockColor: TColor read FBlockColor write FBlockColor;
    property BlockFontColor: TColor read FBlockFontColor write FBlockFontColor;
    property CommentAttr: TFont read FCommentAttr write SetCommentAttr;
    property KeywordAttr: TFont read FKeywordAttr write SetKeywordAttr;
    property StringAttr: TFont read FStringAttr write SetStringAttr;
    property TextAttr: TFont read FTextAttr write SetTextAttr;
    property Lines: TStrings read GetText write SetText;
    property ReadOnly: Boolean read FReadOnly write FReadOnly;
    property SyntaxType: TSyntaxType read FSyntaxType write SetSyntaxType;
    property ShowFooter: boolean read FShowFooter write SetShowFooter;
    property ShowGutter: boolean read FShowGutter write SetShowGutter;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

  TfqbSynMemoSearch = class(TForm)
    Search: TButton;
    Button1: TButton;
    Label1: TLabel;
    Edit1: TEdit;
    procedure FormKeyPress(Sender: TObject; var Key: Char);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fqbSynMemoSearch: TfqbSynMemoSearch;

procedure Register;

implementation

{$R *.DFM}

uses Clipbrd, comctrls;

procedure Register;
begin
  RegisterComponents('FastQB2', [TfqbSyntaxMemo])
end;

const
  PasKeywords =
     'and,array,begin,case,const,div,do,downto,else,end,except,finally,'+
     'for,function,if,in,is,mod,nil,not,of,or,procedure,program,repeat,shl,'+
     'shr,string,then,to,try,until,uses,var,while,with,xor';

  CppKeywords =
     'bool,break,case,char,continue,define,default,delete,do,double,else,'+
     'except,finally,float,for,if,include,int,is,new,return,string,switch,try,'+
     'variant,void,while';

  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';

  WordChars = ['a'..'z', 'A'..'Z', '0'..'9', '_'];

type
  THackScrollBar = class(TScrollBar)
  end;

{ TfrSyntaxMemo }

constructor TfqbSyntaxMemo.Create(AOwner: TComponent);
var
  m: TMenuItem;
  i: integer;
begin
  inherited Create(AOwner);

  FVScroll := TScrollBar.Create(Self);

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

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

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

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


  if AOwner is TWinControl then
    Parent := AOwner as TWinControl;

  OnDragOver := DOver;
  OnDragDrop := DDrop;

{$IFDEF Delphi4}
  OnMouseWheelUp := MouseWheelUp;
  OnMouseWheelDown := MouseWheelDown;
  KWheel := 1;
{$ENDIF}

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

  Cursor := crIBeam;
  FBlockColor := clHighlight;
  FBlockFontColor := clHighlightText;

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

  FPopupMenu := TPopupMenu.Create(Self);
  m := TMenuItem.Create(FPopupMenu);
  m.Caption := 'Cut';
  m.OnClick := CutPopup;
  FPopupMenu.Items.Add(m);
  m := TMenuItem.Create(FPopupMenu);
  m.Caption := 'Copy';
  m.OnClick := CopyPopup;
  FPopupMenu.Items.Add(m);
  m := TMenuItem.Create(FPopupMenu);
  m.Caption := 'Paste';
  m.OnClick := PastePopup;
  FPopupMenu.Items.Add(m);

  LastSearch := '';
{$IFDEF Delphi4}
  Setlength(Bookmarks, 10);
  for i := 0 to Length(Bookmarks)-1 do
{$ELSE}
  for i := 0 to 9 do
{$ENDIF}
    Bookmarks[i] := -1;

  FActiveLine := -1;

  Height := 200;
  Width := 200;

end;

destructor TfqbSyntaxMemo.Destroy;
begin
  FPopupMenu.Free;
  FCommentAttr.Free;
  FKeywordAttr.Free;
  FStringAttr.Free;
  FTextAttr.Free;
  FText.Free;
  FUndo.Free;
  FSynStrings.Free;
  FVScroll.Free;
  inherited;
end;

{ Windows-specific stuff }

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

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

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

procedure TfqbSyntaxMemo.ShowPos;
begin
  if FFooterHeight > 0 then
    with Canvas do
    begin
      Font.Name := 'Tahoma';
      Font.Color := clBlack;
      Font.Style := [];
      Font.Size := 8;
      Brush.Color := clBtnFace;
      TextOut(FGutterWidth + 4, Height - TextHeight('|') - 5, IntToStr(FPos.y) + ' : ' + IntToStr(FPos.x) + '    ');
    end;
end;

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

procedure TfqbSyntaxMemo.CMFontChanged(var Message: TMessage);
var
  b: TBitmap;
begin
  FCommentAttr.Size := Font.Size;
  FCommentAttr.Name := Font.Name;
  FKeywordAttr.Size := Font.Size;
  FKeywordAttr.Name := Font.Name;
  FStringAttr.Size := Font.Size;
  FStringAttr.Name := Font.Name;
  FTextAttr.Size := Font.Size;
  FTextAttr.Name := Font.Name;

  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(Self.Font.Name)) <> 0;
  end;
  b.Free;
end;

{ End of stuff }

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

  ShowGutter := True;
  ShowFooter := True;
  FVScroll.Parent := Self;
  FVScroll.Kind := sbVertical;
  FVScroll.OnChange := ScrollClick;
  FVScroll.OnEnter := ScrollEnter;
  FVScroll.Ctl3D := False;
  Color := clWindow;
  TabStop := True;

end;


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

procedure TfqbSyntaxMemo.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited;
  if FCharWidth = 0 then exit;
  FWindowSize := Point((ClientWidth - FGutterWidth) div FCharWidth,
                       (Height - FFooterHeight) div FCharHeight );
  FVScroll.SetBounds(Width - FVScroll.Width - 4, 0, FVScroll.Width, Height - 4);
  UpdateScrollBar;
end;

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

procedure TfqbSyntaxMemo.UpdateScrollBar;