rmd_dbx.pas

来自「report machine 2.3 功能强大」· PAS 代码 · 共 955 行 · 第 1/2 页

{*****************************************}
{                                         }
{           Report Machine v2.0           }
{             Wrapper for Dbx             }
{                                         }
{*****************************************}

unit RMD_Dbx;

interface

{$I RM.INC}

{$IFDEF DM_DBX}
uses
  Windows, Classes, SysUtils, Forms, Dialogs, ExtCtrls, StdCtrls, Controls, DB,
  SqlExpr, DBLocalS, RM_Class, RMD_DBWrap
{$IFDEF Delphi6}, Variants, ValEdit, Menus{$ENDIF};

type
  TRMDDBXComponents = class(TComponent) // fake component
  end;

 { TRMDDBXDatabase }
  TRMDDBXDatabase = class(TRMNonVisualControl)
  private
    FDatabase: TSQLConnection;
    procedure PropEditor(Sender: TObject);
  protected
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
    function DoMethod(const MethodName: string; Par1, Par2, Par3: Variant): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;
    property Database: TSQLConnection read FDatabase;
  end;

 { TRMDDBXTable }
  TRMDDBXTable = class(TRMDTable)
  private
    FTable: TSQLTable;
  protected
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
    procedure GetIndexNames(sl: TStrings); override;

    function GetDatabases: string; override;
    function GetTableNames: string; override;
  public
    constructor Create; override;
    procedure DefineProperties; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
  end;

  { TRMDDBXQuery}
{  TRMDDBXQuery = class(TRMDQuery)
  private
    FQuery: TSQLQuery;
  protected
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
    function DoMethod(const MethodName: string; Par1, Par2, Par3: Variant): Variant; override;

    function GetParamName(Index: Integer): string; override;
    function GetParamType(Index: Integer): TFieldType; override;
    procedure SetParamType(Index: Integer; Value: TFieldType); override;
    function GetParamKind(Index: Integer): TRMParamKind; override;
    procedure SetParamKind(Index: Integer; Value: TRMParamKind); override;
    function GetParamText(Index: Integer): string; override;
    procedure SetParamText(Index: Integer; Value: string); override;
    function GetParamValue(Index: Integer): Variant; override;
    procedure SetParamValue(Index: Integer; Value: Variant); override;

    function GetDatabases: string; override;
    procedure GetTableNames(DB: string; Strings: TStrings); override;
    procedure GetTableFieldNames(const DB, TName: string; sl: TStrings); override;
  public
    constructor Create; override;
    procedure DefineProperties; override;
  published
  end;
}

  { TRMDDBXQuery}
  TRMDDBXQuery = class(TRMDQuery)
  private
    FQuery: TSQLClientDataSet;

    procedure OnSQLTextChangedEvent(Sender: TObject);
  protected
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
    function DoMethod(const MethodName: string; Par1, Par2, Par3: Variant): Variant; override;

    function GetParamName(Index: Integer): string; override;
    function GetParamType(Index: Integer): TFieldType; override;
    procedure SetParamType(Index: Integer; Value: TFieldType); override;
    function GetParamKind(Index: Integer): TRMParamKind; override;
    procedure SetParamKind(Index: Integer; Value: TRMParamKind); override;
    function GetParamText(Index: Integer): string; override;
    procedure SetParamText(Index: Integer; Value: string); override;
    function GetParamValue(Index: Integer): Variant; override;
    procedure SetParamValue(Index: Integer; Value: Variant); override;

    function GetDatabases: string; override;
    procedure GetTableNames(DB: string; Strings: TStrings); override;
    procedure GetTableFieldNames(const DB, TName: string; sl: TStrings); override;
  public
    constructor Create; override;
    procedure DefineProperties; override;
  published
  end;

  { TDBEditForm }
  TRMDFormDbxDBProp = class(TForm)
    btnOK: TButton;
    btnCancel: TButton;
    StringEditorMenu: TPopupMenu;
    LoadItem: TMenuItem;
    SaveItem: TMenuItem;
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    procedure btnOKClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure LoadItemClick(Sender: TObject);
    procedure SaveItemClick(Sender: TObject);
  private
    FValueListEditor: TValueListEditor;

    procedure Localize;
  end;
{$ENDIF}

implementation

{$IFDEF DM_DBX}
{$R *.DFM}
{$R RMD_DBX.RES}

uses RM_Utils, RM_CmpReg, RM_Const;

type
  THackSQLConnection = class(TSQLConnection)
  end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDDBXDatabase}

constructor TRMDDBXDatabase.Create;
begin
  inherited Create;
  FDatabase := TSQLConnection.Create(RMDialogForm);
  THackSQLConnection(FDataBase).SetDesigning(True, False);
  Component := FDatabase;
  BaseName := 'DBXDatabase';

  Bmp.LoadFromResourceName(hInstance, 'RMD_DBXDB');
  Flags := Flags or flDontUndo;
