Chip 1997 April/Chip_1997-04_cd.bin/prezent/cb/data.z/DBREG.PAS

Pascal/Delphi Source File | 1997-01-16 | 22KB | 797 lines

{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1995,96 Borland International     }
{                                                       }
{*******************************************************}

unit DBReg;

interface

procedure Register;

implementation

uses
  SysUtils, Classes, DsgnIntf, Controls, Forms, DB, DBTables, DBCtrls,
  DBGrids,
  DBCGrids,
  Report,
  MaskProp, MaskText, Mask, DBConsts, DBLookup, DSDesign, DBEdit, FldLinks,
  TypInfo, EditIntf, ExptIntf, ToolIntf, LibConst, QBE, QBindDlg, ProcDlg,
  IxEdit, dbColEdt, DbxTarg, UpdSqlEd, DbXPlor, DBExpt, DBInpReq;

{ TDataSetEditor }

type
  TDataSetEditor = class(TComponentEditor)
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

procedure TDataSetEditor.ExecuteVerb(Index: Integer);
begin
  case Index of
    0: ShowDatasetDesigner(Designer, TTable(Component));
    1: ExploreDataset(TDBDataset(Component));
  end;
end;

function TDataSetEditor.GetVerb(Index: Integer): string;
begin
  case Index of
    0: Result := LoadStr(SDatasetDesigner);
    1: Result := LoadStr(SExplore);
  end;
end;

function TDataSetEditor.GetVerbCount: Integer;
begin
  Result := Ord(Component is TDBDataset) + 1;
end;

{ TDatabaseEditor }

type
  TDatabaseEditor = class(TComponentEditor)
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

procedure TDatabaseEditor.ExecuteVerb(Index: Integer);
begin
  case Index of
    0: if EditDatabase(TDatabase(Component)) then Designer.Modified;
    1: ExploreDatabase(TDatabase(Component));
  end;
end;

function TDatabaseEditor.GetVerb(Index: Integer): string;
begin
  case Index of
    0: Result := LoadStr(SDatabaseEditor);
    1: Result := LoadStr(SExplore);
  end;
end;

function TDatabaseEditor.GetVerbCount: Integer;
begin
  Result := 2;
end;

{ TBatchMoveEditor }

type
  TBatchMoveEditor = class(TDefaultEditor)
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

procedure TBatchMoveEditor.ExecuteVerb(Index: Integer);
begin
  TBatchMove(Component).Execute;
end;

function TBatchMoveEditor.GetVerb(Index: Integer): string;
begin
  Result := LoadStr(SBatchExecute);
end;

function TBatchMoveEditor.GetVerbCount: Integer;
begin
  Result := 1;
end;

{ TDataSetProperty }

type
  TDataSetProperty = class(TComponentProperty)
  private
    FCheckProc: TGetStrProc;
    procedure CheckComponent(const Value: string);
  public
    procedure GetValues(Proc: TGetStrProc); override;
  end;

procedure TDataSetProperty.CheckComponent(const Value: string);
var
  J: Integer;
  Dataset: TDataset;
begin
  Dataset := TDataset(Designer.GetComponent(Value));
  for J := 0 to PropCount - 1 do
    if TDataSource(GetComponent(J)).IsLinkedTo(Dataset) then
      Exit;
  FCheckProc(Value);
end;

procedure TDataSetProperty.GetValues(Proc: TGetStrProc);
begin
  FCheckProc := Proc;
  inherited GetValues(CheckComponent);
end;

{ TDataSourceProperty }

type
  TDataSourceProperty = class(TComponentProperty)
  private
    FCheckProc: TGetStrProc;
    procedure CheckComponent(const Value: string);
  public
    procedure GetValues(Proc: TGetStrProc); override;
  end;

procedure TDataSourceProperty.CheckComponent(const Value: string);
var
  J: Integer;
  DataSource: TDataSource;
begin
  DataSource := TDataSource(Designer.GetComponent(Value));
  for J := 0 to PropCount - 1 do
    if TDataSet(GetComponent(J)).IsLinkedTo(DataSource) then
      Exit;
  FCheckProc(Value);
end;

procedure TDataSourceProperty.GetValues(Proc: TGetStrProc);
begin
  FCheckProc := Proc;
  inherited GetValues(CheckComponent);
end;

{ TDBStringProperty }

