bdeutils.pas

灰鸽子1.23源码,,,,,,,

          for L := 0 to DataSetCount - 1 do begin
            if DataSets[L].Active then
              DbiSaveChanges(DataSets[L].Handle);
          end;
        end;
    end;
{$IFDEF WIN32}
  end;
{$ENDIF}
end;

{$IFNDEF WIN32}
type
  TDbiGetExactRecordCount = function (hCursor: hDBICur;
    var iRecCount: Longint): DbiResult;

const
  DbiGetExactRecCnt: TDbiGetExactRecordCount = nil;

function DbiGetExactRecordCount(hCursor: hDBICur;
  var iRecCount: Longint): DbiResult;
var
  HModule: THandle;
  ErrMode: Cardinal;
begin
  if not Assigned(DbiGetExactRecCnt) then begin
    ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
    HModule := LoadLibrary('IDAPI01.DLL');
    SetErrorMode(ErrMode);
    if HModule >= HINSTANCE_ERROR then begin
      @DbiGetExactRecCnt := GetProcAddress(HModule, 'DBIGETEXACTRECORDCOUNT');
      FreeLibrary(HModule);
    end;
  end;
  if Assigned(DbiGetExactRecCnt) then
    Result := DbiGetExactRecCnt(hCursor, iRecCount)
  else Result := DbiGetRecordCount(hCursor, iRecCount);
end;
{$ENDIF}

function DataSetRecordCount(DataSet: TDataSet): Longint;
var
  IsCount: Boolean;
begin
{$IFDEF RX_D3}
  if DataSet is TBDEDataSet then begin
{$ENDIF}
    IsCount := (DbiGetExactRecordCount(TBDEDataSet(DataSet).Handle,
      Result) = DBIERR_NONE) or (DbiGetRecordCount(TBDEDataSet(DataSet).Handle,
      Result) = DBIERR_NONE);
{$IFDEF RX_D3}
  end
  else
    try
      Result := DataSet.RecordCount;
      IsCount := True;
    except
      IsCount := False;
    end;
{$ENDIF}
  if not IsCount then Result := -1;
end;

function DataSetRecNo(DataSet: TDataSet): Longint;
var
  FCurProp: CURProps;
  FRecProp: RECProps;
begin
  Result := -1;
  if (DataSet <> nil) and DataSet.Active and (DataSet.State in [dsBrowse,
    dsEdit]) then
  begin
{$IFDEF RX_D3}
    if not (DataSet is TBDEDataSet) then begin
      Result := DataSet.RecNo;
      Exit;
    end;
{$ENDIF}
    if DbiGetCursorProps(TBDEDataSet(DataSet).Handle, FCurProp) <> DBIERR_NONE then
      Exit;
    if (StrComp(FCurProp.szTableType, szParadox) = 0) or
      (FCurProp.iSeqNums = 1) then
    begin
      DataSet.GetCurrentRecord(nil);
      if DbiGetSeqNo(TBDEDataSet(DataSet).Handle, Result) <> DBIERR_NONE then
        Result := -1;
    end
    else if StrComp(FCurProp.szTableType, szDBase) = 0 then begin
      DataSet.GetCurrentRecord(nil);
      if DbiGetRecord(TBDEDataSet(DataSet).Handle, dbiNOLOCK, nil, @FRecProp) = DBIERR_NONE
        then Result := FRecProp.iPhyRecNum;
    end;
  end;
end;

function DataSetPositionStr(DataSet: TDataSet): string;
var
  RecNo, RecCount: Longint;
begin
  try
    RecNo := DataSetRecNo(DataSet);
  except
    RecNo := -1;
  end;
  if RecNo >= 0 then begin
    RecCount := DataSetRecordCount(DataSet);
    if RecCount >= 0 then Result := Format('%d:%d', [RecNo, RecCount])
    else Result := IntToStr(RecNo);
  end
  else Result := '';
end;

function TransActive(Database: TDatabase): Boolean;
var
  Info: XInfo;
{$IFDEF WIN32}
  S: hDBISes;
{$ENDIF}
begin
{$IFDEF WIN32}
  Result := False;
  if DbiGetCurrSession(S) <> DBIERR_NONE then Exit;
{$ENDIF}
  Result := (Database.Handle <> nil) and
    (DbiGetTranInfo(Database.Handle, nil, @Info) = DBIERR_NONE) and
    (Info.exState = xsActive);
{$IFDEF WIN32}
  DbiSetCurrSession(S);
{$ENDIF}
end;

function GetBdeDirectory: string;
const
  Ident = 'DLLPATH';
var
{$IFDEF WIN32}
  Ini: TRegistry;
