fqbclass.pas

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

{*******************************************}
{                                           }
{          FastQueryBuilder 1.03            }
{                                           }
{            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 FQB_COM}
  ,FastQueryBuilder_TLB
  ,FastReport_TLB
  ,VCLCOM
  ,ComServ
  ,ComObj
{$ENDIF}
{$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);
    procedure SetXPStyle(const AComp: TControl);
  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 CMRelease(var Message: TMessage); message CM_RELEASE;
    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;
    procedure CreateWnd; 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 WMVscroll(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;
  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; abstract;
  published
    property ShowSystemTables: Boolean read FShowSystemTables write
                   FShowSystemTables default False;
  end;
  
{$IFDEF FQB_COM}
  TfqbDialog = class( TComponent, IFastQueryBuilder )
{$ELSE}
  TfqbDialog = class(TComponent)
{$ENDIF}
  private
    FEngine: TfqbEngine;
    function GetSchemaInsideSQL: Boolean;
    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
{$IFDEF FQB_COM}
    function DesignQuery(const Param1: IfrxCustomQuery; out ModalResult: WordBool): HResult; stdcall;
    function Get_SQL(out Value: WideString): HResult; stdcall;
    function Set_SQL(const Value: WideString): HResult; stdcall;
    function Get_SQLSchema(out Value: WideString): HResult; stdcall;
    function Set_SQLSchema(const Value: WideString): HResult; stdcall;
{$ENDIF}
    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 GetSchemaInsideSQL write
                   SetSchemaInsideSQL default True;
  end;
  
  TfqbCore = class(TObject)
  private
    FEngine: TfqbEngine;
    FGrid: TfqbGrid;
    FSchemaInsideSQL: Boolean;
    FSQL: string;
    FSQLSchema: string;
    FTableArea: TfqbTableArea;
    FUseCoding: Boolean;
    FText: string;
    FUsingQuotes: Boolean;
    function ExtractSchema(const Value: string): string;
    function ExtractSQL(const Str: string): string;
    function GetEngine: TfqbEngine;
    function GetGrid: TfqbGrid;
    function GetSQL: string;
    function GetSQLSchema: string;
    function GetTableArea: TfqbTableArea;
    procedure SetSchemaInsideSQL(const Value: Boolean);
    procedure SetSQL(Value: string);
    procedure SetSQLSchema(const Value: string);
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Clear;
    function GenerateSQL: string;
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStr(const Str: TStringList);
    procedure RecognizeModel(const crc32: Cardinal; const FileName: string);
    procedure SaveToFile(const FileName: string);
    procedure SaveToStr(var Str: TStringList);
    property Engine: TfqbEngine read GetEngine write FEngine;
    property Grid: TfqbGrid read GetGrid write FGrid;
    property SQL: string read GetSQL write SetSQL;
    property SQLSchema: string read GetSQLSchema write SetSQLSchema;
    property TableArea: TfqbTableArea read GetTableArea write FTableArea;
    property SchemaInsideSQL: Boolean read FSchemaInsideSQL write SetSchemaInsideSQL
                   default True;
    property UsingQuotes: Boolean read FUsingQuotes write FUsingQuotes;

  end;
  

function fqbCore: TfqbCore;

const
  StrFieldType : array [0..29] of string = (''{0}, 'String'{1}, 'Smallint'{2},
                       'Integer'{3}, 'Word'{4}, 'Boolean'{5}, 'Float'{6},
                       'Currency'{7}, 'BCD'{8}, 'Date'{9}, 'Time'{10},
                       'DateTime'{11}, 'Bytes'{12}, 'VarBytes'{13}, 'AutoInc'{14},
                       'Blob'{15}, 'Memo'{16}, 'Graphic'{17}, 'FmtMemo'{18},
                       'ParadoxOle'{19}, 'DBaseOle'{20}, 'TypedBinary'{21},
                       'Cursor'{22}, 'FixedChar'{23}, 'WideString'{24}, 'Largeint'{25},
                       'ADT'{26}, 'Array'{27}, 'Reference'{28}, 'DataSet'{29});

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

implementation

{$R images.res}

uses Math, IniFiles, Dialogs, Commctrl, fqbDesign, fqbLinkForm, fqbUtils,
     fqbRes, fqbrcDesign
     {$IFDEF Delphi7}
     ,Themes
     {$ENDIF}
     {$IFDEF FQB_COM}
     ,frxCustomDB
     {$ENDIF}
     ;

const
  clSelectedLink = clGreen;
  clNotSelectedLink = clBlack;

  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;
  rowVisibility = 1;
  rowWhere =      2;
  rowSort =       3;
  rowFunction =   4;
  rowGroup =      5;

  CompatibleIntTypes = [2, 3, 4, 12, 14];
  CompatibleDateTimeTypes = [9, 10, 11];
  CompatibleFloatTypes = [6, 7];

type
  TcrTControl = class(TControl)
  end;
  
var
  FfqbCore: TfqbCore = nil;
  FExternalCreation: Boolean = True;

function fqbCore: TfqbCore;
begin
  if FfqbCore = nil then
  begin
    FExternalCreation := False;
    try
      FfqbCore := TfqbCore.Create;
    finally
      FExternalCreation := True;
    end;
  end;
  Result := FfqbCore;
end;

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;

{-----------------------  TfqbField -----------------------}
function TfqbField.GetFieldName: string;
begin
  if ((Pos(' ', FFieldName) > 0) or (Pos('/', FFieldName) > 0)
    or ((UpperCase(FFieldName) <> FFieldName)) and fqbCore.UsingQuotes) then
    Result := '"' + FFieldName + '"'
  else
    Result := FFieldName
end;

{-----------------------  TfqbFieldList -----------------------}
function TfqbFieldList.Add: TfqbField;
begin
  Result := TfqbField(inherited Add)
end;

function TfqbFieldList.GetItem(Index: Integer): TfqbField;
begin
  Result := TfqbField(inherited Items[Index])
end;

procedure TfqbFieldList.SetItem(Index: Integer; const Value: TfqbField);
begin
  Items[Index].Assign(Value)
end;

{-----------------------  TfqbLinkList -----------------------}
function TfqbLinkList.Add: TfqbLink;
begin
  Result := TfqbLink(inherited Add)
end;

function TfqbLinkList.GetItem(Index: Integer): TfqbLink;
begin
  Result := TfqbLink(inherited Items[Index])
end;

procedure TfqbLinkList.SetItem(Index: Integer; const Value: TfqbLink);
begin
  Items[Index].Assign(Value)
end;

{-----------------------  TfqbLink -----------------------}
constructor TfqbLink.Create(Collection: TCollection);
var