adodb.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

    function GetNumericScale: Byte;
    function GetParameter: _Parameter;
    function GetParameterDirection: TParameterDirection;
    function GetPrecision: Byte;
    function GetProperties: Properties;
    function GetSize: Integer;
    function GetValue: Variant;
    procedure SetAttributes(const Value: TParameterAttributes);
    procedure SetDataType(const Value: TDataType);
    procedure SetName(const Value: WideString);
    procedure SetNumericScale(const Value: Byte);
    procedure SetParameterDirection(const Value: TParameterDirection);
    procedure SetPrecision(const Value: Byte);
    procedure SetSize(const Value: Integer);
    procedure SetValue(const Value: Variant);
    function GetParameters: TParameters;
  protected
    procedure AssignTo(Dest: TPersistent); override;
    function GetDisplayName: string; override;
    function IsEqual(Value: TParameter): Boolean;
  public
    procedure Assign(Source: TPersistent); override;
    procedure AppendChunk(Val: OleVariant);
    procedure LoadFromFile(const FileName: string; DataType: TDataType);
    procedure LoadFromStream(Stream: TStream; DataType: TDataType);
    property ParameterObject: _Parameter read GetParameter;
    property Parameters: TParameters read GetParameters;
    property Properties: Properties read GetProperties;
  published
    property Name: WideString read GetName write SetName;
    property Attributes: TParameterAttributes read GetAttributes write SetAttributes default [];
    property DataType: TDataType read GetDataType write SetDataType default ftUnknown;
    property Direction: TParameterDirection read GetParameterDirection write SetParameterDirection default pdInput;
    property NumericScale: Byte read GetNumericScale write SetNumericScale default 0;
    property Precision: Byte read GetPrecision write SetPrecision default 0;
    property Size: Integer read GetSize write SetSize default 0;
    property Value: Variant read GetValue write SetValue;
  end;

{ TParameters }

  TPropList = array of PPropInfo;

  TParameters = class(TOwnedCollection)
  private
    FModified: Boolean;
    function GetCommand: TADOCommand;
    function GetItem(Index: Integer): TParameter;
    function GetParamCollection: Parameters;
    function GetParamValue(const ParamName: WideString): Variant;
    procedure SetItem(Index: Integer; const Value: TParameter);
    procedure SetParamValue(const ParamName: WideString; const Value: Variant);
  protected
    function Create_Parameter(const Name: WideString;
      DataType: TDataType; Direction: TParameterDirection = pdInput;
      Size: Integer = 0): _Parameter;
    function GetAttrCount: Integer; override;
    function GetAttr(Index: Integer): string; override;
    function GetItemAttr(Index, ItemIndex: Integer): string; override;
    function InternalRefresh: Boolean;
    procedure AppendParameters;
    procedure Update(Item: TCollectionItem); override;
    property Modified: Boolean read FModified;
  public
    function AddParameter: TParameter;
    procedure AssignValues(Value: TParameters);
    function CreateParameter(const Name: WideString; DataType: TDataType;
      Direction: TParameterDirection; Size: Integer; Value: OleVariant): TParameter;
    function FindParam(const Value: WideString): TParameter;
    procedure GetParamList(List: TList; const ParamNames: WideString);
    function IsEqual(Value: TParameters): Boolean;
    function ParamByName(const Value: WideString): TParameter;
    function ParseSQL(SQL: string; DoCreate: Boolean): string;
    function Refresh: Boolean;
    property ParamValues[const ParamName: WideString]: Variant read GetParamValue write SetParamValue;
    property Command: TADOCommand read GetCommand;
    property Items[Index: Integer]: TParameter read GetItem write SetItem; default;
    property ParameterCollection: Parameters read GetParamCollection;
  end;

