adodb.pas

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

  public
    constructor Create(AOwner: TComponent); override;
    procedure ExecProc;
  published
    property CommandTimeout;
    property DataSource;
    property EnableBCD;
    property ProcedureName: WideString read GetCommandText write SetCommandText;
    property Parameters;
    property Prepared;
  end;

{ TADOBlobStream }

  TADOBlobStream = class(TMemoryStream)
  private
    FField: TBlobField;
    FDataSet: TCustomADODataSet;
    FBuffer: PChar;
    FFieldNo: Integer;
    FModified: Boolean;
    FData: Variant;
    FFieldData: Variant;
  protected
    procedure ReadBlobData;
    function Realloc(var NewCapacity: Longint): Pointer; override;
  public
    constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
    destructor Destroy; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    procedure Truncate;
  end;

{ Global Functions }

procedure CreateUDLFile(const FileName, ProviderName, DataSourceName: WideString);
function DataLinkDir: string;
procedure GetProviderNames(Names: TStrings);
function PromptDataSource(ParentHandle: THandle; InitialString: WideString): WideString;
function PromptDataLinkFile(ParentHandle: THandle; InitialFile: WideString): WideString;
function GetDataLinkFiles(FileNames: TStrings; Directory: string = ''): Integer;

implementation

uses DBCommon, Mtx, DBConsts, ComObj, ADOConst;

type
  PRecInfo = ^TRecInfo;
  TRecInfo = packed record
    Bookmark: OleVariant;
    BookmarkFlag: TBookmarkFlag;
    RecordStatus: Integer;
    RecordNumber: Integer;
  end;

const
  { Connection Flags }
  cfOpen       = 1;
  cfExecute    = 2;
  cfIndex      = 3;
  cfParameters = 4;
  cfProvider   = 5;

  bfNA = TBookmarkFlag(Ord(High(TBookmarkFlag)) + 1);
  RSOnlyCommandTypes = [cmdTableDirect, cmdFile]; { Command Types valid only in RecordSet.Open calls }

var
  GlobalMalloc: IMalloc;

{ Enum Mappings }