const
  BdeKey = 'SOFTWARE\Borland\Database Engine';
{$ELSE}
  Ini: TIniFile;
{$ENDIF}
begin
  Result := '';
{$IFDEF WIN32}
  Ini := TRegistry.Create;
  try
    Ini.RootKey := HKEY_LOCAL_MACHINE;
    if Ini.OpenKey(BdeKey, False) then
      if Ini.ValueExists(Ident) then Result := Ini.ReadString(Ident);
{$ELSE}
  Ini := TIniFile.Create('WIN.INI');
  try
    Result := Ini.ReadString('IDAPI', Ident, '');
{$ENDIF}
  { Check for multiple directories, use only the first one }
  if Pos(';', Result) > 0 then Delete(Result, Pos(';', Result), MaxInt);
  if (Length(Result) > 2) and (Result[Length(Result)] <> '\') then
    Result := Result + '\';
  finally
    Ini.Free;
  end;
end;

procedure ExportDataSetEx(Source: TBDEDataSet; DestTable: TTable;
  TableType: TTableType; const AsciiCharSet: string;
  AsciiDelimited: Boolean; AsciiDelimiter, AsciiSeparator: Char;
  MaxRecordCount: Longint);

  function ExportAsciiField(Field: TField): Boolean;
  begin
    Result := Field.Visible and not (Field.Calculated
      {$IFDEF WIN32} or Field.Lookup {$ENDIF}) and not (Field.DataType in
      ftNonTextTypes + [ftUnknown]);
  end;

const
  TextExt = '.TXT';
  SchemaExt = '.SCH';
var
  I: Integer;
  S, Path: string;
  BatchMove: TBatchMove;
  TablePath: array[0..dbiMaxPathLen] of Char;
begin
  if Source = nil then _DBError(SDataSetEmpty);
  if DestTable.Active then DestTable.Close;
{$IFDEF WIN32}
  if Source is TDBDataSet then
    DestTable.SessionName := TDBDataSet(Source).SessionName;
{$ENDIF}
  if (TableType = ttDefault) then begin
    if DestTable.TableType <> ttDefault then
      TableType := DestTable.TableType
    else if (CompareText(ExtractFileExt(DestTable.TableName), TextExt) = 0) then
      TableType := ttASCII;
  end;
  BatchMove := TBatchMove.Create(Application);
  try
    StartWait;
    try
      BatchMove.Mode := batCopy;
      BatchMove.Source := Source;
      BatchMove.Destination := DestTable;
      DestTable.TableType := TableType;
      BatchMove.Mappings.Clear;
      if (DestTable.TableType = ttASCII) then begin
        if CompareText(ExtractFileExt(DestTable.TableName), SchemaExt) = 0 then
          DestTable.TableName := ChangeFileExt(DestTable.TableName, TextExt);
        with Source do
          for I := 0 to FieldCount - 1 do begin
            if ExportAsciiField(Fields[I]) then
              BatchMove.Mappings.Add(Format('%s=%0:s',
                [Fields[I].FieldName]));
          end;
        BatchMove.RecordCount := 1;
      end
      else BatchMove.RecordCount := MaxRecordCount;
      BatchMove.Execute;
      if (DestTable.TableType = ttASCII) then begin
        { ASCII table always created in "fixed" format with "ascii"
          character set }
        with BatchMove do begin
          Mode := batAppend;
          RecordCount := MaxRecordCount;
        end;
        S := ChangeFileExt(ExtractFileName(DestTable.TableName), '');
        Path := NormalDir(ExtractFilePath(DestTable.TableName));
        if Path = '' then begin
          DestTable.Open;
          try
            Check(DbiGetDirectory(DestTable.DBHandle, False, TablePath));
            Path := NormalDir(OemToAnsiStr(StrPas(TablePath)));
          finally
            DestTable.Close;
          end;
        end;
        with TIniFile.Create(ChangeFileExt(Path + S, SchemaExt)) do
        try
          if AsciiCharSet <> '' then
            WriteString(S, 'CharSet', AsciiCharSet)
          else WriteString(S, 'CharSet', 'ascii');
          if AsciiDelimited then begin { change ASCII-file format to CSV }
            WriteString(S, 'Filetype', 'VARYING');
            WriteString(S, 'Delimiter', AsciiDelimiter);
            WriteString(S, 'Separator', AsciiSeparator);
          end;
        finally
          Free;
        end;
        { clear previous output - overwrite existing file }
        S := Path + ExtractFileName(DestTable.TableName);
        if Length(ExtractFileExt(S)) < 2 then
          S := ChangeFileExt(S, TextExt);
        I := FileCreate(S);
        if I < 0 then
          raise EFCreateError.CreateFmt(ResStr(SFCreateError), [S]);
        FileClose(I);
        BatchMove.Execute;
      end;
    finally
      StopWait;
    end;
  finally
    BatchMove.Free;
  end;
end;

procedure ExportDataSet(Source: TBDEDataSet; DestTable: TTable;
  TableType: TTableType; const AsciiCharSet: string;
  AsciiDelimited: Boolean; MaxRecordCount: Longint);
begin
  ExportDataSetEx(Source, DestTable, TableType, AsciiCharSet,
    AsciiDelimited, '"', ',', MaxRecordCount);
end;

procedure ImportDataSet(Source: TBDEDataSet; DestTable: TTable;
  MaxRecordCount: Longint; Mappings: TStrings; Mode: TBatchMode);
var
  BatchMove: TBatchMove;
begin
  if Source = nil then _DBError(SDataSetEmpty);
{$IFDEF WIN32}
  if (Source is TDBDataSet) and not Source.Active then
    TDBDataSet(Source).SessionName := DestTable.SessionName;
{$ENDIF}
  BatchMove := TBatchMove.Create(Application);
  try
    StartWait;
    try
      BatchMove.Mode := Mode;
      BatchMove.Source := Source;
      BatchMove.Destination := DestTable;
      if Mappings.Count > 0 then
        BatchMove.Mappings.AddStrings(Mappings);
      BatchMove.RecordCount := MaxRecordCount;
      BatchMove.Execute;
    finally
      StopWait;
    end;
  finally
    BatchMove.Free;
  end;
end;

function GetNativeHandle(Database: TDatabase; Buffer: Pointer;
  BufSize: Integer): Pointer;
var
  Len: Word;
begin
  Result := nil;
  if Assigned(Database) and Database.Connected then begin
    if Database.IsSQLBased then begin
      Check(DbiGetProp(HDBIOBJ(Database.Handle), dbNATIVEHNDL,
        Buffer, BufSize, Len));
      Result := Buffer;
    end
    else DBError(SLocalDatabase);
  end
  else _DBError(SDatabaseClosed);
end;

procedure BdeTranslate(Locale: TLocale; Source, Dest: PChar; ToOem: Boolean);
var
  Len: Cardinal;
begin
  Len := StrLen(Source);
  if ToOem then AnsiToNativeBuf(Locale, Source, Dest, Len)
  else NativeToAnsiBuf(Locale, Source, Dest, Len);
  if Source <> Dest then Dest[Len] := #0;
end;

function TrimMessage(Msg: PChar): PChar;
var
  Blank: Boolean;
  Source, Dest: PChar;
begin
  Source := Msg;
  Dest := Msg;
  Blank := False;
  while Source^ <> #0 do begin
    if Source^ <= ' ' then Blank := True
    else begin
      if Blank then begin
        Dest^ := ' ';
        Inc(Dest);
        Blank := False;
      end;
      Dest^ := Source^;
      Inc(Dest);
    end;
    Inc(Source);
  end;
  if (Dest > Msg) and ((Dest - 1)^ = '.') then Dec(Dest);
  Dest^ := #0;
  Result := Msg;
end;

function BdeErrorMsg(ErrorCode: DBIResult): string;
var
  I: Integer;
  NativeError: Longint;
  Msg, LastMsg: DBIMSG;
begin
  I := 1;
  DbiGetErrorString(ErrorCode, Msg);
  TrimMessage(Msg);
  if Msg[0] = #0 then Result := Format(ResStr(SBDEError), [ErrorCode])
  else Result := StrPas(Msg);
  while True do begin
    StrCopy(LastMsg, Msg);
    ErrorCode := DbiGetErrorEntry(I, NativeError, Msg);
    if (ErrorCode = DBIERR_NONE) or
      (ErrorCode = DBIERR_NOTINITIALIZED) then Break;
    TrimMessage(Msg);
    if (Msg[0] <> #0) and (StrComp(Msg, LastMsg) <> 0) then
      Result := Format('%s. %s', [Result, Msg]);
    Inc(I);
  end;
  for I := 1 to Length(Result) do
    if Result[I] < ' ' then Result[I] := ' ';
end;

procedure DataSetShowDeleted(DataSet: TBDEDataSet; Show: Boolean);
begin
  with DataSet do begin
    CheckBrowseMode;
    Check(DbiValidateProp(hDBIObj(Handle), curSOFTDELETEON, True));
    DisableControls;
    try
      Check(DbiSetProp(hDBIObj(Handle), curSOFTDELETEON, Ord(Show)));
    finally
      EnableControls;
    end;
    if DataSet is TTable then TTable(DataSet).Refresh
    else begin
      CursorPosChanged;
      First;
    end;
  end;
end;

function CurrentRecordDeleted(DataSet: TBDEDataSet): Boolean;
var
  FRecProp: RECProps;
begin
  Result := False;
  if (DataSet <> nil) and DataSet.Active then begin
    DataSet.GetCurrentRecord(nil);
    if DbiGetRecord(DataSet.Handle, dbiNOLOCK, nil, @FRecProp) = DBIERR_NONE
      then Result := FRecProp.bDeleteFlag;
  end;
end;

procedure DbNotSupported;
begin
  DbiError(DBIERR_NOTSUPPORTED);
end;

procedure ToggleDebugLayer(Active: Boolean; const DebugFile: string);
const
  Options: array[Boolean] of Longint = (0, DEBUGON or OUTPUTTOFILE or
    APPENDTOLOG);
var
  FileName: DBIPATH;
begin
  Check(DbiDebugLayerOptions(Options[Active], StrPLCopy(FileName,
    DebugFile, SizeOf(DBIPATH) - 1)));
end;

initialization
  DbUtils.CreateLocateObject := CreateDbLocate;
{$IFDEF WIN32}
finalization
  ReleaseSaveIndexies;
{$ELSE}
  AddExitProc(ReleaseSaveIndexies);
{$ENDIF}
end.