fqbclass.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

{*******************************************}
{                                           }
{           FastQueryBuilder 1.0            }
{                                           }
{            Copyright (c) 2005             }
{             Fast Reports Inc.             }
{                                           }
{*******************************************}

{$I fqb.inc}

unit fqbClass;

interface

uses
  Windows, Messages, Classes, Controls, Menus, Forms, Graphics, StdCtrls, Grids,
  DB, SysUtils, ExtCtrls, CheckLst, Buttons, Comctrls
{$IFDEF Delphi6}
  ,Variants
{$ENDIF};

type
  TfqbTable = class;
  TfqbTableArea = class;
  EfqbError = class(Exception)
  end;
  
  TfqbField = class(TCollectionItem)
  private
    FFieldName: string;
    FFielType: Integer;
    FLinked: Boolean;
    function GetFieldName: string;
  public
    property FieldName: string read GetFieldName write FFieldName;
    property FieldType: Integer read FFielType write FFielType;
    property Linked: Boolean read FLinked write FLinked;
  end;
  
  TfqbFieldList = class(TOwnedCollection)
  private
    function GetItem(Index: Integer): TfqbField;
    procedure SetItem(Index: Integer; const Value: TfqbField);
  public
    function Add: TfqbField;
    property Items[Index: Integer]: TfqbField read GetItem write SetItem; default;
  end;
  
  TfqbLink = class(TCollectionItem)
  protected
    FArea: TfqbTableArea;
    FDestField: TfqbField;
    FDestTable: TfqbTable;
    FJOp: Integer;
    FJType: Integer;
    FMenu: TPopupMenu;
    FSelected: Boolean;
    FSourceField: TfqbField;
    FSourceTable: TfqbTable;
    procedure DoDelete(Sender: TObject);
    procedure DoOptions(Sender: TObject);
    procedure Draw;
    function GetDestCoords: TPoint;
    function GetSourceCoords: TPoint;
    procedure SetSelected(const Value: Boolean);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    property DestCoords: TPoint read GetDestCoords;
    property DestField: TfqbField read FDestField;
    property DestTable: TfqbTable read FDestTable;
    property JoinOperator: Integer read FJOp write FJOp;
    property JoinType: Integer read FJType write FJType;
    property Selected: Boolean read FSelected write SetSelected;
    property SourceCoords: TPoint read GetSourceCoords;
    property SourceField: TfqbField read FSourceField;
    property SourceTable: TfqbTable read FSourceTable;
  end;
  
  TfqbLinkList = class(TOwnedCollection)
  private
    function GetItem(Index: Integer): TfqbLink;
    procedure SetItem(Index: Integer; const Value: TfqbLink);
  public
    function Add: TfqbLink;
    property Items[Index: Integer]: TfqbLink read GetItem write SetItem; default;
  end;
  
  TfqbCheckListBox = class(TCheckListBox)
  protected
    procedure ClickCheck; override;
    procedure DragOver(Sender: TObject; X, Y: Integer; State: TDragState; var
                   Accept: Boolean); override;
  public
    procedure DragDrop(Sender: TObject; X, Y: Integer); override;
  end;
  
  TfqbTable = class(TPanel)
  private
    FAliasName: string;
    FButtonClose: TSpeedButton;
    FButtonMinimize: TSpeedButton;
    FCheckListBox: TfqbCheckListBox;
    FFieldList: TfqbFieldList;
    FImage: TImage;
    FLabel: TLabel;
    FOldHeight: Integer;
    FTableName: string;
    function GetSellectedField: TfqbField;
    procedure SetTableName(const Value: string);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    function GetLinkPoint(AIndex: integer; ASide: char): TPoint;
    procedure Resize; override;
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
    procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure _DoExit(Sender: TObject);
    procedure _DoMinimize(Sender: TObject);
    procedure _DoRestore(Sender: TObject);
    property ChBox: TfqbCheckListBox read FCheckListBox;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UpdateFieldList;
    procedure UpdateLinkList;
    property AliasName: string read FAliasName;
    property FieldList: TfqbFieldList read FFieldList write FFieldList;
    property SellectedField: TfqbField read GetSellectedField;
    property TableName: string read FTableName write SetTableName;
  end;
  
  TfqbTableArea = class(TScrollBox)
  private
    FCanvas: TCanvas;
    FInstX: Integer;
    FInstY: Integer;
    FLinkList: TfqbLinkList;
  protected
    procedure Click; override;
    function GenerateAlias(const ATableNAme: string): string; virtual;
    function GetLineAtCursor: Integer;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function CompareFields(TableID1: integer; FIndex1: integer; TableID2: integer;
                   FIndex2: integer): Boolean;
    procedure DragDrop(Source: TObject; X, Y: Integer); override;
    procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var
                   Accept: Boolean); override;
    function FindTable(const AName, AAlias: string): TfqbTable;
    procedure InsertTable(const X, Y : integer; const Name: string); overload;
    procedure InsertTable(const Name : string); overload;
    property LinkList: TfqbLinkList read FLinkList;
  end;
  
  TfqbTableListBox = class(TListBox)
  protected
    procedure DblClick; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
                   override;
  public
    constructor Create(AOwner: TComponent); override;
  end;
  
  PGridColumn = ^TGridColumn;
  TGridColumn = record
    Table: string;
    Alias: string;
    Field: string;
    Visibl: Boolean;
    Where: string;
    Sort: Integer;
    Func: Integer;
    Group: Integer;
  end;
  
  TfqbEdit = class(TEdit)
  private
    FButton: TSpeedButton;
    FOnButtonClick: TNotifyEvent;
    FPanel: TPanel;
    FShowButton: Boolean;
    procedure SetShowButton(const Value: Boolean);
  protected
    procedure ButtonClick(Sender: TObject);
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure SetEditRect;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    property OnButtonClick: TNotifyEvent read FOnButtonClick write FOnButtonClick;
    property ShowButton: Boolean read FShowButton write SetShowButton;
  end;
  
  TfqbColumnResizeEvent = procedure (Sender: TCustomListview; ColumnIndex: Integer;
                 ColumnWidth: Integer) of object;
  TfqbGrid = class(TListView)
  private
    FEndColumnResizeEvent: TfqbColumnResizeEvent;
    FFunctionList: TComboBox;
    FGroupList: TComboBox;
    FPopupMenu: TPopupMenu;
    FSortList: TComboBox;
    FVisibleList: TComboBox;
    FWhereEditor: TfqbEdit;
    procedure fqbOnChange(Sender: TObject);
    procedure fqbOnMenu(Sender: TObject);
    procedure fqbOnPopup(Sender: TObject);
    procedure fqbOnSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
    procedure fqbSetBounds(var Contr: TControl);
  protected
    procedure CreateWnd; override;
    procedure DoColumnResize(ColumnIndex, ColumnWidth: Integer); virtual;
    function FindColumnIndex(pHeader: pNMHdr): Integer;
    function FindColumnWidth(pHeader: pNMHdr): Integer;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
                   override;
    procedure RecalcColWidth;
    procedure Resize; override;
    procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;
    procedure WM_VSCROLL(var Msg: TWMNotify); message WM_VSCROLL;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function AddColumn: Integer;
    procedure Exchange(const AItm1, AItm2: integer);
    procedure fqbUpdate;
    procedure UpdateColumn;
    property OnEndColumnResize: TfqbColumnResizeEvent read FEndColumnResizeEvent
                   write FEndColumnResizeEvent;
  end;
  
  TfqbEngine = class(TComponent)
  private
    FShowSystemTables: Boolean;
    FSQL: string;
  public
    procedure ReadFieldList(const ATableName: string; var AFieldList: TfqbFieldList);
                   virtual; abstract;
    procedure ReadTableList(ATableList: TStrings); virtual; abstract;
    function ResultDataSet: TDataSet; virtual; abstract;
    procedure SetSQL(const Value: string); virtual;
  published
    property ShowSystemTables: Boolean read FShowSystemTables write
                   FShowSystemTables default False;
  end;
  
  TfqbDialog = class(TComponent)
  private
    FEngine: TfqbEngine;
    FSchemaInsideSQL: Boolean;
    FSQL: string;
    FSQLSchema: string;
    Ftext: string;
    function GetSQL: string;
    function GetSQLSchema: string;
    procedure SetEngine(const Value: TfqbEngine);
    procedure SetSchemaInsideSQL(const Value: Boolean);
    procedure SetSQL(Value: string);
    procedure SetSQLSchema(const Value: string);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    function Execute: Boolean; virtual;
    property SQL: string read GetSQL write SetSQL;
    property SQLSchema: string read GetSQLSchema write SetSQLSchema;
  published
    property Engine: TfqbEngine read FEngine write SetEngine;
    property SchemaInsideSQL: Boolean read FSchemaInsideSQL write SetSchemaInsideSQL
                   default True;
  end;
  
  TcrTControl = class(TControl)
  end;
  

