dbunit.pas

企业进销存管理系统

  { Structure File Functions }
  function DBCheckStructureFile(strFileName: String; var ResultsList: TStringList;
                                         var Srec: TStructureRec): Boolean;
  function DBConfigureTableStructure(strDataBase, strTableName, strStructureFile: string;
                                         var Tbl: TTable; var SpecialInfo: TDBTableSpecialInfo): Boolean;
  function DBCreateTableFromStructure(strDataBase, strTableName, strStructureFile: String): Boolean;
  function DBStructGetAlias(S: String; var strAlias, strPath: String): Boolean;
  function DBStructGetField(S: String; var strFieldName, strFieldType, strRequired: String;
                                         var FieldSize: Integer; var SubType: Word): Boolean;
  function DBStructGetIndex(S: String; var strIndexName, strIndexFields, strOptions: String): Boolean;
  function DBStructGetTableName(S: String; var strTableName, strDesc: String): Boolean;
  function DBRestructureTable(strDataBase, strTableName, strStructureFile: String;
                                         FOptype: array of CROptype; IOptype: array of CROptype;
                                         var pFldDes: pFldDesc): Boolean;
  function DBStructProcessTable(var TablePacket: TStringList; var strResult: String; TableIndex: LongInt;
                                         var SRec: TStructureRec): Boolean;
  function DBStructSyncTables(strDataBase, strStructureFile: String; Verbose :Boolean): Boolean;

  { Support Functions }
  function DBAnsiToNative(const NameStr: string; NativeBuf: PChar; MaxLength: Integer): PChar;
  function DBCheckAutoIncTranslationAllowed(strDataBase, strTableName, strPassword: String): Boolean;
  procedure DBCreateTable(var WorkTable: TTable; SpecialInfo: TDBTableSpecialInfo);
  function DBDecodeValCheck(FieldType: TFieldType; FieldSize: Integer; HasFlag: WordBool;
                                         Value: DBIVCHK): String;
  function DBDeleteNetFile: Boolean;
  function DBGetBDEVersion(var VersionInfo: TFileVersionRecord): Boolean;
  function DBGetCursorProps(strDataBase, strTableName: String; var CurProp: CURProps): LongInt;
  function DBGetCursorPropsProtected(strDataBase, strTableName: String; var CurProp: CURProps): Boolean;
  function DBGetRefInt(strDataBase, strTableName: String; SeqNo: Word; var RIntDesc: RIntDesc): Boolean;
  function DBGetTableAssociatedFiles(strDataBase, strTableName: String; var FileList: TStringList): Boolean;
  function DBGetTableType(TableName: String): DBINAME;
  function DBGetTutilityVersion(var VersionInfo: TFileVersionRecord): Boolean;
  function DBGetValCheck(strDataBase, strTableName: String; SeqNo: Word; var VchkDes: VCHKDesc): Boolean;
  function DBSetAutoIncField(strDataBase, strTableName, strPassword: String; FieldIndex: Integer): Boolean;
  function DBTableIsProtected(strDataBase, strTableName: String; var NeedsPassword: Boolean): Boolean;
  function DBProtectTable(strDataBase, strTableName, strPassword: String): Boolean;

