rmd_dbwrap.pas

进销存·完整的·有数据库的·非常完整·只得参考

{*****************************************}
{                                         }
{           Report Machine v2.0           }
{        Wrapper for Table & Query        }
{                                         }
{*****************************************}

unit RMD_DBWrap;

interface

{$I RM.inc}

uses
  Classes, SysUtils, Controls, Forms, Menus, DB, RM_Class, RM_DBSet, RM_Pars
{$IFDEF Delphi6}, Variants{$ENDIF};

const
  RMFieldClasses: array[0..9] of TFieldClass = (
    TStringField, TSmallintField, TIntegerField, TWordField,
    TBooleanField, TFloatField, TCurrencyField, TDateField,
    TTimeField, TBlobField);

  RMParamTypes: array[0..10] of TFieldType = (
    ftBCD, ftBoolean, ftCurrency, ftDate, ftDateTime, ftInteger,
    ftFloat, ftSmallint, ftString, ftTime, ftWord);

type
  TRMParamKind = (rmpkValue, rmpkAssignFromMaster);

	{ TRMDStoredProc }
  TRMDStoredProc = class(TRMNonVisualControl)
  private
    FParamCount: Integer;
    procedure ParamsEditor(Sender: TObject);
    function GetParamCount: Integer;
  protected
    FDataSource: TDataSource;
    FDBDataSet: TRMDBDataset;
    FParams: TRMVariables;
    procedure OnBeforeOpenQueryEvent(DataSet: TDataSet); virtual;

    function GetParamName(Index: Integer): string; virtual; abstract;
    function GetParamType(Index: Integer): TFieldType; virtual; abstract;
    procedure SetParamType(Index: Integer; Value: TFieldType); virtual; abstract;
    function GetParamKind(Index: Integer): TRMParamKind; virtual; abstract;
    procedure SetParamKind(Index: Integer; Value: TRMParamKind); virtual; abstract;
    function GetParamText(Index: Integer): string; virtual; abstract;
    procedure SetParamText(Index: Integer; Value: string); virtual; abstract;
    function GetParamValue(Index: Integer): Variant; virtual; abstract;
    procedure SetParamValue(Index: Integer; Value: Variant); virtual; abstract;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure DefineProperties; override;
    procedure Loaded; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    function ParamIndex(const ParName: string): Integer;

    property ParamCount: Integer read GetParamCount;
    property ParamName[Index: Integer]: string read GetParamName; //取得参数的名称
    property ParamType[Index: Integer]: TFieldType read GetParamType write SetParamType; //取得(设置)参数类型
    property ParamKind[Index: Integer]: TRMParamKind read GetParamKind write SetParamKind; //取得(设置)参数初始化类型
    property ParamText[Index: Integer]: string read GetParamText write SetParamText; //取得(设置)参数初始化值
    property ParamValue[Index: Integer]: Variant read GetParamValue write SetParamValue; //取得(设置)参数值
  published
  end;

 { TRMDDataSet }
  TRMDDataSet = class(TRMNonVisualControl)
  private
    FDataSet: TDataSet;
    procedure P1Click(Sender: TObject);
    procedure SetDataSet(Value: TDataSet);
    function GetDatabaseName: string;
    procedure SetDatabaseName(const Value: string);
    procedure _GetDatabases(Sender: TObject);
  protected
    FCanBrowse: Boolean;
    FHaveFilter: Boolean;
    FDataSource: TDataSource;
    FDBDataSet: TRMDBDataset;
    procedure FieldsEditor(Sender: TObject);
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
    function DoMethod(const MethodName: string; Pars: array of Variant): Variant; override;

    procedure GetDatabases(sl: TStrings); virtual; abstract; //获取数据库列表
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure DefineProperties; override;
    procedure Loaded; override;
    procedure ShowEditor; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;

    property DataSet: TDataSet read FDataSet write SetDataSet;
    property DatabaseName: string read GetDatabaseName write SetDatabaseName;
  published
  end;

 { TRMDTable }
  TRMDTable = class(TRMDDataSet)
  private
    procedure JoinEditor(Sender: TObject);
    procedure _GetIndexs(Sender: TObject);
    procedure _GetMasterSource(Sender: TObject);
    procedure _GetTableNames(Sender: TObject);
  protected
    procedure GetTableNames(sl: TStrings); virtual; abstract; //获取表列表
    procedure GetIndexNames(sl: TStrings); virtual; abstract; //获取索引列表
  public
    procedure DefineProperties; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure Loaded; override;
  published
  end;

  { TRMDQuery }
  TRMDQuery = class(TRMDDataSet)
  private
    FEditSQLAsText: Boolean;
    FVisualSQL: TStringList;
    FParamCount: Integer;
    FOnSQLTextChanged: TNotifyEvent;
    procedure SQLEditor(Sender: TObject);
    procedure ParamsEditor(Sender: TObject);
    function GetParamCount: Integer;
    function GetSQL: string;
    procedure SetSQL(aSql: string);
  protected
    FParams: TRMVariables;
    procedure OnBeforeOpenQueryEvent(DataSet: TDataSet); virtual;
    function DoMethod(const MethodName: string; Pars: array of Variant): Variant; override;

    function GetParamName(Index: Integer): string; virtual; abstract;
    function GetParamType(Index: Integer): TFieldType; virtual; abstract;
    procedure SetParamType(Index: Integer; Value: TFieldType); virtual; abstract;
    function GetParamKind(Index: Integer): TRMParamKind; virtual; abstract;
    procedure SetParamKind(Index: Integer; Value: TRMParamKind); virtual; abstract;
    function GetParamText(Index: Integer): string; virtual; abstract;
    procedure SetParamText(Index: Integer; Value: string); virtual; abstract;
    function GetParamValue(Index: Integer): Variant; virtual; abstract;
    procedure SetParamValue(Index: Integer; Value: Variant); virtual; abstract;
    procedure GetTableNames(DB: string; Strings: TStrings); virtual; abstract;

    procedure GetTableFieldNames(const DB, TName: string; sl: TStrings); virtual; abstract; //获取表的字段名称列表
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure DefineProperties; override;
    procedure Loaded; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    function ParamIndex(const ParName: string): Integer;

    property EditSQLAsText: Boolean read FEditSQLAsText write FEditSQLAsText;
    property SQL: string read GetSQL write SetSQL;
    property VisualSQL: TStringList read FVisualSQL write FVisualSQL;

    property ParamCount: Integer read GetParamCount;
    property ParamName[Index: Integer]: string read GetParamName; //取得参数的名称
    property ParamType[Index: Integer]: TFieldType read GetParamType write SetParamType; //取得(设置)参数类型
    property ParamKind[Index: Integer]: TRMParamKind read GetParamKind write SetParamKind; //取得(设置)参数初始化类型
    property ParamText[Index: Integer]: string read GetParamText write SetParamText; //取得(设置)参数初始化值
    property ParamValue[Index: Integer]: Variant read GetParamValue write SetParamValue; //取得(设置)参数值

    property OnSQLTextChanged: TNotifyEvent read FOnSQLTextChanged write FOnSQLTextChanged;
  published
  end;

