jvbdeutils.pas

East make Tray Icon in delphi

  AppConName := ConName;
  if AppConName = '' then
  begin
    ExeName := ExtractFileName(Application.ExeName);
    AppConName := Copy(ExeName, 1, Pos('.', ExeName) - 1);
  end;
  IniFile := TIniFile.Create(IniFileName);
  try
    TempStr := IniFile.ReadString(scConNames, idConNames, '');
    if Pos(AppConName, TempStr) = 0 then
    begin
      if TempStr <> '' then
        TempStr := TempStr + ',';
      IniFile.WriteString(scConNames, idConNames, TempStr + AppConName);
    end;
    IniFile.WriteInteger(AppConName, idType, ConType);
    IniFile.WriteString(AppConName, idServer, ConServer);
    if Database.IsSQLBased then
    begin
      IniFile.WriteString(AppConName, idSQLDataFilePath, DBPath);
      IniFile.WriteString(AppConName, idSQLUserID, UserName);
    end
    else
      IniFile.WriteString(AppConName, idDataFilePath, DBPath);
  finally
    IniFile.Free;
  end;
end;

{ BDE aliases routines }

function IsDirectory(const DatabaseName: string): Boolean;
var
  I: Integer;
begin
  Result := True;
  if (DatabaseName = '') then
    Exit;
  I := 1;
  while I <= Length(DatabaseName) do
  begin
    if DatabaseName[I] in LeadBytes then
      Inc(I)
    else
      if DatabaseName[I] in [':', '\'] then
      Exit;
    Inc(I);
  end;
  Result := False;
end;

function GetAliasPath(const AliasName: string): string;
var
  SAlias: DBINAME;
  Desc: DBDesc;
  Params: TStrings;
begin
  Result := '';
  StrPLCopy(SAlias, AliasName, SizeOf(SAlias) - 1);
  AnsiToOem(SAlias, SAlias);
  Check(DbiGetDatabaseDesc(SAlias, @Desc));
  if StrIComp(Desc.szDbType, szCFGDBSTANDARD) = 0 then
  begin
    OemToAnsi(Desc.szPhyName, Desc.szPhyName);
    Result := StrPas(Desc.szPhyName);
  end
  else
  begin
    Params := TStringList.Create;
    try
      Session.Active := True;
      Session.GetAliasParams(AliasName, Params);
      Result := Params.Values['SERVER NAME'];
    finally
      Params.Free;
    end;
  end;
end;

//=== { TJvCloneDataset } ====================================================

procedure TJvCloneDataset.SetSourceHandle(ASourceHandle: HDBICur);
begin
  if ASourceHandle <> FSourceHandle then
  begin
    Close;
    FSourceHandle := ASourceHandle;
    if FSourceHandle <> nil then
      Open;
  end;
end;

function TJvCloneDataset.CreateHandle: HDBICur;
begin
  Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));
end;

procedure TJvCloneDataset.SetReadOnly(Value: Boolean);
begin
  CheckInactive;
  FReadOnly := Value;
end;

//=== { TJvCloneDbDataset } ==================================================

procedure TJvCloneDbDataset.InitFromDataSet(Source: TDBDataSet; Reset: Boolean);
begin
  with Source do
  begin
    Self.SessionName := SessionName;
    Self.DatabaseName := DatabaseName;
    SetSourceHandle(Handle);
    Self.Filter := Filter;
    Self.OnFilterRecord := OnFilterRecord;
    if not Reset then
      Self.Filtered := Filtered;
  end;
  if Reset then
  begin
    Filtered := False;
    First;
  end;
end;

procedure TJvCloneDbDataset.SetSourceHandle(ASourceHandle: HDBICur);
begin
  if ASourceHandle <> FSourceHandle then
  begin
    Close;
    FSourceHandle := ASourceHandle;
    if FSourceHandle <> nil then
      Open;
  end;
end;

function TJvCloneDbDataset.CreateHandle: HDBICur;
begin
  Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));
end;

procedure TJvCloneDbDataset.SetReadOnly(Value: Boolean);
begin
  CheckInactive;
  FReadOnly := Value;
end;

//=== { TJvCloneTable } ======================================================

procedure TJvCloneTable.InitFromTable(SourceTable: TTable; Reset: Boolean);
begin
  with SourceTable do
  begin
    Self.TableType := TableType;
    Self.TableName := TableName;
    Self.SessionName := SessionName;
    Self.DatabaseName := DatabaseName;
    if not Reset then
    begin
      if IndexName <> '' then
        Self.IndexName := IndexName
      else
        if IndexFieldNames <> '' then
        Self.IndexFieldNames := IndexFieldNames;
    end;
    SetSourceHandle(Handle);
    Self.Filter := Filter;
    Self.OnFilterRecord := OnFilterRecord;
    if not Reset then
      Self.Filtered := Filtered;
  end;
  if Reset then
  begin
    Filtered := False;
    DbiResetRange(Handle);
    IndexName := '';
    IndexFieldNames := '';
    First;
  end;