{ TADOCommand }

  TADOCommand = class(TComponent)
  private
    FCommandObject: _Command;
    FConnection: TADOConnection;
    FConnectionString: WideString;
    FCommandText: WideString;
    FCommandTextAlias: string;
    FComponentRef: TComponent;
    FExecuteOptions: TExecuteOptions;
    FParameters: TParameters;
    FConnectionFlags: set of 1..8;
    FParamCheck: Boolean;
    function GetCommandTimeOut: Integer;
    function GetCommandType: TCommandType;
    function GetPrepared: WordBool;
    function GetProperties: Properties;
    function GetState: TObjectStates;
    procedure SetCommandTimeOut(const Value: Integer);
    procedure SetComandType(const Value: TCommandType);
    procedure SetConnection(const Value: TADOConnection);
    procedure SetConnectionString(const Value: WideString);
    procedure SetParameters(const Value: TParameters);
    procedure SetPrepared(const Value: WordBool);
    function GetActiveConnection: _Connection;
  protected
    procedure AssignCommandText(const Value: WideString; Loading: Boolean = False);
    procedure CheckCommandText;
    procedure ClearActiveConnection;
    function ComponentLoading: Boolean;
    procedure ConnectionStateChange(Sender: TObject; Connecting: Boolean);
    procedure Initialize(DoAppend: Boolean = True); virtual;
    procedure OpenConnection; virtual;
    procedure SetCommandText(const Value: WideString); virtual;
    function SetConnectionFlag(Flag: Integer; Value: Boolean): Boolean; virtual;
    property ActiveConnection: _Connection read GetActiveConnection;
    property CommandTextAlias: string read FCommandTextAlias write FCommandTextAlias;
    property ComponentRef: TComponent read FComponentRef write FComponentRef;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Cancel;
    function Execute: _Recordset; overload;
    function Execute(const Parameters: OleVariant): _Recordset; overload;
    function Execute(var RecordsAffected: Integer; const Parameters: OleVariant): _Recordset; overload;
    property CommandObject: _Command read FCommandObject;
    property Properties: Properties read GetProperties;
    property States: TObjectStates read GetState;
  published
    property CommandText: WideString read FCommandText write SetCommandText;
    property CommandTimeout: Integer read GetCommandTimeOut write SetCommandTimeOut default 30;
    property CommandType: TCommandType read GetCommandType write SetComandType default cmdText;
    property Connection: TADOConnection read FConnection write SetConnection;
    property ConnectionString: WideString read FConnectionString write SetConnectionString;
    property ExecuteOptions: TExecuteOptions read FExecuteOptions write FExecuteOptions default [];
    property Prepared: WordBool read GetPrepared write SetPrepared default False;
    property Parameters: TParameters read FParameters write SetParameters;
    property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
  end;