const
{$IFDEF WIN32}
  DB_DATA_TYPE_COUNT = 22;
{$ELSE}
  DB_DATA_TYPE_COUNT = 17;
{$ENDIF}
  strDataTypeLong: array[0..(DB_DATA_TYPE_COUNT - 1)] of String =
                                        ('ftUnknown - Unknown or undetermined',
                                         'ftString - Character or string field',
                                         'ftSmallInt - 16-bit integer field',
                                         'ftInteger - 32-bit integer field',
                                         'ftWord - 16-bit unsigned integer field',
                                         'ftBoolean - Boolean field',
                                         'ftFloat - Floating-point numeric field',
                                         'ftCurrency - Money field',
                                         'ftBCD - Binary-Coded Decimal field',
                                         'ftDate - Date field',
                                         'ftTime - Time field',
                                         'ftDateTime - Date and time field',
                                         'ftBytes - Fixed number of bytes (binary storage)',
                                         'ftVarBytes - Variable number of bytes (binary storage)',
{$IFDEF WIN32}
                                         'ftAutoInc - Auto-incrementing 32-bit integer counter field',
                                         'ftBlob - Binary Large OBject field',
                                         'ftMemo - Text memo field',
                                         'ftGraphic - Bitmap field',
                                         'ftFmtMemo - Formatted text memo field',
                                         'ftParadoxOle - Paradox OLE field',
                                         'ftDBaseOle - dBASE OLE field',
                                         'ftTypedBinary - Typed binary field');
{$ELSE}
                                         'ftBlob - Binary Large OBject field',
                                         'ftMemo - Text memo field',
                                         'ftGraphic - Bitmap field');
{$ENDIF}

  strDataType: array[0..(DB_DATA_TYPE_COUNT - 1)] of string =
                                        ('ftUnknown',
                                         'ftString',
                                         'ftSmallInt',
                                         'ftInteger',
                                         'ftWord',
                                         'ftBoolean',
                                         'ftFloat',
                                         'ftCurrency',
                                         'ftBCD',
                                         'ftDate',
                                         'ftTime',
                                         'ftDateTime',
                                         'ftBytes',
                                         'ftVarBytes',
{$IFDEF WIN32}
                                         'ftAutoInc',
                                         'ftBlob',
                                         'ftMemo',
                                         'ftGraphic',
                                         'ftFmtMemo',
                                         'ftParadoxOle',
                                         'ftDBaseOle',
                                         'ftTypedBinary');
{$ELSE}
                                         'ftBlob',
                                         'ftMemo',
                                         'ftGraphic');
{$ENDIF}

var
  ReRaiseDBExceptions: Boolean;           { Indicator: Pass DB Exceptions back to calling routine }
  LastDBError: DBIResult;                 { Last BDE Error code }
  LastDBErrorString: String;              { Last BDE Error string }
  VerboseDBResponse: Boolean;             { True if verbose responses desired }

implementation

uses WinProcs, Dialogs, Controls;

var
  FBDEUtil: TBDEUtil;


procedure PublishBDEResult(DBRslt: DBIResult); forward;
{$IFNDEF WIN32}
function DbiDeleteAlias(hCfg: hDBICfg; pszAliasName: PChar): DBIResult; far; external 'IDAPI01';
function CopyFile(const FileName, DestName: String): Boolean; forward;
{$ENDIF}
function GetDLLVersion(DLLNameStr: String; var VersionInfo: TFileVersionRecord): Boolean; forward;
procedure ClearStructureRec(var SRec: TStructureRec); forward;
function AddSlash(var Path: String): String; forward;
function RemoveFirstWord(var S : String; Delimiter: Char): String; forward;
function KillExt(TableName: PChar): PChar; forward;
function NeedsExt(TableName: PChar): PChar; forward;


{$IFDEF WIN32}
type
  { subclass defining a read-only registry key open }
  TReadOnlyRegistry = class(TRegistry)
  public
    function OpenKeyReadOnly(const Key: string): Boolean;
  end;

{ TReadOnlyRegistry }
function TReadOnlyRegistry.OpenKeyReadOnly(const Key: string): Boolean;
var
  TempKey: HKey;
  S: string;
  //Disposition: Integer;
  Relative: Boolean;