end;

procedure TJvCloneTable.SetSourceHandle(ASourceHandle: HDBICur);
begin
  if ASourceHandle <> FSourceHandle then
  begin
    Close;
    FSourceHandle := ASourceHandle;
    if FSourceHandle <> nil then
      Open;
  end;
end;

procedure TJvCloneTable.SetReadOnly(Value: Boolean);
begin
  CheckInactive;
  FReadOnly := Value;
end;

function TJvCloneTable.CreateHandle: HDBICur;
begin
  Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));
end;

//=== { TJvDBLocate } ========================================================

function CreateDbLocate: TJvLocateObject;
begin
  Result := TJvDBLocate.Create;
end;

destructor TJvDBLocate.Destroy;
begin
  inherited Destroy;
end;

procedure TJvDBLocate.CheckFieldType(Field: TField);
var
  Locale: TLocale;
begin
  if not (Field.DataType in [ftDate, ftTime, ftDateTime]) then
  begin
    if DataSet is TBDEDataSet then
      Locale := TBDEDataSet(DataSet).Locale
    else
      Locale := Session.Locale;
    ConvertStringToLogicType(Locale, FieldLogicMap(Field.DataType),
      Field.DataSize, Field.FieldName, LookupValue, nil);
  end;
end;

function TJvDBLocate.UseKey: Boolean;
var
  I: Integer;
begin
  Result := False;
  if DataSet is TTable then
    with DataSet as TTable do
    begin
      if (not Self.LookupField.IsIndexField) and (not IndexSwitch or
        (not CaseSensitive and Database.IsSQLBased)) then
        Exit;
      if (not LookupExact) and (Self.LookupField.DataType <> ftString) then
        Exit;
      IndexDefs.Update;
      for I := 0 to IndexDefs.Count - 1 do
        with IndexDefs[I] do
          if not (ixExpression in Options) and
            ((ixCaseInsensitive in Options) or CaseSensitive) then
            if SameText(Fields, Self.LookupField.FieldName) then
            begin
              Result := True;
              Exit;
            end;
    end;
end;

function TJvDBLocate.LocateKey: Boolean;
var
  Clone: TJvCloneTable;

  function LocateIndex(Table: TTable): Boolean;
  begin
    with Table do
    begin
      SetKey;
      FieldByName(Self.LookupField.FieldName).AsString := LookupValue;
      if LookupExact then
        Result := GotoKey
      else
      begin
        GotoNearest;
        Result := MatchesLookup(FieldByName(Self.LookupField.FieldName));
      end;
    end;
  end;

begin
  try
    TTable(DataSet).CheckBrowseMode;
    if TTable(DataSet).IndexFieldNames = LookupField.FieldName then
      Result := LocateIndex(TTable(DataSet))
    else
    begin
      Clone := TJvCloneTable.Create(DataSet);
      with Clone do
      try
        ReadOnly := True;
        InitFromTable(TTable(DataSet), True);
        IndexFieldNames := Self.LookupField.FieldName;
        Result := LocateIndex(Clone);
        if Result then
        begin
          Check(DbiSetToCursor(TTable(DataSet).Handle, Handle));
          DataSet.Resync([rmExact, rmCenter]);
        end;
      finally
        Free;
      end;
    end;
  except
    Result := False;
  end;
end;

function TJvDBLocate.FilterApplicable: Boolean;
begin
  Result := IsFilterApplicable(DataSet);
end;


function TJvDBLocate.LocateCallback: Boolean;
var
  Clone: TJvCloneDbDataset;
begin
  Result := False;
  try
    TBDEDataSet(DataSet).CheckBrowseMode;
    Clone := TJvCloneDbDataset.Create(DataSet);
    with Clone do
    try
      ReadOnly := True;
      InitFromDataSet(TDBDataSet(DataSet), True);
      OnFilterRecord := RecordFilter;
      Filtered := True;
      if not (Bof and Eof) then
      begin
        First;
        Result := True;
      end;
      if Result then
      begin
        Check(DbiSetToCursor(TBDEDataSet(DataSet).Handle, Handle));
        DataSet.Resync([rmExact, rmCenter]);
      end;
    finally
      Free;
    end;
  except
    Result := False;
  end;
end;

procedure TJvDBLocate.RecordFilter(DataSet: TDataSet; var Accept: Boolean);
begin
  Accept := MatchesLookup(DataSet.FieldByName(LookupField.FieldName));
end;

function TJvDBLocate.LocateFilter: Boolean;
var
  SaveCursor: TCursor;
begin
  if LookupExact or (LookupField.DataType = ftString) or
    not (DataSet is TDBDataSet) then
    Result := inherited LocateFilter
  else
  begin
    SaveCursor := Screen.Cursor;
    Screen.Cursor := crHourGlass;
    try
      Result := LocateCallback;
    finally
      Screen.Cursor := SaveCursor;
    end;
  end;