function fqbGenerateSQL(TableArea: TfqbTableArea; Grid: TfqbGrid): string;
procedure fqbSaveToStr(TableArea: TfqbTableArea; Grid: TfqbGrid; var Str: TStringList);
procedure fqbSaveToFile(TableArea: TfqbTableArea; Grid: TfqbGrid; const FileName: string);
procedure fqbLoadFromStr(TableArea: TfqbTableArea; Grid: TfqbGrid; const Str: TStringList);
procedure fqbLoadFromFile(TableArea: TfqbTableArea; Grid: TfqbGrid; const FileName: string);
procedure fqbClear(const AForm: TCustomForm);

var
  fqbActiveEngine: TfqbEngine;

  StrFieldType : array [0..29] of string = ('', 'String', 'Smallint',
                       'Integer', 'Word', 'Boolean', 'Float', 'Currency', 'BCD',
                       'Date', 'Time', 'DateTime', 'Bytes', 'VarBytes', 'AutoInc',
                       'Blob', 'Memo', 'Graphic', 'FmtMemo', 'ParadoxOle',
                       'DBaseOle', 'TypedBinary', 'Cursor', 'FixedChar', 'WideString',
                       'Largeint', 'ADT', 'Array', 'Reference', 'DataSet');

const
  _fqbBeginModel = '/*_FQBMODEL';
  _fqbEndModel = '_FQBEND*/';