type
  TDBStringProperty = class(TStringProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure GetValueList(List: TStrings); virtual; abstract;
    procedure GetValues(Proc: TGetStrProc); override;
  end;

function TDBStringProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paValueList, paSortList, paMultiSelect];
end;

procedure TDBStringProperty.GetValues(Proc: TGetStrProc);
var
  I: Integer;
  Values: TStringList;
begin
  Values := TStringList.Create;
  try
    GetValueList(Values);
    for I := 0 to Values.Count - 1 do Proc(Values[I]);
  finally
    Values.Free;
  end;
end;

{ TSessionNameProperty }

type
  TSessionNameProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TSessionNameProperty.GetValueList(List: TStrings);
begin
  Sessions.GetSessionNames(List);
end;

{ TDatabaseNameProperty }

type
  TDatabaseNameProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TDatabaseNameProperty.GetValueList(List: TStrings);
begin
  (GetComponent(0) as TDBDataSet).DBSession.GetDatabaseNames(List);
end;

{ TAliasNameProperty }

type
  TAliasNameProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TAliasNameProperty.GetValueList(List: TStrings);
begin
  (GetComponent(0) as TDatabase).Session.GetAliasNames(List);
end;

{ TDriverNameProperty }

type
  TDriverNameProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TDriverNameProperty.GetValueList(List: TStrings);
begin
  (GetComponent(0) as TDatabase).Session.GetDriverNames(List);
end;

{ TTableNameProperty }

type
  TTableNameProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TTableNameProperty.GetValueList(List: TStrings);
const
  Masks: array[TTableType] of string[5] = ('', '*.DB', '*.DBF', '*.TXT');
var
  Table: TTable;
begin
  Table := GetComponent(0) as TTable;
  Table.DBSession.GetTableNames(Table.DatabaseName, Masks[Table.TableType],
    Table.TableType = ttDefault, False, List);
end;

{ TIndexNameProperty }

type
  TIndexNameProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TIndexNameProperty.GetValueList(List: TStrings);
begin
  (GetComponent(0) as TTable).GetIndexNames(List);
end;

{ TProcedureNameProperty }

type
  TProcedureNameProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TProcedureNameProperty.GetValueList(List: TStrings);
var
  DBDataSet: TDBDataSet;
begin
  DBDataSet := GetComponent(0) as TDBDataSet;
  DBDataSet.DBSession.GetStoredProcNames(DBDataSet.DatabaseName, List);
end;

{ TIndexFieldNamesProperty }

type
  TIndexFieldNamesProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TIndexFieldNamesProperty.GetValueList(List: TStrings);
var
  I: Integer;
begin
  with GetComponent(0) as TTable do
  begin
    IndexDefs.Update;
    for I := 0 to IndexDefs.Count - 1 do
      with IndexDefs[I] do
        if not (ixExpression in Options) then List.Add(Fields);
  end;
end;

{ TDataFieldProperty }

type
  TDataFieldProperty = class(TDBStringProperty)
  public
    function GetDataSourcePropName: string; virtual;
    procedure GetValueList(List: TStrings); override;
  end;

function TDataFieldProperty.GetDataSourcePropName: string;
begin
  Result := 'DataSource';
end;

procedure TDataFieldProperty.GetValueList(List: TStrings);
var
  Instance: TComponent;
  PropInfo: PPropInfo;
  DataSource: TDataSource;
begin
  Instance := GetComponent(0);
  PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, GetDataSourcePropName);
  if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
  begin
    DataSource := TObject(GetOrdProp(Instance, PropInfo)) as TDataSource;
    if (DataSource <> nil) and (DataSource.DataSet <> nil) then
      DataSource.DataSet.GetFieldNames(List);
  end;
end;

{ TLookupSourceProperty }

type
  TLookupSourceProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TLookupSourceProperty.GetValueList(List: TStrings);
begin
  with GetComponent(0) as TField do
    if DataSet <> nil then DataSet.GetFieldNames(List);
end;

{ TLookupDestProperty }

