rmd_bde.pas

report machine 2.3 功能强大

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

unit RMD_BDE;

interface

{$I RM.INC}

{$IFDEF DM_BDE}
uses
  Windows, Classes, SysUtils, Forms, Dialogs, ExtCtrls, StdCtrls, Controls, DB,
  DBTables, RM_Class, RMD_DBWrap
{$IFDEF Delphi6}, Variants{$ENDIF};

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

 { TRMDBDEDatabase }
  TRMDBDEDatabase = class(TRMNonVisualControl)
  private
    FDatabase: TDatabase;
    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: TDatabase read FDatabase;
  end;

  { TRMDBDETable }
  TRMDBDETable = class(TRMDTable)
  private
    FTable: TTable;
  protected
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;

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

  { TRMDBDEQuery}
  TRMDBDEQuery = class(TRMDQuery)
  private
    FQuery: TQuery;
  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 LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
  published
  end;

  { TDBEditForm }
  TRMDFormBDEDBProp = class(TForm)
    GroupBox1: TGroupBox;
    Label1: TLabel;
    cmbAliasName: TComboBox;
    Label2: TLabel;
    cmbDriverName: TComboBox;
    Label3: TLabel;
    memDatabaseParams: TMemo;
    btnDefaultsParam: TButton;
    btnClearParam: TButton;
    btnOK: TButton;
    btnCancel: TButton;
    Label4: TLabel;
    edtDBName: TEdit;
    btnPath: TButton;
    procedure cmbAliasNameChange(Sender: TObject);
    procedure cmbAliasNameDropDown(Sender: TObject);
    procedure cmbDriverNameChange(Sender: TObject);
    procedure cmbDriverNameDropDown(Sender: TObject);
    procedure btnDefaultsParamClick(Sender: TObject);
    procedure btnClearParamClick(Sender: TObject);
    procedure btnOKClick(Sender: TObject);
    procedure btnPathClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    FDatabase: TDatabase;
    function Edit: Boolean;
    procedure Localize;
  end;
{$ENDIF}

implementation

{$IFDEF DM_BDE}
{$R *.DFM}
{$R RMD_BDE.RES}

uses BdeConst, BDE, RM_Utils, RM_CmpReg, RM_Const, ShlObj, ActiveX;

function RMSelectDirectory(const Caption: string; const Root: WideString;
  out Directory: string): Boolean;
var
  WindowList: Pointer;
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: LongWord;
begin
  Result := False;
  Directory := '';
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  begin
    Buffer := ShellMalloc.Alloc(MAX_PATH);
    try
      RootItemIDList := nil;
      if Root <> '' then
      begin
        SHGetDesktopFolder(IDesktopFolder);
        IDesktopFolder.ParseDisplayName(Application.Handle, nil,
          POleStr(Root), Eaten, RootItemIDList, Flags);
      end;
      with BrowseInfo do
      begin
        hwndOwner := Application.Handle;
        pidlRoot := RootItemIDList;
        pszDisplayName := Buffer;
        lpszTitle := PChar(Caption);
        ulFlags := BIF_RETURNONLYFSDIRS;
      end;
      WindowList := DisableTaskWindows(0);
      try
        ItemIDList := ShBrowseForFolder(BrowseInfo);
      finally
        EnableTaskWindows(WindowList);
      end;
      Result :=  ItemIDList <> nil;
      if Result then
      begin
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory := Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDBDEDatabase}

constructor TRMDBDEDatabase.Create;
begin
  inherited Create;
  FDatabase := TDataBase.Create(RMDialogForm);
  Component := FDatabase;
  BaseName := 'Database';

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

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

procedure TRMDBDEDatabase.DefineProperties;

  function GetAliasNames: string;
  var
    i: Integer;
    sl: TStringList;
  begin
    Result := '';
    sl := TStringList.Create;
    Session.GetAliasNames(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;
    Session.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;
  AddEnumProperty('AliasName', GetAliasNames, [Null]);
  AddProperty('Connected', [rmdtBoolean], nil);
  AddProperty('DatabaseName', [rmdtString], nil);
  AddEnumProperty('DriverName', GetDriverNames, [Null]);
  AddProperty('LoginPrompt', [rmdtBoolean], nil);
  AddProperty('Params', [rmdtHasEditor, rmdtOneObject], PropEditor);
  AddProperty('Params.Count', [], nil);
end;

procedure TRMDBDEDatabase.SetPropValue(Index: string; Value: Variant);
begin
  inherited SetPropValue(Index, Value);
  Index := AnsiUpperCase(Index);
  if Index = 'DATABASENAME' then
    FDatabase.DatabaseName := 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 = 'ALIASNAME' then
    FDatabase.AliasName := Value
  else if Index = 'PARAMS' then
    FDatabase.Params.Text := Value
end;

function TRMDBDEDatabase.GetPropValue(Index: string): Variant;
begin
  Index := AnsiUpperCase(Index);
  Result := inherited GetPropValue(Index);
  if Result <> Null then Exit;
  if Index = 'DATABASENAME' then
    Result := FDatabase.DatabaseName
  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 = 'ALIASNAME' then
    Result := FDatabase.AliasName
  else if Index = 'PARAMS.COUNT' then
    Result := FDatabase.Params.Count
  else if Index = 'PARAMS' then
    Result := FDatabase.Params.Text
end;

function TRMDBDEDatabase.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 TRMDBDEDatabase.LoadFromStream(Stream: TStream);
var
  s: string;
begin
  inherited LoadFromStream(Stream);
  FDatabase.DatabaseName := RMReadString(Stream);
  s := RMReadString(Stream);
  if s <> '' then
    FDatabase.AliasName := s;
  s := RMReadString(Stream);
  if s <> '' then
    FDatabase.DriverName := s;
  FDatabase.LoginPrompt := RMReadBoolean(Stream);
  RMReadMemo(Stream, FDatabase.Params);
  FDatabase.Connected := RMReadBoolean(Stream);
end;

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

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

procedure TRMDBDEDatabase.PropEditor(Sender: TObject);
begin
  RMDesigner.BeforeChange;
  with TRMDFormBDEDBProp.Create(Application) do
  begin
    try
      FDatabase := Self.FDatabase;
      if Edit then
        RMDesigner.AfterChange;
    finally
      Free;
    end;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDBDETable}

constructor TRMDBDETable.Create;
begin
  inherited Create;
  FTable := TTable.Create(RMDialogForm);
  DataSet := FTable;

  Component := FTable;
  BaseName := 'Table';
  Bmp.LoadFromResourceName(hInstance, 'RMD_BDETABLE');
end;

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

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

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

procedure TRMDBDETable.GetIndexNames(sl: TStrings);
var
  i: integer;
begin
	try
	  if (Length(FTable.TableName) > 0) and (FTable.IndexDefs <> nil) then
  	begin
    	FTable.IndexDefs.Update;
	    for i := 0 to FTable.IndexDefs.Count - 1 do
  	  begin
    	  if FTable.IndexDefs[i].Name <> '' then
      	  sl.Add(FTable.IndexDefs[i].Name);
	    end;
  	end;