end;

destructor TRMDDBXDatabase.Destroy;
begin
  if Assigned(RMDialogForm) then
    FDatabase.Free;
  inherited Destroy;
end;

procedure TRMDDBXDatabase.DefineProperties;

  function _GetConnectionNames: string;
  var
    i: Integer;
    sl: TStringList;
  begin
    Result := '';
    sl := TStringList.Create;
    GetConnectionNames(sl);
    sl.Sort;
    for i := 0 to sl.Count - 1 do
      Result := Result + sl[i] + ';';
    sl.Free;
  end;

  function _GetDriverNames: string;
  var
    i, j: Integer;
    sl: TStringList;
    s: string;
  begin
    Result := '';
    sl := TStringList.Create;
    GetDriverNames(sl);
    sl.Sort;
    for i := 0 to sl.Count - 1 do
    begin
      s := sl[i];
      for j := 1 to Length(s) do
        if s[j] = ';' then
          s[j] := ',';
      Result := Result + s + ';';
    end;
    sl.Free;
  end;

begin
  inherited DefineProperties;
  AddProperty('Connected', [rmdtBoolean], nil);
  AddEnumProperty('ConnectionName', _GetConnectionNames, [Null]);
  AddEnumProperty('DriverName', _GetDriverNames, [Null]);
  AddProperty('LoginPrompt', [rmdtBoolean], nil);
  AddProperty('Params', [rmdtHasEditor, rmdtOneObject], PropEditor);
  AddProperty('Params.Count', [], nil);
end;

procedure TRMDDBXDatabase.SetPropValue(Index: string; Value: Variant);
begin
  inherited SetPropValue(Index, Value);
  Index := AnsiUpperCase(Index);
  if Index = 'CONNECTIONNAME' then
    FDatabase.ConnectionName := Value
  else if Index = 'DRIVERNAME' then
    FDatabase.DriverName := Value
  else if Index = 'LOGINPROMPT' then
    FDatabase.LoginPrompt := Value
  else if Index = 'CONNECTED' then
    FDatabase.Connected := Value
  else if Index = 'PARAMS' then
    FDatabase.Params.Text := Value
end;

function TRMDDBXDatabase.GetPropValue(Index: string): Variant;
begin
  Index := AnsiUpperCase(Index);
  Result := inherited GetPropValue(Index);
  if Result <> Null then Exit;
  if Index = 'CONNECTIONNAME' then
    Result := FDatabase.ConnectionName
  else if Index = 'DRIVERNAME' then
    Result := FDatabase.DriverName
  else if Index = 'LOGINPROMPT' then
    Result := FDatabase.LoginPrompt
  else if Index = 'CONNECTED' then
    Result := FDatabase.Connected
  else if Index = 'PARAMS.COUNT' then
    Result := FDatabase.Params.Count
  else if Index = 'PARAMS' then
    Result := FDatabase.Params.Text
end;

function TRMDDBXDatabase.DoMethod(const MethodName: string; Par1, Par2, Par3: Variant): Variant;
begin
  Result := inherited DoMethod(MethodName, Par1, Par2, Par3);
  if Result = Null then
    Result := LinesMethod(FDataBase.Params, MethodName, 'PARAMS', Par1, Par2, Par3);
end;

procedure TRMDDBXDatabase.LoadFromStream(Stream: TStream);
var
  s: string;
begin
  inherited LoadFromStream(Stream);
  FDatabase.ConnectionName := RMReadString(Stream);
  s := RMReadString(Stream);
  if s <> '' then
    FDatabase.DriverName := s;
  FDatabase.LoginPrompt := RMReadBoolean(Stream);
  RMReadMemo(Stream, FDatabase.Params);
  FDatabase.Connected := RMReadBoolean(Stream);
end;

procedure TRMDDBXDatabase.SaveToStream(Stream: TStream);
begin
  LVersion := 0;
  inherited SaveToStream(Stream);
  RMWriteString(Stream, FDatabase.ConnectionName);
  RMWriteString(Stream, FDatabase.DriverName);
  RMWriteBoolean(Stream, FDatabase.LoginPrompt);
  RMWriteMemo(Stream, FDatabase.Params);
  RMWriteBoolean(Stream, FDatabase.Connected);
end;

procedure TRMDDBXDatabase.ShowEditor;
begin
  PropEditor(nil);
end;

procedure TRMDDBXDatabase.PropEditor(Sender: TObject);
var
  SaveConnected: Boolean;