type
  TLookupDestProperty = class(TDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TLookupDestProperty.GetValueList(List: TStrings);
begin
  with GetComponent(0) as TField do
    if LookupDataSet <> nil then LookupDataSet.GetFieldNames(List);
end;

{ TListFieldProperty }

type
  TListFieldProperty = class(TDataFieldProperty)
  public
    function GetDataSourcePropName: string; override;
  end;

function TListFieldProperty.GetDataSourcePropName: string;
begin
  Result := 'ListSource';
end;

{ TLookupFieldProperty }

type
  TLookupFieldProperty = class(TDataFieldProperty)
  public
    function GetDataSourcePropName: string; override;
  end;

function TLookupFieldProperty.GetDataSourcePropName: string;
begin
  Result := 'LookupSource';
end;

{ TLookupIndexProperty }

type
  TLookupIndexProperty = class(TLookupFieldProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;

procedure TLookupIndexProperty.GetValueList(List: TStrings);
var
  Instance: TComponent;
  PropInfo: PPropInfo;
  DataSource: TDataSource;
begin
  Instance := GetComponent(0);
  PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, GetDataSourcePropName);
  if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
  begin
    DataSource := TObject(GetOrdProp(Instance, PropInfo)) as TDataSource;
    if (DataSource <> nil) and (DataSource.DataSet <> nil) then
    begin
      if (DataSource.DataSet is TTable) and
          (TTable(DataSource.DataSet).IndexFieldCount > 0) then
        List.Add(TTable(DataSource.DataSet).IndexFields[0].FieldName)
      else
        DataSource.DataSet.GetFieldNames(List);
    end;
  end;
end;

{ TDBImageEditor }

type
  TDBImageEditor = class(TDefaultEditor)
  public
    procedure Copy; override;
  end;

procedure TDBImageEditor.Copy;
begin
  TDBImage(Component).CopyToClipboard;
end;

{ TQueryEditor }

type
  TQueryEditor = class(TComponentEditor)
  private
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

procedure TQueryEditor.ExecuteVerb(Index: Integer);
var
  Query: TQuery;
  List: TParams;
begin
  Query := Component as TQuery;
  case Index of
    0: ShowDatasetDesigner(Designer, TTable(Component));
    1:
      begin
        List := TParams.Create;
        try
          List.Assign(Query.Params);
          if EditQueryParams(Query, List) then
          begin
            Query.Close;
            Query.Params := List;
            if Designer <> nil then Designer.Modified;
          end;
        finally
          List.Free;
        end;
     end;
    2: ExploreDataset(TDBDataset(Component));
    3:
      begin
        ExecBuilder(Query);
        if Designer <> nil then Designer.Modified;
      end;
  end;
end;

function TQueryEditor.GetVerb(Index: Integer): string;
begin
  case Index of
    0: Result := LoadStr(SSQLDatasetDesigner);
    1: Result := LoadStr(SBindVerb);
    2: Result := LoadStr(SExplore);
    3: Result := LoadStr(SQBEVerb);
  end;
end;

function TQueryEditor.GetVerbCount: Integer;
begin
  if not VQBLoadAttempted then InitVQB;
  if VQBLoaded then Result := 4
  else Result := 3;
end;

{ TStoredProcEditor }

procedure EditStoredProcParams(StoredProc: TStoredProc; Designer: TDesigner);
var
  List: TParams;
begin
  List := TParams.Create;
  try
    StoredProc.CopyParams(List);
    if EditProcParams(StoredProc, List) then
    begin
      StoredProc.Params := List;
      if Designer <> nil then Designer.Modified;
    end;
  finally
    List.Free;
  end;
end;

type
  TStoredProcEditor = class(TComponentEditor)
  private
    procedure Edit; override;
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

procedure TStoredProcEditor.Edit;
begin
  ShowDatasetDesigner(Designer, TTable(Component));
end;

procedure TStoredProcEditor.ExecuteVerb(Index: Integer);
var
  StoredProc: TStoredProc;
begin
  StoredProc := Component as TStoredProc;
  case Index of
    0: Edit;
    1: EditStoredProcParams(StoredProc, Designer);
    2: ExploreDataset(StoredProc);
  end;
end;

function TStoredProcEditor.GetVerb(Index: Integer): string;
begin
  case Index of
    0: Result := LoadStr(SDatasetDesigner);
    1: Result := LoadStr(SBindVerb);
    2: Result := LoadStr(SExplore);
  end;
end;

function TStoredProcEditor.GetVerbCount: Integer;
begin
  Result := 3;
end;

{ TParamsProperty }

type
  TParamsProperty = class(TPropertyEditor)
  public
    function GetValue: string; override;
    function GetAttributes: TPropertyAttributes; override;
  end;

function TParamsProperty.GetValue: string;
begin
  Result := Format('(%s)', [TParams.ClassName]);
end;

function TParamsProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paDialog];
end;