begin
  S := Key;
  Relative := not ((S <> '') and (S[1] = '\'));
  if not Relative then
    Delete(S, 1, 1);
  TempKey := 0;
  Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,
                         KEY_READ, TempKey) = ERROR_SUCCESS;
  if Result then
  begin
    if (CurrentKey <> 0) and Relative then
      S := CurrentPath + '\' + S;
    ChangeKey(TempKey, S);
  end;
end;
{$ENDIF}


(*
*******************************************************************************
  Database Functions
*******************************************************************************
*)

{$IFDEF WIN32} { 16 and 32-bit alias maintenance routines are different ... could use
                 16-bit version for both, but the 32-bit Delphi calls provide more
                 error-checking, etc }
{ DBAddAlias --  add a new database alias (see help for complete description) }
function DBAddAlias(Alias, Path, DefaultDriver: String): Boolean;
var
  OldMode : TConfigMode;
begin
  Result := True; { assume success for now }

  with Session do
  begin
    { Save original mode so that it can be restored later }
    OldMode := ConfigMode;
    ConfigMode := cmAll;
    try
      try
        AddStandardAlias(Alias, Path, DefaultDriver);
      except
        on E: EDataBaseError do
        begin
          Result := False;
          LastDBErrorString := E.Message;
          { Re Raise Exception so that it is passed back to the Calling function }
          if ReRaiseDBExceptions then
            raise;
        end;
      end;
    finally
      SaveConfigFile;
      ConfigMode := OldMode;
    end;
  end;
end;

{$ELSE} { 16-bit version of alias maintenance routines }

{ DBAddAlias --  add a new database alias (see help for complete description) }
function DBAddAlias(Alias, Path, DefaultDriver: String): Boolean;
var
  DBRslt      : DBIRESULT;
  AliasName   : DBINAME;
  DriverName  : DBIPATH;
  OptionStr   : Array[0..255] of Char;
begin
  try
    DBAnsiToNative(Alias, AliasName, (SizeOf(AliasName) - 1));
    DBAnsiToNative(DefaultDriver, DriverName, (SizeOf(DriverName) - 1));
    { build option buffer }
    StrPCopy(OptionStr, ('PATH: ' + Path));
    DBRslt := DbiAddAlias(nil, AliasName, DriverName, OptionStr, True);
    PublishBDEResult(DBRslt);
    Result := (DBRslt = DBIERR_NONE);
  except
    on E: EDataBaseError do
    begin
      Result := False;
      LastDBErrorString := E.Message;
      { Re Raise Exception so that it is passed back to the Calling function }
      if ReRaiseDBExceptions then
        raise;
    end;
  end;
end;
{$ENDIF}

{ DBBDEUsersList --  list users logged onto BDE (see help for complete description) }
function DBBDEUsersList(var UserList: TStringList): Boolean;
var
  InMemCursor : hdbicur;
  DbiRslt     : dbiResult;
  UsrDesc     : USERDesc;
begin
  Result := True; { assume sucess for now }

  DbiRslt := DbiOpenUserList(InMemCursor);
  PublishBDEResult(DbiRslt);
  if DbiRslt = DBIERR_NONE then
  begin
    try
      repeat
        DbiRslt:= DbiGetNextRecord(InMemCursor, dbiNOLOCK, @UsrDesc, nil);
        if (DbiRslt = DBIERR_NONE) then
        begin
          UserList.Add('User name: ' + StrPas(UsrDesc.szUserName));
          UserList.Add('Net Session: ' + IntToStr(UsrDesc.iNetSession));
          UserList.Add('Product Class: ' + IntToStr(UsrDesc.iProductClass));
          UserList.Add('');
        end;
      until (DbiRslt <> DBIERR_NONE);
      if (DbiRslt <> DBIERR_EOF) then
      begin
        PublishBDEResult(DbiRslt);
        Result := False;
      end;
    finally
      DbiCloseCursor(InMemCursor);
    end;
  end
  else
    Result := False;
end;

{ DBCheckAlias --  confirms validity of alias (see help for complete description) }
function DBCheckAlias(Alias, DefaultDriver: String; var Path: String): Boolean;
var
  AliasParams     : TStringList;
  i               : Integer;
  strExistingPath : String; { Existing path setting }
  UserOption      : Word;
begin
  { Init }
  Result := True; { assume success for now }
  strExistingPath := '';

  { append directory seperator onto end of path variable if needed}
  Path := AddSlash(Path);

  with Session do
  begin
    AliasParams := TStringList.Create;
    try
      { Get Existing Alias Information }
      try
        GetAliasParams(Alias ,AliasParams);