jvbdeutils.pas

East make Tray Icon in delphi

    begin
      { Place the table name in descriptor }
      StrPCopy(szTblName, Table.TableName);
      { Place the table type in descriptor }
      StrCopy(szTblType, CurProp.szTableType);
      bPack := True;
      bProtected := CurProp.bProtected;
    end;
    { Get the current table's directory. This is why the table MUST be
      opened until now }
    Check(DbiGetDirectory(Table.DBHandle, False, TablePath));
    { Close the table }
    Table.Close;
    try
      { NOW: since the DbiDoRestructure call needs a valid DB handle BUT the
        table cannot be opened, call DbiOpenDatabase to get a valid handle.
        Setting TTable.Active = False does not give you a valid handle }
      Check(DbiOpenDatabase(nil, szCFGDBSTANDARD, dbiReadWrite, dbiOpenExcl, nil,
        0, nil, nil, hDb));
      { Set the table's directory to the old directory }
      Check(DbiSetDirectory(hDb, TablePath));
      { Pack the PARADOX table }
      Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
      { Close the temporary database handle }
      Check(DbiCloseDatabase(hDb));
    finally
      { Re-Open the table }
      Table.Open;
    end;
  end
  else
    if StrComp(CurProp.szTableType, szDBASE) = 0 then
  begin
    { Call DbiPackTable procedure if dBase table }
    Exclusive := Table.Exclusive;
    Table.Close;
    try
      Table.Exclusive := True;
      Table.Open;
      try
        Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, nil, True));
      finally
        Table.Close;
      end;
    finally
      Table.Exclusive := Exclusive;
      Table.Open;
    end;
  end
  else
    DbiError(DBIERR_WRONGDRVTYPE);
end;

procedure FetchAllRecords(DataSet: TBDEDataSet);
begin
  with DataSet do
    if not Eof then
    begin
      CheckBrowseMode;
      Check(DbiSetToEnd(Handle));
      Check(DbiGetPriorRecord(Handle, dbiNOLOCK, nil, nil));
      CursorPosChanged;
      UpdateCursorPos;
    end;
end;

procedure BdeFlushBuffers;
var
  I, L: Integer;
  Session: TSession;
  J: Integer;
begin
  for J := 0 to Sessions.Count - 1 do
  begin
    Session := Sessions[J];
    if not Session.Active then
      Continue;
    for I := 0 to Session.DatabaseCount - 1 do
    begin
      with Session.Databases[I] do
        if Connected and not IsSQLBased then
        begin
          for L := 0 to DataSetCount - 1 do
          begin
            if DataSets[L].Active then
              DbiSaveChanges(DataSets[L].Handle);
          end;
        end;
    end;
  end;
end;

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

function DataSetRecNo(DataSet: TDataSet): Longint;
var
  CurProp: CURProps;
  FRecProp: RECProps;
begin
  Result := -1;
  if (DataSet <> nil) and DataSet.Active and (DataSet.State in [dsBrowse,
    dsEdit]) then
  begin
    if not (DataSet is TBDEDataSet) then
    begin
      Result := DataSet.RecNo;
      Exit;
    end;
    if DbiGetCursorProps(TBDEDataSet(DataSet).Handle, CurProp) <> DBIERR_NONE then
      Exit;
    if (StrComp(CurProp.szTableType, szPARADOX) = 0) or
      (CurProp.iSeqNums = 1) then
    begin
      DataSet.GetCurrentRecord(nil);
      if DbiGetSeqNo(TBDEDataSet(DataSet).Handle, Result) <> DBIERR_NONE then
        Result := -1;
    end
    else
      if StrComp(CurProp.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;
  S: hDBISes;
begin
  Result := False;
  if DbiGetCurrSession(S) <> DBIERR_NONE then
    Exit;
  Result := (Database.Handle <> nil) and
    (DbiGetTranInfo(Database.Handle, nil, @Info) = DBIERR_NONE) and
    (Info.exState = xsActive);
  DbiSetCurrSession(S);
end;

function GetBdeDirectory: string;
const
  Ident = 'DLLPATH';
var
  Ini: TRegistry;
const
  BdeKey = 'SOFTWARE\Borland\Database Engine';
begin
  Result := '';
  Ini := TRegistry.Create;
  try
    Ini.RootKey := HKEY_LOCAL_MACHINE;
    if Ini.OpenKey(BdeKey, False) then
      if Ini.ValueExists(Ident) then
        Result := Ini.ReadString(Ident);
  { 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 or Field.Lookup) 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;
  if Source is TDBDataSet then
    DestTable.SessionName := TDBDataSet(Source).SessionName;
  if (TableType = ttDefault) then
  begin
    if DestTable.TableType <> ttDefault then
      TableType := DestTable.TableType
    else
    if AnsiSameText(ExtractFileExt(DestTable.TableName), TextExt) 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 AnsiSameText(ExtractFileExt(DestTable.TableName), SchemaExt) 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.CreateResFmt(@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);
  if (Source is TDBDataSet) and not Source.Active then
    TDBDataSet(Source).SessionName := DestTable.SessionName;
  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(RsELocalDatabase);
  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(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;
{ begin JvDBUtil }

procedure ExecuteSQLScript(Base: TDatabase; const Script: string; const Commit: TCommit; OnProgress: TJvDBProgressEvent; const UserData: Integer);
var
  N: Integer;
  Term: Char;

  function NextQuery: string;
  var
    C: Char;
    Rem: Boolean;
  begin
    Result := '';
    Rem := False;
    while Length(Script) >= N do
    begin
      C := Script[N];
      Inc(N);
      if (C = Term) and not Rem then
        Exit;
      Result := Result + C;
      if (C = '/') and (Length(Script) >= N) and (Script[N] = '*') then
        Rem := True;
      if (C = '*') and (Length(Script) >= N) and (Script[N] = '/') and Rem then
        Rem := False;
    end;
    Result := '';
  end;

  function SetTerm(S: string): Boolean;
  var
    Rem: Boolean;
  begin