function RMFindFieldDef(DataSet: TDataSet; FieldName: string): TFieldDef;
function RMGetDataSetName(Owner: TComponent; d: TDataSource): string;
function RMGetDataSource(Owner: TComponent; d: TDataSet): TDataSource;

implementation

uses RM_Const, RM_Utils, RMD_DBFldEditor, RMD_md, RMD_QueryParm, RMD_QryDesigner,
  RMD_DataPrv, RM_DCtrl, RM_DBCtrls;

function RMFindFieldDef(DataSet: TDataSet; FieldName: string): TFieldDef;
var
  i: Integer;
begin
  Result := nil;
  with DataSet do
  begin
    for i := 0 to FieldDefs.Count - 1 do
    begin
      if AnsiCompareText(FieldDefs.Items[i].Name, FieldName) = 0 then
      begin
        Result := FieldDefs.Items[i];
        break;
      end;
    end;
  end;
end;

function RMGetDataSetName(Owner: TComponent; d: TDataSource): string;
begin
  Result := '';
  if (d <> nil) and (d.DataSet <> nil) then
  begin
    Result := d.Dataset.Name;
    if d.Dataset.Owner <> Owner then
      Result := d.Dataset.Owner.Name + '.' + Result;
  end;
end;

function RMGetDataSource(Owner: TComponent; d: TDataSet): TDataSource;
var
  i: Integer;
  sl: TStringList;
  ds: TDataSource;