begin
  with TRMDFormDbxDBProp.Create(Application) do
  begin
    FValueListEditor.Strings.Assign(FDatabase.Params);
    if (ShowModal = mrOk) and ((Restrictions and rmrfDontModify) = 0) then
    begin
      RMDesigner.BeforeChange;
      SaveConnected := FDatabase.Connected;
      FDatabase.Connected := False;
      FDatabase.Params.Assign(FValueListEditor.Strings);
      FDatabase.Connected := SaveConnected;
      RMDesigner.AfterChange;
    end;
    Free;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDDBXTable}

constructor TRMDDBXTable.Create;
begin
  inherited Create;
  FCanBrowse := False;
  FHaveFilter := False;
  FTable := TSQLTable.Create(RMDialogForm);
  DataSet := FTable;

  Component := FTable;
  BaseName := 'DBXTable';
  Bmp.LoadFromResourceName(hInstance, 'RMD_DBXTABLE');
end;

function TRMDDBXTable.GetDatabases: string;
var
  i: Integer;
  sl: TStringList;
begin
  Result := '';
  sl := TStringList.Create;
  RMGetComponents(RMDialogForm, TSQLConnection, sl, nil);
  sl.Sort;
  for i := 0 to sl.Count - 1 do
    Result := Result + sl[i] + ';';
  sl.Free;
end;

procedure TRMDDBXTable.GetIndexNames(sl: TStrings);
var
  i: integer;
begin
  try
		with FTable do
    begin
	    if TableName <> '' then
  	  begin
//    	  IndexDefs.Update;
      	for i := 0 to IndexFieldCount - 1 do
	      begin
        	sl.Add(IndexFields[i].Name);
      	end;
	    end;
    end;
  except
  end;
end;

function TRMDDBXTable.GetTableNames: string;
var
  i: Integer;
  sl: TStringList;
begin
  Result := '';
  if FTable.SQLConnection <> nil then
  begin
    sl := TStringList.Create;
    try
      try
        FTable.SQLConnection.GetTableNames(sl);
        sl.Sort;
        for i := 0 to sl.Count - 1 do
          Result := Result + sl[i] + ';';
      except
      end;
    finally
      sl.Free;
    end;
  end;
end;

procedure TRMDDBXTable.DefineProperties;
begin
  inherited DefineProperties;
end;

procedure TRMDDBXTable.SetPropValue(Index: string; Value: Variant);
var
  d: TComponent;
begin
  inherited SetPropValue(Index, Value);
  Index := AnsiUpperCase(Index);
  if Index = 'INDEXNAME' then
    FTable.IndexName := Value
  else if Index = 'MASTERSOURCE' then
  begin
    d := RMFindComponent(FTable.Owner, Value);
    FTable.MasterSource := RMGetDataSource(FTable.Owner, TDataSet(d));
  end
  else if Index = 'MASTERFIELDS' then
    FTable.MasterFields := Value
  else if Index = 'TABLENAME' then
  begin
    FTable.Close;
    FTable.TableName := Value;
  end
  else if index = 'DATABASE' then
  begin
    FTable.Close;
    d := RMFindComponent(FTable.Owner, Value);
    FTable.SQLConnection := TSQLConnection(d);
  end;
end;

function TRMDDBXTable.GetPropValue(Index: string): Variant;

  function GetDataBase(Owner: TComponent; d: TSQLConnection): string;
  begin
    Result := '';
    if d <> nil then
    begin
      Result := d.Name;
      if d.Owner <> Owner then
        Result := d.Owner.Name + '.' + Result;
    end;
  end;

begin
  Index := AnsiUpperCase(Index);
  Result := inherited GetPropValue(Index);
  if Result <> Null then Exit;
  if Index = 'INDEXNAME' then
    Result := FTable.IndexName
  else if Index = 'MASTERSOURCE' then
    Result := RMGetDataSetName(FTable.Owner, FTable.MasterSource)
  else if Index = 'MASTERFIELDS' then
    Result := FTable.MasterFields
  else if Index = 'TABLENAME' then
    Result := FTable.TableName
  else if Index = 'DATABASE' then
    Result := GetDataBase(FTable.Owner, FTable.SQLConnection);
end;

procedure TRMDDBXTable.LoadFromStream(Stream: TStream);
begin
  inherited LoadFromStream(Stream);
end;

procedure TRMDDBXTable.SaveToStream(Stream: TStream);
begin
  LVersion := 0;
  inherited SaveToStream(Stream);
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDDBXQuery}

{constructor TRMDDBXQuery.Create;
begin
  inherited Create;
  FHaveFilter := False;
  FCanBrowse := False;
  FQuery := TSQLQuery.Create(RMDialogForm);
  DataSet := FQuery;

  Component := FQuery;
  BaseName := 'DBXQuery';
  Bmp.LoadFromResourceName(hInstance, 'RMD_DBXQUERY');
end;