implementation

{$R images.res}

uses Math, IniFiles, Dialogs, Commctrl, fqbDesign, fqbLinkForm, fqbUtils;

const
  clSelectedLink = clGreen;
  clNotSelectedLink = clBlack;

  fqbUseCoding: boolean = true; //for debuging

  LinkType: array[0..5] of string = ('=', '>', '<', '>=', '<=', '<>');
  JoinType: array[0..3] of string = ('INNER JOIN', 'LEFT OUTER JOIN',
                                     'RIGHT OUTER JOIN', 'FULL OUTER JOIN');

  rowColumn =     0;
//  rowTable =      1;
  rowVisibility = 1;
  rowWhere =      2;
  rowSort =       3;
  rowFunction =   4;
  rowGroup =      5;

type
  crTCustomListbox = class(TCustomListbox)
  end;
  
function ExtractSQL(const Str: string): string; forward;
function ExtractSchema(const Value: string): string; forward;

function FindFQBcomp(const AClassName: string; const Source: TComponent): TComponent;
  var
    i: integer;
begin
  Result := nil;
  if UpperCase(Source.ClassName) = UpperCase(AClassName) then
      Result := Source
  else
    for i := 0 to Source.ComponentCount - 1 do
      if Result = nil then
        Result := FindFQBcomp(AClassName, Source.Components[i])
      else
        Exit
end;

function fqbGenerateSQL(TableArea: TfqbTableArea; Grid: TfqbGrid): string;
  const
    strTab  = '    ';
    strSel = 'SELECT ';
    strFrom = 'FROM';
    strWhere = 'WHERE';
    strOrder = 'ORDER BY ';
    strGroup = 'GROUP BY ';
  var
    i: integer;
    tmpStr, orderStr, prd, groupStr: string;
    slFrom, slWhere: TStringList;
    Tbl1, Tbl2, Tbl3: TfqbTable;
    CopyLL: TList;
    flg: boolean;
    SQL: TStringList;

  function FormingFrom(const Ind: integer):string;
    var
      tmp: TfqbLink;
  begin
      tmp := TableArea.LinkList[Ind];
      Result :=  strTab + JoinType[tmp.JoinType] + ' '
                + Tbl2.TableName + ' ' + Tbl2.AliasName + ' ON ('
                + Tbl1.AliasName + '.' + tmp.SourceField.FieldName
                + LinkType[tmp.JoinOperator]
                + Tbl2.AliasName + '.' + tmp.DestField.FieldName + ')'
  end;

  function FormingFromAnd(const Ind: integer):string;
    var
      tmp: TfqbLink;
  begin
    tmp := TfqbLink(TableArea.LinkList[Ind]);
    Result := ' AND ('
             + Tbl1.AliasName + '.' + tmp.SourceField.FieldName
             + LinkType[tmp.JoinOperator]
             + Tbl3.AliasName + '.' + tmp.DestField.FieldName + ') '
  end;

begin
  SQL := TStringList.Create;
//SELECT
  tmpStr := strSel;

  if Grid.Items.Count = 0 then Exit;

  for i := 0 to Grid.Items.Count - 1 do

  if TGridColumn(Grid.Items[i].Data^).Visibl then
  begin

    if Grid.Items[i].SubItems[rowFunction - 1] <> '' then
      prd := Grid.Items[i].SubItems[rowFunction - 1] + '('
    else
      prd := '';

    tmpStr := tmpStr + prd + TGridColumn(Grid.Items[i].Data^).Alias + '.'
              + TGridColumn(Grid.Items[i].Data^).Field;

    if prd <> '' then prd := ')';

    tmpStr := tmpStr + prd + ', '
  end;
  tmpStr := Copy(tmpStr,1,Length(tmpStr) - 2);
  SQL.Add(tmpStr);

