rmd_diamond.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 711 行 · 第 1/2 页

{*****************************************}
{                                         }
{           Report Machine 2.0           }
{       Wrapper for Diamond Access        }
{                                         }
{*****************************************}

unit RMD_Diamond;

interface

{$I RM.INC}
uses
  Classes, SysUtils, Forms, ExtCtrls, DB, DAODatabase, DAODataset, DAOMDTable,
  DAOQuery, DAOTable, DAOTlb, Dialogs, Controls, StdCtrls, RM_Class, RMD_DBWrap,
  JvInterpreter
{$IFDEF Delphi6}, Variants{$ENDIF};

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

  TRMDDiamondDatabase = class(TRMDialogComponent)
  private
    FDatabase: TDAODatabase;

    function GetConnected: Boolean;
    procedure SetConnected(Value: Boolean);
    function GetDAOVersion: TDAOVersion;
    procedure SetDAOVersion(Value: TDAOVersion);
    function GetWorkspace: TWorkspace;
    procedure SetWorkspace(Value: TWorkspace);
    function GetDatabaseName: string;
    procedure SetDatabaseName(Value: string);
  protected
    procedure AfterChangeName; override;
    procedure PropEditor(Sender: TObject);
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(aStream: TStream); override;
    procedure SaveToStream(aStream: TStream); override;
    procedure ShowEditor; override;
  published
    property Database: TDAODatabase read FDatabase;
    property DatabaseName: string read GetDatabaseName write SetDatabaseName;
    property Connected: Boolean read GetConnected write SetConnected;
    property DAOVersion: TDAOVersion read GetDAOVersion write SetDAOVersion;
    property Workspace: TWorkspace read GetWorkspace write SetWorkspace;
  end;

 { TRMDDiamondTable }
  TRMDDiamondTable = class(TRMDTable)
  private
    FTable: TDAOMasterDetailTable;
  protected
    function GetTableName: string; override;
    procedure SetTableName(Value: string); override;
    function GetFilter: string; override;
    procedure SetFilter(Value: string); override;
    function GetIndexName: string; override;
    procedure SetIndexName(Value: string); override;
    function GetMasterFields: string; override;
    procedure SetMasterFields(Value: string); override;
    function GetMasterSource: string; override;
    procedure SetMasterSource(Value: string); override;
    function GetDatabaseName: string; override;
    procedure SetDatabaseName(const Value: string); override;
    procedure GetIndexNames(sl: TStrings); override;
  public
    constructor Create; override;
    procedure LoadFromStream(aStream: TStream); override;
    procedure SaveToStream(aStream: TStream); override;
  end;

  { TRMDDiamondQuery }
  TRMDDiamondQuery = class(TRMDQuery)
  private
    FQuery: TDAOQuery;
  protected
    function GetParamCount: Integer; override;
    function GetSQL: string; override;
    procedure SetSQL(Value: string); override;
    function GetFilter: string; override;
    procedure SetFilter(Value: string); override;
    function GetDatabaseName: string; override;
    procedure SetDatabaseName(const Value: string); override;
    function GetDataSource: string; override;
    procedure SetDataSource(Value: string); 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;

    procedure GetDatabases(sl: TStrings); override;
    procedure GetTableNames(DB: string; Strings: TStrings); override;
    procedure GetTableFieldNames(const DB, TName: string; sl: TStrings); override;
  public
    constructor Create; override;
    procedure LoadFromStream(aStream: TStream); override;
    procedure SaveToStream(aStream: TStream); override;
  published
  end;

implementation

uses RM_Const, RM_Common, RM_utils, RM_PropInsp, RM_Insp;

{$R RMD_Diamond.RES}

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDDiamondDatabase}

constructor TRMDDiamondDatabase.Create;
begin
  inherited Create;
  Typ := gtAddin;
  BaseName := 'DAODatabase';
  FBmpRes := 'RMD_DiamondDB';

  DontUndo := True;
  FDatabase := TDAODatabase.Create(RMDialogForm);
end;

destructor TRMDDiamondDatabase.Destroy;
begin
  if Assigned(RMDialogForm) then
  begin
    FDatabase.Free;
    FDatabase := nil;
  end;
  inherited Destroy;
end;

procedure TRMDDiamondDatabase.AfterChangeName;
begin
  FDatabase.Name := Name;
end;

procedure TRMDDiamondDatabase.LoadFromStream(aStream: TStream);
begin
  inherited LoadFromStream(aStream);
  RMReadWord(aStream);
  FDatabase.DatabaseName := RMReadString(aStream);
  FDatabase.DAOVersion := TDAOVersion(RMReadByte(aStream));
  FDatabase.Workspace.UserName := RMReadString(aStream);
  FDatabase.Workspace.Password := RMReadString(aStream);
  FDatabase.Connected := RMReadBoolean(aStream);
end;