{ TCustomADODataSet }

  TCursorOption = (coHoldRecords, coMovePrevious, coAddNew, coDelete, coUpdate,
    coBookmark, coApproxPosition, coUpdateBatch, coResync, coNotify, coFind,
    coSeek, coIndex);
  TCursorOptions = set of TCursorOption;

  TEventReason = (erAddNew, erDelete, erUpdate, erUndoUpdate, erUndoAddNew,
    erUndoDelete, erRequery, erResynch, erClose, erMove, erFirstChange,
    erMoveFirst, erMoveNext, erMovePrevious, erMoveLast);

  TFilterGroup = (fgUnassigned, fgNone, fgPendingRecords, fgAffectedRecords,
    fgFetchedRecords, fgPredicate, fgConflictingRecords);

  TMarshalOption = (moMarshalAll, moMarshalModifiedOnly);

  TRecordStatus = (rsOK, rsNew, rsModified, rsDeleted, rsUnmodified, rsInvalid,
    rsMultipleChanges, rsPendingChanges, rsCanceled, rsCantRelease,
    rsConcurrencyViolation, rsIntegrityViolation, rsMaxChangesExceeded,
    rsObjectOpen, rsOutOfMemory, rsPermissionDenied, rsSchemaViolation,
    rsDBDeleted);
  TRecordStatusSet = set of TRecordStatus;

  TAffectRecords = (arCurrent, arFiltered, arAll, arAllChapters);

  TPersistFormat = (pfADTG, pfXML);

  TSeekOption = (soFirstEQ, soLastEQ, soAfterEQ, soAfter, soBeforeEQ, soBefore);

  PVariantList = ^TVariantList;
  TVariantList = array[0..0] of OleVariant;

  TWillChangeFieldEvent = procedure(DataSet: TCustomADODataSet;
    const FieldCount: Integer; const Fields: OleVariant;
    var EventStatus: TEventStatus) of object;

  TFieldChangeCompleteEvent = procedure(DataSet: TCustomADODataSet;
    const FieldCount: Integer; const Fields: OleVariant;
    const Error: Error; var EventStatus: TEventStatus) of object;

  TWillChangeRecordEvent = procedure(DataSet: TCustomADODataSet;
    const Reason: TEventReason; const RecordCount: Integer;
    var EventStatus: TEventStatus) of object;

  TRecordChangeCompleteEvent = procedure(DataSet: TCustomADODataSet;
    const Reason: TEventReason; const RecordCount: Integer;
    const Error: Error; var EventStatus: TEventStatus) of object;

  TEndOfRecordsetEvent = procedure (DataSet: TCustomADODataSet;
    var MoreData: WordBool; var EventStatus: TEventStatus) of object;

  TFetchProgressEvent = procedure(DataSet: TCustomADODataSet;
    Progress, MaxProgress: Integer; var EventStatus: TEventStatus) of object;

  TRecordsetErrorEvent = procedure(DataSet: TCustomADODataSet;
    const Reason: TEventReason; const Error: Error; var EventStatus: TEventStatus) of object;

  TRecordsetReasonEvent = procedure(DataSet: TCustomADODataSet;
    const Reason: TEventReason; var EventStatus: TEventStatus) of object;

  TRecordsetEvent = procedure(DataSet: TCustomADODataSet;
    const Error: Error; var EventStatus: TEventStatus) of object;

  TRecordsetCreate = procedure(DataSet: TCustomADODataSet;
    const Recordset: _Recordset) of object;

  TCustomADODataSet = class(TDataSet, IUnknown, RecordsetEventsVt)
  private
    FRecordsetObject: _Recordset;
    FFindCursor: _Recordset;
    FLookupCursor: _Recordset;
    FLockCursor: _Recordset;
    FRowset: IRowset;
    FAccessor: IAccessor;
    FRowsetFind: IRowsetFind;
    FHAccessor: HACCESSOR;
    FOleRecBufSize: Integer;
    FEventsID: Integer;
    FCommand: TADOCommand;
    FFilterBuffer: PChar;
    FRecBufSize: Integer;
    FCacheSize: Integer;
    FDetailFilter: string;
    FIndexFieldNames: string;
    FMaxRecords: Integer;
    FModifiedFields: TList;
    FParentRecNo: Integer;
    FIndexFields: TList;
    FIndexDefs: TIndexDefs;
    FParams: TParams;
    FIndexName: string;
    FDesignerData: string;
    FMasterDataLink: TMasterDataLink;
    FFilterGroup: TFilterGroup;
    FCursorLocation: TCursorLocation;
    FCursorType: TCursorType;
    FLockType: TADOLockType;
    FMarshalOptions: TMarshalOption;
    FRSCommandType: TCommandType;
    FParentDataSet: TCustomADODataSet;
    FBlockReadInfo: Pointer;
    FStoreDefs: Boolean;
    FEnableBCD: Boolean;
    FConnectionChanged: Boolean;
    FOnWillChangeField: TWillChangeFieldEvent;
    FOnFieldChangeComplete: TFieldChangeCompleteEvent;
    FOnWillChangeRecord: TWillChangeRecordEvent;
    FOnRecordChangeComplete: TRecordChangeCompleteEvent;
    FOnWillChangeRecordset: TRecordsetReasonEvent;
    FOnRecordsetChangeComplete: TRecordsetErrorEvent;
    FOnWillMove: TRecordsetReasonEvent;
    FOnMoveComplete: TRecordsetErrorEvent;
    FOnEndOfRecordset: TEndOfRecordsetEvent;
    FOnFetchComplete: TRecordsetEvent;
    FOnFetchProgress: TFetchProgressEvent;
    FOnRecordsetCreate: TRecordsetCreate;
    function GetCacheSize: Integer;
    function GetCommandTimeout: Integer;
    function GetCommandType: TCommandType;
    function GetConnection: TADOConnection;
    function GetConnectionString: WideString;
    function GetCursorLocation: TCursorLocation;
    function GetCursorType: TCursorType;
    function GetExecuteOptions: TExecuteOptions;
    function GetFilterGroup: TFilterGroup;
    function GetIndexField(Index: Integer): TField;
    function GetIndexFieldCount: Integer;
    function GetIndexFieldNames: string;
    function GetIndexName: string;
    function GetLockType: TADOLockType;
    function GetMarshalOptions: TMarshalOption;
    function GetMasterFields: string;
    function GetMaxRecords: Integer;
    function GetParamCheck: Boolean;
    function GetParameters: TParameters;
    function GetPrepared: Boolean;
    function GetProperties: Properties;
    function GetRecordsetState: TObjectStates;
    function GetRecordStatus: TRecordStatusSet;
    function GetSort: WideString;
    procedure PropertyChanged;
    procedure ReadDesignerData(Reader: TReader);
    procedure RefreshIndexFields;
    procedure SetCacheSize(const Value: Integer);
    procedure SetCommandTimeout(const Value: Integer);
    procedure SetCommandType(const Value: TCommandType);
    procedure SetConnectionString(const Value: WideString);
    procedure SetCursorLocation(const Value: TCursorLocation);
    procedure SetCursorType(const Value: TCursorType);
    procedure SetExecuteOptions(const Value: TExecuteOptions);
    procedure SetFilterGroup(const Value: TFilterGroup);
    procedure SetIndexField(Index: Integer; const Value: TField);
    procedure SetIndexFieldNames(const Value: string);
    procedure SetIndexName(const Value: string);
    procedure SetLockType(const Value: TADOLockType);
    procedure SetMarshalOptions(const Value: TMarshalOption);
    procedure SetMasterFields(const Value: string);
    procedure SetMaxRecords(const Value: Integer);
    procedure SetParamCheck(const Value: Boolean);
    procedure SetParameters(const Value: TParameters);
    procedure SetRecordset(const Value: _Recordset);
    procedure SetPrepared(const Value: Boolean);
    procedure SetSort(const Value: WideString);
    procedure WriteDesignerData(Writer: TWriter);
  protected
    { IProviderSupport }
    procedure PSEndTransaction(Commit: Boolean); override;
    procedure PSExecute; override;
    function PSExecuteStatement(const ASQL: string; AParams: TParams;
      ResultSet: Pointer = nil): Integer; override;
    procedure PSGetAttributes(List: TList); override;
    function PSGetDefaultOrder: TIndexDef; override;
    function PSGetKeyFields: string; override;
    function PSGetParams: TParams; override;
    function PSGetQuoteChar: string; override;
    function PSGetTableName: string; override;
    function PSGetIndexDefs(IndexTypes: TIndexOptions = [ixPrimary..ixNonMaintained]): TIndexDefs; override;
    function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override;
    function PSInTransaction: Boolean; override;