{ TStoredParamsProperty }

type
  TStoredParamsProperty = class(TParamsProperty)
    procedure Edit; override;
  end;

procedure TStoredParamsProperty.Edit;
begin
  EditStoredProcParams(GetComponent(0) as TStoredProc, Designer);
end;

{ TQueryParamsProperty }

type
  TQueryParamsProperty = class(TParamsProperty)
    procedure Edit; override;
  end;

procedure TQueryParamsProperty.Edit;
var
  List: TParams;
  Query: TQuery;
begin
  Query := GetComponent(0) as TQuery;
  List := TParams.Create;
  try
    List.Assign(Query.Params);
    if EditQueryParams(Query, List) and not List.IsEqual(Query.Params) then
    begin
      Modified;
      Query.Close;
      Query.Params := List;
    end;
  finally
    List.Free;
  end;
end;

{ TIndexFilesProperty }

type
  TIndexFilesProperty = class(TPropertyEditor)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure Edit; override;
    function GetValue: string; override;
  end;

function TIndexFilesProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog, paReadOnly];
end;

function TIndexFilesProperty.GetValue: string;
begin
  Result := Format('(%s)', [TIndexFiles.ClassName]);
end;

procedure TIndexFilesProperty.Edit;
var
  List: TStringList;
  Table: TTable;
  I: Integer;
  IndexFile: string;
begin
  Table := GetComponent(0) as TTable;
  List := TStringList.Create;
  try
    List.Assign(Table.IndexFiles);
    if EditIndexFiles(Table, List) then
    begin
      for I := 0 to List.Count - 1 do
      begin
        IndexFile := List[I];
        with Table.IndexFiles do
          if IndexOf(IndexFile) = -1 then Add(IndexFile);
      end;
      for I := Table.IndexFiles.Count - 1 downto 0 do
      begin
        IndexFile := Table.IndexFiles[I];
        with Table.IndexFiles do
          if List.IndexOf(IndexFile) = -1 then Delete(IndexOf(IndexFile));
      end;
      Modified;
    end;
  finally
    List.Free;
  end;
end;

{ TDBColumnAttributesProperty }

type
  TDBColumnAttributesProperty = class(TClassProperty)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
  end;

procedure TDBColumnAttributesProperty.Edit;
begin
  if EditDBGridColumns(TDBGridColumns(GetOrdValue)) then Modified;
end;

function TDBColumnAttributesProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog, paReadOnly];
end;

{ TDBGridEditor }
type
  TDBGridEditor = class(TComponentEditor)
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

procedure TDBGridEditor.ExecuteVerb(Index: Integer);
begin
  if EditDBGridColumns(TDBGrid(Component).Columns) then
    Designer.Modified;
end;

function TDBGridEditor.GetVerb(Index: Integer): string;
begin
  Result := LoadStr(SDBGridColEditor);
end;

function TDBGridEditor.GetVerbCount: Integer;
begin
  Result := 1;
end;

{ TUpdateSQLEditor }

type
  TUpdateSQLEditor = class(TComponentEditor)
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

procedure TUpdateSQLEditor.ExecuteVerb(Index: Integer);
begin
  if EditUpdateSQL(TUpdateSQL(Component)) then Designer.Modified;
end;

function TUpdateSQLEditor.GetVerb(Index: Integer): string;
begin
  Result := LoadStr(SUpdateSQLEditor);
end;

function TUpdateSQLEditor.GetVerbCount: Integer;
begin
  Result := 1;
end;

{ Registration }