end;

{ DataSet locate routines }

function IsFilterApplicable(DataSet: TDataSet): Boolean;
var
  Status: DBIResult;
  Filter: hDBIFilter;
begin
  if DataSet is TBDEDataSet then
  begin
    Status := DbiAddFilter(TBDEDataSet(DataSet).Handle, 0, 0, False, nil,
      nil, Filter);
    Result := (Status = DBIERR_NONE) or (Status = DBIERR_INVALIDFILTER);
    if Result then
      DbiDropFilter(TBDEDataSet(DataSet).Handle, Filter);
  end
  else
    Result := True;
end;

function DataSetFindValue(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
begin
  with TJvDBLocate.Create do
  try
    DataSet := ADataSet;
    if ADataSet is TDBDataSet then
      IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;
    Result := Locate(FieldName, Value, True, False);
  finally
    Free;
  end;
end;

function DataSetFindLike(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
begin
  with TJvDBLocate.Create do
  try
    DataSet := ADataSet;
    if ADataSet is TDBDataSet then
      IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;
    Result := Locate(FieldName, Value, False, False);
  finally
    Free;
  end;
end;

var
  SaveIndexFieldNames: TStringList = nil;

procedure UsesSaveIndexies;
begin
  if SaveIndexFieldNames = nil then
    SaveIndexFieldNames := TStringList.Create;
end;

procedure ReleaseSaveIndices;
begin
  FreeAndNil(SaveIndexFieldNames);
end;

procedure SetIndex(Table: TTable; const IndexFieldNames: string);
var
  IndexToSave: string;
begin
  IndexToSave := Table.IndexFieldNames;
  Table.IndexFieldNames := IndexFieldNames;
  UsesSaveIndexies;
  SaveIndexFieldNames.AddObject(IndexToSave, Table.MasterSource);
end;

procedure RestoreIndex(Table: TTable);
begin
  if (SaveIndexFieldNames <> nil) and (SaveIndexFieldNames.Count > 0) then
  begin
    try
      Table.IndexFieldNames :=
        SaveIndexFieldNames[SaveIndexFieldNames.Count - 1];
      Table.MasterSource :=
        TDataSource(SaveIndexFieldNames.Objects[SaveIndexFieldNames.Count - 1]);
    finally
      SaveIndexFieldNames.Delete(SaveIndexFieldNames.Count - 1);
      if SaveIndexFieldNames.Count = 0 then
        ReleaseSaveIndices;
    end;
  end;
end;

procedure DeleteRange(Table: TTable; IndexFields: array of const;
  FieldValues: array of const);
var
  I: Integer;
  NewIndex: string;
begin
  NewIndex := '';
  for I := Low(IndexFields) to High(IndexFields) do
  begin
    NewIndex := NewIndex + TVarRec(IndexFields[I]).VString^;
    if I <> High(IndexFields) then
      NewIndex := NewIndex + ';';
  end;
  SetIndex(Table, NewIndex);
  try
    Table.SetRange(FieldValues, FieldValues);
    try
      while not Table.Eof do
        Table.Delete;
    finally
      Table.CancelRange;
    end;
  finally
    RestoreIndex(Table);
  end;
end;

procedure ReindexTable(Table: TTable);
var
  WasActive: Boolean;
  WasExclusive: Boolean;
begin
  with Table do
  begin
    WasActive := Active;
    WasExclusive := Exclusive;
    DisableControls;
    try
      if not (WasActive and WasExclusive) then
        Close;
      try
        Exclusive := True;
        Open;
        Check(dbiRegenIndexes(Handle));
      finally
        if not (WasActive and WasExclusive) then
        begin
          Close;
          Exclusive := WasExclusive;
          Active := WasActive;
        end;
      end;
    finally
      EnableControls;
    end;
  end;
end;

procedure PackTable(Table: TTable);
{ This routine copied and modified from demo unit TableEnh.pas
  from Borland Int. }
var
  { CurProp holds information about the structure of the table }
  CurProp: CURProps;
  { Specific information about the table structure, indexes, etc. }
  TblDesc: CRTblDesc;
  { Uses as a handle to the database }
  hDb: hDBIDb;
  { Path to the currently opened table }
  TablePath: array [0..dbiMaxPathLen] of Char;
  Exclusive: Boolean;
begin
  if not Table.Active then
    _DBError(SDataSetClosed);
  Check(DbiGetCursorProps(Table.Handle, CurProp));
  if StrComp(CurProp.szTableType, szPARADOX) = 0 then
  begin
    { Call DbiDoRestructure procedure if PARADOX table }
    hDb := nil;
    { Initialize the table descriptor }
    FillChar(TblDesc, SizeOf(CRTblDesc), 0);
    with TblDesc do