dbunit.pas

企业进销存管理系统

        { Check Current Alias PATH parameter }
        for i := 0 to AliasParams.Count -1 do
        begin
          if Copy(AliasParams[i], 0, 4) = 'PATH' then
          begin
            strExistingPath := Copy(AliasParams[i], 6, length(AliasParams[i]) -5);
            { Modify parameter, may be used if setting differes }
            AliasParams[i] := 'PATH=' + Path;
          end;
        end;

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

        { if the existing path setting and new path setting differ then ask for
          confirmation before modifying }
        if CompareText(strExistingPath, Path) <> 0 then
        begin
          if VerboseDBResponse then
            UserOption := MessageDlg('The path specified for the alias differs from the current '
                                     + 'alias configuration. (Existing Path: ' + strExistingPath
                                     + ' New Path: ' + Path + '). Do you wish to modify the existing '
                                     + 'configuration?', mtConfirmation, [mbYes, mbNo, mbCancel], 0)
          else
            UserOption := mrYes;  { assume 'Yes' response }
          case UserOption of
            mrYes: begin { modify existing alias }
{$IFDEF WIN32}
                     ModifyAlias(Alias, AliasParams);
                     Session.SaveConfigFile;
{$ELSE}
                     { must delete and re-add in 16-bit mode }
                     if (not DBDeleteAlias(Alias)) Or (not DBAddAlias(Alias, Path, DefaultDriver)) then
                       Result := False;
{$ENDIF}
                     if VerboseDBResponse then
                       MessageDlg('The Alias path has been altered.', mtINformation, [mbOK], 0);
                   end;
            mrNo: Path := strExistingPath;
            mrCancel: begin
                        Result := False;
                        Exit;
                      end;
          end; { case }
        end;

      except { Alias does not exist, ask user if it should be created. }
        if VerboseDBResponse then
          UserOption := MessageDlg('Alias: ' + Alias + ' does not exist. Do you wish to ' +
                                   'create a new alias?', mtConfirmation, [mbYes, mbNo], 0)
        else
          UserOption := mrYes;  { assume new alias desired }
        if (UserOption = mrYes) then
        begin
          try
            Result := DBAddAlias(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;

        end
        else { user does not wish to create new alias }
        begin
          Result := False;
          if VerboseDBResponse then
            MessageDlg('No alias created.', mtInformation, [mbOK], 0);
          Exit;
        end;
      end;

    finally
      AliasParams.Free;
    end;
  end;
end;

{$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 }
{ DBDeleteAlias --  delete alias and save the configuration (see help for complete description) }
function DBDeleteAlias(strAlias: String): Boolean;
begin
  result := True;

  with Session do
  begin
    try
      DeleteAlias(strAlias);
      SaveConfigFile;
    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;
end;

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

{ DBDeleteAlias --  delete alias and save the configuration (see help for complete description) }
function DBDeleteAlias(strAlias: String): Boolean;
var
  AliasName   : DBINAME;
  DBRslt      : DBIRESULT;
begin
  try
    DBAnsiToNative(strAlias, AliasName, (SizeOf(AliasName) - 1));
    DBRslt := DbiDeleteAlias(nil, AliasName);
    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}

{ DBGetAliasPath -- returns the full path for a given alias name }
function DBGetAliasPath(strAlias: String): String;
var
  AliasParamsList : TStringList;
  AliasPath       : String;