begin
  sl := TStringList.Create;
  Result := nil;
  RMGetComponents(Owner, TDataSource, sl, nil);
  for i := 0 to sl.Count - 1 do
  begin
    ds := RMFindComponent(Owner, sl[i]) as TDataSource;
    if (ds <> nil) and (ds.DataSet = d) then
    begin
      Result := ds;
      break;
    end;
  end;
  sl.Free;
end;


{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDStoredProc}

constructor TRMDStoredProc.Create;
begin
  inherited Create;
  FParams := TRMVariables.Create;

  FDataSource := TDataSource.Create(RMDialogForm);
  FDataSource.DataSet := nil;

  FDBDataSet := TRMDBDataSet.Create(RMDialogForm);
  FDBDataSet.DataSource := FDataSource;

  Flags := Flags or flDontUndo;
end;

destructor TRMDStoredProc.Destroy;
begin
  if Assigned(RMDialogForm) then
  begin
    FDBDataset.Free;
    FDataSource.Free;
    FDataSet.Free;
  end;
  FParams.Free;
  inherited Destroy;
end;

procedure TRMDStoredProc.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('Params', [rmdtHasEditor], ParamsEditor);
end;

procedure TRMDStoredProc.Loaded;
var
  i: Integer;
begin
  try
    Prop['Database'] := FFixupList['Database'];
    for i := 0 to FParamCount - 1 do
    begin
      ParamType[i] := FFixupList['ParamType' + IntToStr(i)];
      ParamKind[i] := FFixupList['ParamKind' + IntToStr(i)];
      ParamText[i] := FFixupList['ParamText' + IntToStr(i)];
    end;
    FDataSet.Active := FFixupList['Active'];
  except
  end;
  inherited Loaded;
end;

function TRMDStoredProc.GetParamCount: Integer;
begin
  Result := Prop['Params.Count'];
end;

function TRMDStoredProc.ParamIndex(const ParName: string): Integer;
var
  i: Integer;
begin
  Result := -1;
  for i := 0 to ParamCount - 1 do
  begin
    if AnsiCompareText(ParamName[i], ParName) = 0 then
    begin
      Result := i;
      Exit;
    end;
  end;
end;

procedure TRMDStoredProc.LoadFromStream(Stream: TStream);

  procedure ReadParams;
  var
    i: Integer;
    w: Word;
  begin
    Stream.Read(FParamCount, 2);
    for i := 0 to FParamCount - 1 do
    begin
      Stream.Read(w, 2);
      FFixupList['ParamType' + IntToStr(i)] := RMParamTypes[w];
      Stream.Read(w, 2);
      FFixupList['ParamKind' + IntToStr(i)] := TRMParamKind(w);
      FFixupList['ParamText' + IntToStr(i)] := RMReadString(Stream);
    end;
  end;

begin
  inherited LoadFromStream(Stream);
  ReadParams;
end;

procedure TRMDStoredProc.SaveToStream(Stream: TStream);

  procedure WriteParams;
  var
    i: Integer;
    count, j: Word;
  begin
    count := ParamCount;
    Stream.Write(count, 2);
    for i := 0 to count - 1 do
    begin
      for j := Low(RMParamTypes) to High(RMParamTypes) do
      begin
        if ParamType[i] = RMParamTypes[j] then
          Break;
      end;
      Stream.Write(j, 2);
      j := Word(ParamKind[i]);
      Stream.Write(j, 2);
      RMWriteString(Stream, ParamText[i]);
    end;
  end;

begin
  inherited SavetoStream(Stream);
  WriteParams;
end;

procedure TRMDStoredProc.ParamsEditor(Sender: TObject);
begin
  if ParamCount > 0 then
  begin
    with TRMDParamsForm.Create(nil) do
    begin
      Query := TRMDQuery(Self);
      Caption := Self.Name + ' ' + RMLoadStr(SParams);
      if ShowModal = mrOk then
        RMDesigner.Modified := True;
      Free;
    end;
  end;
end;

procedure TRMDStoredProc.OnBeforeOpenQueryEvent(DataSet: TDataSet);
var
  i: Integer;
  SaveView: TRMView;
  SavePage: TRMPage;
  SaveBand: TRMBand;

  function DefParamValue(index: Integer): string;
  begin
    if ParamType[index] in [ftDate, ftDateTime] then
      Result := '01.01.00'
    else if ParamType[index] = ftTime then
      Result := '00:00'