procedure Register;
begin
  RegisterComponents(LoadStr(srDAccess), [TDataSource, TTable, TQuery,
    TStoredProc, TDatabase, TSession, TBatchMove, TUpdateSQL]);
  RegisterComponents(LoadStr(srDControls), [TDBGrid, TDBNavigator, TDBText,
    TDBEdit, TDBMemo, TDBImage, TDBListBox, TDBComboBox, TDBCheckBox,
    TDBRadioGroup, TDBLookupListBox, TDBLookupComboBox]);
  RegisterComponents(LoadStr(srDControls), [TDBCtrlGrid]);
  RegisterComponents(LoadStr(srWin31), [TDBLookupList, TDBLookupCombo]);
  RegisterNoIcon([TField]);
  RegisterFields([TStringField, TIntegerField, TSmallintField, TWordField,
    TFloatField, TCurrencyField, TBCDField, TBooleanField, TDateField,
    TVarBytesField, TBytesField, TTimeField, TDateTimeField,
    TBlobField, TMemoField, TGraphicField, TAutoIncField]);
  RegisterPropertyEditor(TypeInfo(TDataSet), TDataSource, 'DataSet', TDataSetProperty);
  RegisterPropertyEditor(TypeInfo(TDataSource), TTable, 'MasterSource', TDataSourceProperty);
  RegisterPropertyEditor(TypeInfo(TDataSource), TQuery, 'DataSource', TDataSourceProperty);
  RegisterPropertyEditor(TypeInfo(string), TDatabase, 'AliasName', TAliasNameProperty);
  RegisterPropertyEditor(TypeInfo(string), TDatabase, 'DriverName', TDriverNameProperty);
  RegisterPropertyEditor(TypeInfo(string), TDatabase, 'SessionName', TSessionNameProperty);
  RegisterPropertyEditor(TypeInfo(string), TDBDataSet, 'SessionName', TSessionNameProperty);
  RegisterPropertyEditor(TypeInfo(string), TDBDataSet, 'DatabaseName', TDatabaseNameProperty);
  RegisterPropertyEditor(TypeInfo(TDataSetUpdateObject), TDataSet, 'UpdateObject', TComponentProperty);
  RegisterPropertyEditor(TypeInfo(string), TTable, 'TableName', TTableNameProperty);
  RegisterPropertyEditor(TypeInfo(string), TTable, 'IndexName', TIndexNameProperty);
  RegisterPropertyEditor(TypeInfo(string), TTable, 'IndexFieldNames', TIndexFieldNamesProperty);
  RegisterPropertyEditor(TypeInfo(string), TField, 'KeyFields', TLookupSourceProperty);
  RegisterPropertyEditor(TypeInfo(string), TField, 'LookupKeyFields', TLookupDestProperty);
  RegisterPropertyEditor(TypeInfo(string), TField, 'LookupResultField', TLookupDestProperty);
  RegisterPropertyEditor(TypeInfo(string), TComponent, 'DataField', TDataFieldProperty);
  RegisterPropertyEditor(TypeInfo(string), TDBLookupControl, 'KeyField', TListFieldProperty);
  RegisterPropertyEditor(TypeInfo(string), TDBLookupControl, 'ListField', TListFieldProperty);
  RegisterPropertyEditor(TypeInfo(string), TWinControl, 'LookupField', TLookupIndexProperty);
  RegisterPropertyEditor(TypeInfo(string), TWinControl, 'LookupDisplay', TLookupFieldProperty);
  RegisterPropertyEditor(TypeInfo(string), TDBEdit, 'EditMask', TMaskProperty);
  RegisterPropertyEditor(TypeInfo(string), TField, 'EditMask', TMaskProperty);
  RegisterPropertyEditor(TypeInfo(string), TTable, 'MasterFields', TFieldLinkProperty);
  RegisterPropertyEditor(TypeInfo(TParams), TQuery, 'Params', TQueryParamsProperty);
  RegisterPropertyEditor(TypeInfo(string), TStoredProc, 'StoredProcName', TProcedureNameProperty);
  RegisterPropertyEditor(TypeInfo(TParams), TStoredProc, 'Params', TStoredParamsProperty);
  RegisterPropertyEditor(TypeInfo(TStrings), TTable, 'IndexFiles', TIndexFilesProperty);
  RegisterPropertyEditor(TypeInfo(TDBGridColumns), nil, '', TDBColumnAttributesProperty);
  RegisterComponentEditor(TDataset, TDataSetEditor);
  RegisterComponentEditor(TDatabase, TDatabaseEditor);
  RegisterComponentEditor(TBatchMove, TBatchMoveEditor);
  RegisterComponentEditor(TQuery, TQueryEditor);
  RegisterComponentEditor(TDBImage, TDBImageEditor);
  RegisterComponentEditor(TStoredProc, TStoredProcEditor);
  RegisterComponentEditor(TDBGrid, TDBGridEditor);
  RegisterComponentEditor(TUpdateSQL, TUpdateSQLEditor);
  DBExpt.Register;
end;

end.