procedure TRMDDiamondDatabase.SaveToStream(aStream: TStream);
begin
  inherited SaveToStream(aStream);
  RMWriteWord(aStream, 0);
  RMWriteString(aStream, FDatabase.DatabaseName);
  RMWriteByte(aStream, Byte(FDatabase.DAOVersion));
  RMWriteString(aStream, FDatabase.Workspace.UserName);
  RMWriteString(aStream, FDatabase.Workspace.Password);
  RMWriteBoolean(aStream, FDatabase.Connected);
end;

function TRMDDiamondDatabase.GetDatabaseName: string;
begin
  Result := FDatabase.DatabaseName;
end;

procedure TRMDDiamondDatabase.SetDatabaseName(Value: string);
begin
  FDatabase.DatabaseName := Value;
end;

function TRMDDiamondDatabase.GetConnected: Boolean;
begin
  Result := FDatabase.Connected;
end;

procedure TRMDDiamondDatabase.SetConnected(Value: Boolean);
begin
  FDatabase.Connected := Value;
end;

function TRMDDiamondDatabase.GetDAOVersion: TDAOVersion;
begin
  Result := FDatabase.DAOVersion;
end;

procedure TRMDDiamondDatabase.SetDAOVersion(Value: TDAOVersion);
begin
  FDatabase.DAOVersion := Value;
end;

function TRMDDiamondDatabase.GetWorkspace: TWorkspace;
begin
  Result := FDatabase.Workspace;
end;

procedure TRMDDiamondDatabase.SetWorkspace(Value: TWorkspace);
begin
  FDatabase.Workspace := Value;
end;

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

procedure TRMDDiamondDatabase.PropEditor(Sender: TObject);
var
  OpenDialog: TOpenDialog;
begin
  OpenDialog := TOpenDialog.Create(nil);
  OpenDialog.Filter := '*.mdb|*.mdb';
  try
    if OpenDialog.Execute then
    begin
      FDatabase.DatabaseName := OpenDialog.FileName;
    end;
  finally
    OpenDialog.Free;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDDiamondTable}

constructor TRMDDiamondTable.Create;
begin
  inherited Create;
  Typ := gtAddin;
  BaseName := 'DAOMasterDetailTable';
  FBmpRes := 'RMD_DiamondTABLE';

  FTable := TDAOMasterDetailTable.Create(RMDialogForm);
  DataSet := FTable;
end;

procedure TRMDDiamondTable.LoadFromStream(aStream: TStream);
begin
  inherited LoadFromStream(aStream);
  RMReadWord(aStream);
end;

procedure TRMDDiamondTable.SaveToStream(aStream: TStream);
begin
  inherited SaveToStream(aStream);
  RMWriteWord(aStream, 0);
end;

function TRMDDiamondTable.GetTableName: string;
begin
  Result := FTable.TableName;
end;

procedure TRMDDiamondTable.SetTableName(Value: string);
begin
  FTable.Close;
  FTable.TableName := Value;
end;

function TRMDDiamondTable.GetFilter: string;
begin
  Result := FTable.Filter;
end;

procedure TRMDDiamondTable.SetFilter(Value: string);
begin
  FTable.Filter := Value;
end;

function TRMDDiamondTable.GetIndexName: string;
begin
  Result := FTable.IndexFieldNames;
end;

procedure TRMDDiamondTable.SetIndexName(Value: string);
begin
  FTable.IndexFieldNames := Value;
end;

function TRMDDiamondTable.GetMasterFields: string;
begin
  Result := FTable.MasterFields;
end;

procedure TRMDDiamondTable.SetMasterFields(Value: string);
begin
  FTable.MasterFields := Value;
end;

function TRMDDiamondTable.GetMasterSource: string;
begin
  Result := '';
  if FTable.MasterSource <> nil then
  begin
    Result := FTable.MasterSource.Name;
    if FTable.MasterSource.Owner <> FTable.Owner then
      Result := FTable.MasterSource.Owner.Name + '.' + Result;
  end;
end;

procedure TRMDDiamondTable.SetMasterSource(Value: string);
var
  lComponent: TComponent;
begin
  lComponent := RMFindComponent(FTable.Owner, Value);
  FTable.MasterSource := RMGetDataSource(FTable.Owner, TDataSet(lComponent));
end;

function TRMDDiamondTable.GetDatabaseName: string;
begin
  Result := '';
  if FTable.Database <> nil then
  begin
    Result := FTable.Database.Name;
    if FTable.Database.Owner <> FTable.Owner then
      Result := FTable.Database.Owner.Name + '.' + Result;
  end;
end;

procedure TRMDDiamondTable.SetDatabaseName(const Value: string);
var
  lComponent: TComponent;
begin
  FTable.Close;
  lComponent := RMFindComponent(FTable.Owner, Value);
  FTable.Database := TDAODatabase(lComponent);
end;

procedure TRMDDiamondTable.GetIndexNames(sl: TStrings);
begin
  sl.Clear;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDDiamondQuery}

constructor TRMDDiamondQuery.Create;
begin
  inherited Create;
  Typ := gtAddin;
  BaseName := 'DAOQuery';
  FBmpRes := 'RMD_DiamondQUERY';

  FQuery := TDAOQuery.Create(RMDialogForm);
  DataSet := FQuery;
end;