const
  CommandTypeValues: array[TCommandType] of TOleEnum = (adCmdUnknown,
    adCmdText, adCmdTable, adCmdStoredProc, adCmdFile, adCmdTableDirect);

  ConnectModeValues: array[TConnectMode] of TOleEnum = (adModeUnknown,
    adModeRead, adModeWrite, adModeReadWrite, adModeShareDenyRead,
    adModeShareDenyWrite, adModeShareExclusive, adModeShareDenyNone);

  ConnectOptionValues: array[TConnectOption] of TOleEnum = (adConnectUnspecified,
    adAsyncConnect);

  CursorLocationValues: array[TCursorLocation] of TOleEnum = (adUseServer, adUseClient);

  CursorOptionValues: array[TCursorOption] of TOleEnum = (adHoldRecords,
    adMovePrevious, adAddNew, adDelete, adUpdate, adBookmark, adApproxPosition,
    adUpdateBatch, adResync, adNotify, adFind, adSeek, adIndex);

  CursorTypeValues: array[TCursorType] of TOleEnum = (adOpenUnspecified,
    adOpenForwardOnly, adOpenKeyset, adOpenDynamic, adOpenStatic);

  DataTypeValues: array[TDataType] of TOleEnum = (
    adEmpty, adVarChar, adSmallint, adInteger, adUnsignedSmallint,
    adBoolean, adDouble, adDouble, adCurrency, adDate, adDate,
    adDate, adBinary, adVarBinary, adInteger, adLongVarBinary,
    adLongVarChar, adLongVarBinary, adLongVarBinary, adLongVarBinary,
    adLongVarBinary, adLongVarBinary, adEmpty, adChar, adVarWChar, adBigInt,
    adEmpty, adEmpty, adEmpty, adEmpty, adEmpty, adEmpty, adVariant,
    adIUnknown, adIDispatch, adGuid, adEmpty, adEmpty
    );

  EventReasonValues: array[TEventReason] of TOleEnum = (adRsnAddNew,
    adRsnDelete, adRsnUpdate, adRsnUndoUpdate, adRsnUndoAddNew, adRsnUndoDelete,
    adRsnRequery, adRsnResynch, adRsnClose, adRsnMove, adRsnFirstChange,
    adRsnMoveFirst, adRsnMoveNext, adRsnMovePrevious, adRsnMoveLast);

  EventStatusValues: array[TEventStatus] of TOleEnum = (adStatusOK,
    adStatusErrorsOccurred, adStatusCantDeny, adStatusCancel,
    adStatusUnwantedEvent);

  ExecuteOptionValues: array[TExecuteOption] of TOleEnum = (adAsyncExecute,
    adAsyncFetch, adAsyncFetchNonBlocking, adExecuteNoRecords);

  FilterGroupValues: array[TFilterGroup] of TOleEnum = ($FFFFFFFF {Unassigned},
    adFilterNone, adFilterPendingRecords, adFilterAffectedRecords,
    adFilterFetchedRecords, adFilterPredicate, adFilterConflictingRecords);

  IsolationLevelValues: array[TIsolationLevel] of TOleEnum = (adXactUnspecified,
    adXactChaos, adXactReadUncommitted, adXactBrowse, adXactCursorStability,
    adXactReadCommitted, adXactRepeatableRead, adXactSerializable,
    adXactIsolated);

  LockTypeValues: array[TADOLockType] of TOleEnum = (adLockUnspecified,
    adLockReadOnly, adLockPessimistic, adLockOptimistic,
    adLockBatchOptimistic);

  MarshalOptionValues: array[TMarshalOption] of TOleEnum = (adMarshalAll,
    adMarshalModifiedOnly);

  ObjectStateValues: array[TObjectState] of TOleEnum = (adStateClosed,
    adStateOpen, adStateConnecting, adStateExecuting, adStateFetching);

  ParameterAttributeValues: array[TParameterAttribute] of TOleEnum =
    (adParamSigned, adParamNullable, adParamLong);

  ParameterDirectionValues: array[TParameterDirection] of TOleEnum =
    (adParamUnknown, adParamInput, adParamOutput, adParamInputOutput,
     adParamReturnValue);

  RecordStatusValues: array[TRecordStatus] of TOleEnum = (adRecOK, adRecNew,
    adRecModified, adRecDeleted, adRecUnmodified, adRecInvalid,
    adRecMultipleChanges, adRecPendingChanges, adRecCanceled, adRecCantRelease,
    adRecConcurrencyViolation, adRecIntegrityViolation,adRecMaxChangesExceeded,
    adRecObjectOpen, adRecOutOfMemory, adRecPermissionDenied,
    adRecSchemaViolation, adRecDBDeleted);

  SeekOptionValues: array[TSeekOption] of TOleEnum = (adSeekFirstEQ,
    adSeekLastEQ, adSeekAfterEQ, adSeekAfter, adSeekBeforeEQ, adSeekBefore);

  AffectRecordsValues: array[TAffectRecords] of TOleEnum =
    (adAffectCurrent, adAffectGroup, adAffectAll, adAffectAllChapters);

  XactAttributeValues: array[TXactAttribute] of TOleEnum = (adXactCommitRetaining,
    adXactAbortRetaining);

{ Utility Functions }

function CreateADOObject(const ClassID: TGUID): IUnknown;
var
  Status: HResult;
  FPUControlWord: Word;
begin
  asm
    FNSTCW  FPUControlWord
  end;
  Status := CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
    CLSCTX_LOCAL_SERVER, IUnknown, Result);
  asm
    FNCLEX
    FLDCW FPUControlWord
  end;
  if (Status = REGDB_E_CLASSNOTREG) then
    raise Exception.CreateRes(@SADOCreateError) else
    OleCheck(Status);
end;

function ADOTypeToFieldType(const ADOType: DataTypeEnum; EnableBCD: Boolean = True): TFieldType;
begin
  case ADOType of
    adEmpty: Result := ftUnknown;
    adTinyInt, adSmallInt: Result := ftSmallint;
    adError, adInteger, adUnsignedInt: Result := ftInteger;
    adBigInt, adUnsignedBigInt: Result := ftLargeInt;
    adUnsignedTinyInt, adUnsignedSmallInt: Result := ftWord;
    adSingle, adDouble: Result := ftFloat;
    adCurrency: Result := ftBCD;
    adBoolean: Result := ftBoolean;
    adDBDate: Result := ftDate;
    adDBTime: Result := ftTime;
    adDate, adDBTimeStamp, adFileTime, adDBFileTime: Result := ftDateTime;
    adChar: Result := ftFixedChar;
    adVarChar: Result := ftString;
    adBSTR, adWChar, adVarWChar: Result := ftWideString;
    adLongVarChar, adLongVarWChar: Result := ftMemo;
    adLongVarBinary: Result := ftBlob;
    adBinary: Result := ftBytes;
    adVarBinary: Result := ftVarBytes;
    adChapter: Result := ftDataSet;
    adPropVariant, adVariant: Result := ftVariant;
    adIUnknown: Result := ftInterface;
    adIDispatch: Result := ftIDispatch;
    adGUID: Result := ftGUID;
    adDecimal, adNumeric, adVarNumeric:
      if EnableBCD then Result := ftBCD
      else Result := ftFloat;
  else
    Result := ftUnknown;
  end;