//FROM
  tmpStr := '';
  slFrom := TStringList.Create;
  CopyLL := TList.Create;
  for i := 0 to TableArea.LinkList.Count - 1 do
    CopyLL.Add(Pointer(i));
  while CopyLL.Count <> 0 do
  begin
    Tbl1 := TableArea.LinkList[0].SourceTable;
    Tbl2 := TableArea.LinkList[0].DestTable;
    slFrom.Add(strTab + Tbl1.TableName + ' ' + Tbl1.AliasName);
    slFrom.Add(strTab + FormingFrom(0));
    for i := 1 to CopyLL.Count - 1 do
    begin
      Tbl3 := TableArea.LinkList[0].DestTable;

      if (Tbl3.AliasName = Tbl2.AliasName) then
      begin
        slFrom[slFrom.Count - 1] := slFrom[slFrom.Count - 1] + FormingFromAnd(Integer(CopyLL[i]));
        CopyLL[i] := Pointer(-1);
      end
      else
      begin
        Tbl1 := TableArea.LinkList[Integer(CopyLL[i])].SourceTable;
        Tbl2 := Tbl3;
        slFrom.Add(strTab + FormingFrom(Integer(CopyLL[i])));
        CopyLL[i] := Pointer(-1)
       end

    end;
    CopyLL.Delete(0);
    for i := CopyLL.Count - 1 downto 0 do
      if Integer(CopyLL[i]) = -1 then CopyLL.Delete(i)
  end;

  flg := false;
  for i := 0 to Grid.Items.Count - 1 do
  begin
    tmpStr := TGridColumn(Grid.Items[i].Data^).Table + ' '
                     + TGridColumn(Grid.Items[i].Data^).Alias;

    if Pos(tmpStr, slFrom.Text) = 0 then
    begin
      if slFrom.Count <> 0 then
        slFrom[slFrom.Count - 1] := slFrom[slFrom.Count - 1] + ', ';

      slFrom.Add(strTab + tmpStr);
      flg := true
    end
  end;

  if flg then
    slFrom.Text := Copy(slFrom.Text,1,Length(slFrom.Text) - 2);

  CopyLL.Free;

//WHERE
  slWhere := TStringList.Create;
  for i := 0 to Grid.Items.Count - 1 do
    if TGridColumn(Grid.Items[i].Data^).Where <> '' then
       slWhere.Add(strTab + TGridColumn(Grid.Items[i].Data^).Alias + '.'
                   + TGridColumn(Grid.Items[i].Data^).Field
                   + TGridColumn(Grid.Items[i].Data^).Where + ' AND');

  if slWhere.Count <> 0 then
  begin
    slWhere.Text:= Copy(slWhere.Text,1,Length(slWhere.Text) - 6);
    slWhere.Insert(0,strWhere)
  end;

//ORDER
  orderStr:= '';
  prd:= '';
  flg:= false;
  for i:= 0 to Grid.Items.Count - 1 do
  begin
    if TGridColumn(Grid.Items[i].Data^).Sort <> 0 then
    begin
      if TGridColumn(Grid.Items[i].Data^).Sort = 2 then
              prd := 'DESC'
      else
              prd := '';
      orderStr:= orderStr + TGridColumn(Grid.Items[i].Data^).Alias + '.' +
                               TGridColumn(Grid.Items[i].Data^).Field + prd + ', ';
      flg:= true;
    end;
  end;
  if flg then orderStr:= Copy(orderStr,1,Length(orderStr) - 2);

//GROUP
  groupStr:= '';
  flg:= false;
  for i:= 0 to Grid.Items.Count - 1 do
  begin
    if TGridColumn(Grid.Items[i].Data^).Group <> 0 then
    begin
      groupStr:= groupStr + TGridColumn(Grid.Items[i].Data^).Alias + '.' +
                            TGridColumn(Grid.Items[i].Data^).Field + ', ';
      flg:= true;
    end;
  end;
  if flg then groupStr:= Copy(groupStr,1,Length(groupStr) - 2);

  SQL.Add(strFrom);
  SQL.AddStrings(slFrom);
  SQL.AddStrings(slWhere);

  if orderStr <> '' then SQL.Add(strOrder + orderStr);

  if groupStr <> '' then SQL.Add(strGroup + groupStr);

  slFrom.Free;
  slWhere.Free;

  Result := SQL.Text;