begin
  AliasParamsList := TStringList.Create;
  try
    try
      Session.GetAliasParams(strAlias, AliasParamsList);
      AliasPath := AliasParamsList.Values['PATH'];
      { append '\' if not present }
      if (AliasPath[Length(AliasPath)] <> '\') then
        AliasPath := AliasPath + '\';
      Result := AliasPath;
    except
      { will take exception to an invalid alias name ... return null string }
      Result := '';
    end;
  finally
    AliasParamsList.Free;
  end;
end;

{ DBOpenLockList --  returns details of the current locks placed on a table
  (see help for complete description) }
function DBOpenLockList(strDataBase, strTableName: String; var LockList: TStringList): Boolean;
var
  InMemCursor  : hdbicur;
  Lock         : LOCKDesc;
  DbiRslt      : dbiResult;
  hDb          : hDbiDb;
  TCur         : hDBICur;
  DBName       : DBIPATH;
  TableName    : DBITBLNAME;
begin
  { init }
  Result := False; { assume failure for now }

  { Open a NULL database handle }
  DbiRslt := DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenShared, nil, 0, nil, nil, hDb);
  PublishBDEResult(DbiRslt);
  if DbiRslt = DBIERR_NONE then
  begin
    try
      { set the database directory }
      DBAnsiToNative(strDatabase, DBName, (SizeOf(DBName) - 1));
      DbiRslt := DbiSetDirectory(hDb, DBName);
      PublishBDEResult(DbiRslt);
      if DbiRslt = DBIERR_NONE then
      begin
        { Get Table Cursor }
        DBAnsiToNative(strTableName, TableName, (SizeOf(TableName) - 1));
        DbiRslt := DbiOpenTable(hDb, TableName, nil, nil, nil, 0, dbiREADWRITE, dbiOPENSHARED,
                             xltFIELD, TRUE, nil, TCur);
        PublishBDEResult(DbiRslt);
        if DbiRslt = DBIERR_NONE then
        begin
          try
            DbiRslt := DbiOpenLockList(TCur, True, True, InMemCursor);
            PublishBDEResult(DbiRslt);
            if DbiRslt = DBIERR_NONE then
            begin
              try
                DbiRslt := DbiSetToBegin(InMemCursor);
                PublishBDEResult(DbiRslt);
                if DbiRslt = DBIERR_NONE then
                begin
                  Result := True;

                  LockList.Clear;
                  repeat
                    DbiRslt := DbiGetNextRecord(InMemCursor, dbiNOLOCK, @Lock, nil);
                    PublishBDEResult(DbiRslt);
                    if (DbiRslt <> DBIERR_EOF) then
                    begin
                      LockList.Add('Lock Type: ' + inttostr(Lock.iType));
                      LockList.Add('User Name: ' + StrPas(Lock.szUserName));

                      LockList.Add('Net Session: ' + inttostr(Lock.iNetSession));
                      LockList.Add('Session: ' + inttostr(Lock.iSession));
                      LockList.Add('Record Number: ' + inttostr(Lock.iRecNum));
                      LockList.Add('');
                    end;
                  until DbiRslt <> DBIERR_NONE;

                end;
              finally
                DbiCloseCursor(InMemCursor);
              end;
            end;
          finally
            DbiCloseCursor(TCur);
          end;
        end;
      end;
    finally
      DbiCloseDatabase(hDb);
    end;
  end;

end;


(*
*******************************************************************************
  Table Manipulation Functions
*******************************************************************************
*)

{ DBCloneTableStructure -- create a new table with the same structure as an existing
  table (see help for complete description) }
function DBCloneTableStructure(strDatabase, strTableName, strCloneDir, strCloneTableName, strPassword: String;
                               Mode: TCloneMode; var AutoIncField: Integer): Boolean;
var
  SrcTablePath         : DBITBLNAME;
  DestTablePath        : DBITBLNAME;
  SrcDBPath            : DBIPATH;
  DestDBPath           : DBIPATH;
  iFld, iIdx, iSec, iVal, iRI, iOptP, iOptD: Word;
  DbRslt               : DBIResult;
  TblDesc              : CRTBlDesc;
  hDb                  : hDbiDB;
  TmpCursor            : hdbicur;
  VCheck               : VCHKDesc;
  pVCheckDesc          : pVCHKDesc;
  TmpCount             : LongInt;
  tmpSecDesc           : SECDesc;
  ptmpSecDesc          : pSECDesc;
  pPassword            : PChar;
  NativeStr            : DBITBLNAME;
  i                    : Integer;
  pTestIdxDesc         : pIDXDesc;
  pPrimaryIdxDesc      : pIDXDesc;
  FoundPrimaryIndex    : Boolean;
  pTestFldDesc         : pFLDDesc;
begin
  Result := False;                          { assume failure for now }

  { Convert Password }
  if strPassword <> '' then
    pPassword := AnsiToNative(Session.Locale, strPassword, NativeStr, (SizeOf(DBITBLNAME) - 1))
  else
    pPassword := nil;

  DBAnsiToNative((AddSlash(strDataBase) + strTableName), SrcTablePath, (SizeOf(SrcTablePath) - 1));
  DBAnsiToNative((AddSlash(strCloneDir) + strCloneTableName), DestTablePath, (SizeOf(DestTablePath) - 1));

  FBDEUtil := TBDEUtil.Create;
  try
    DbRslt := TUExit(FBDEUtil.vHtSes);
    PublishBDEResult(DbRslt);
    if DbRslt = DBIERR_NONE then
    begin
      DbRslt := TUInit(FBDEUtil.vHtSes);
      PublishBDEResult(DbRslt);
      if DbRslt = DBIERR_NONE then
      begin
        DbRslt := TUGetCRTblDescCount(FBDEUtil.vhTSes, KillExt(SrcTablePath), iFld, iIdx, iSec,
                                    iVal, iRI, iOptP, iOptD);