end;

function FieldTypeToADOType(const FieldType: TFieldType): DataTypeEnum;
begin
  case FieldType of
    ftUnknown: Result := adEmpty;
    ftString, ftWideString: Result := adVarChar;
    ftSmallint: Result := adSmallint;
    ftInteger, ftAutoInc: Result := adInteger;
    ftWord: Result := adUnsignedSmallInt;
    ftBoolean: Result := adBoolean;
    ftFloat: Result := adDouble;
    ftCurrency, ftBCD: Result := adCurrency;
    ftDate: Result := adDBDate;
    ftTime: Result := adDBTime;
    ftDateTime: Result := adDBTimeStamp;
    ftBytes: Result := adBinary;
    ftVarBytes: Result := adVarBinary;
    ftMemo: Result := adLongVarChar;
    ftBlob, ftGraphic..ftTypedBinary: Result := adLongVarBinary;
    ftFixedChar: Result := adChar;
    ftLargeint: Result := adBigInt;
    ftVariant: Result := adVariant;
    ftInterface: Result := adIUnknown;
    ftIDispatch: Result := adIDispatch;
    ftGuid: Result := adGUID;
  else
    DatabaseErrorFmt(SNoMatchingADOType, [FieldTypeNames[FieldType]]);
    Result := adEmpty;
  end;
end;

function StringToVarArray(const Value: string): OleVariant;
var
  PData: Pointer;
  Size: Integer;
begin
  Size := Length(Value);
  Result := VarArrayCreate([0, Size-1], varByte);
  PData := VarArrayLock(Result);
  try
    Move(Pointer(Value)^, PData^, Size);
  finally
    VarArrayUnlock(Result);
  end;
end;

function VarDataSize(const Value: OleVariant): Integer;
begin
  if VarIsNull(Value) then
    Result := -1
  else if VarIsArray(Value) then
    Result := VarArrayHighBound(Value, 1) + 1
  else if TVarData(Value).VType = varOleStr then
  begin
    Result := Length(PWideString(@TVarData(Value).VOleStr)^);
    if Result = 0 then
      Result := -1;
  end
  else
    Result := SizeOf(OleVariant);
end;

function OleEnumToOrd(OleEnumArray: array of TOleEnum; Value: TOleEnum): Integer;
begin
  for Result := Low(OleEnumArray) to High(OleEnumArray) do
    if Value = OleEnumArray[Result] then Exit;
  raise EADOError.CreateRes(@SInvalidEnumValue);
end;

function GetStates(State: Integer): TObjectStates;
var
  Os: TObjectState;
begin
  Result := [];
  for Os := stOpen to High(TObjectState) do
    if (ObjectStateValues[Os] and State) <> 0 then
      Include(Result, Os);
  if Result = [] then Result := [stClosed];
end;

function ExecuteOptionsToOrd(ExecuteOptions: TExecuteOptions): Integer;
var
  Eo: TExecuteOption;
begin
  Result := 0;
  if ExecuteOptions <> [] then
    for Eo := Low(TExecuteOption) to High(TExecuteOption) do
      if Eo in ExecuteOptions then
        Inc(Result, ExecuteOptionValues[Eo]);
end;

function OrdToExecuteOptions(Options: Integer): TExecuteOptions;
var
  Eo: TExecuteOption;
begin
  Result := [];
  if Options <> 0 then
    for Eo := Low(TExecuteOption) to High(TExecuteOption) do
      if (ExecuteOptionValues[Eo] and Options) <> 0 then
        Include(Result, Eo);
end;

function ExtractFieldName(const Fields: WideString; var Pos: Integer): WideString;
var
  I: Integer;
begin
  I := Pos;
  while (I <= Length(Fields)) and (Fields[I] <> ';') do Inc(I);
  Result := Copy(Fields, Pos, I - Pos);
  if (I <= Length(Fields)) and (Fields[I] = ';') then Inc(I);
  Pos := I;
end;