bdeutils.pas

rxlib2.75控件包

                begin
                  DateTime := StrToDateTime(Value);
{$IFDEF WIN32}
                  TimeStamp := DateTimeToTimeStamp(DateTime);
                  D := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));
{$ELSE}
                  DtData := DateTime * MSecsPerDay;
{$ENDIF}
                end;
            end;
          end;
          Move(D, Buffer^, FldSize);
        end;
      else DbiError(DBIERR_INVALIDFLDTYPE);
    end;
  finally
    if Allocate then FreeMem(Buffer, FldSize);
  end;
end;

{ Execute Query routine }

procedure ExecuteQueryEx(const SessName, DbName, QueryText: string);
begin
  with TQuery.Create(Application) do
  try
    DatabaseName := DbName;
{$IFDEF WIN32}
    SessionName := SessName;
{$ENDIF}
    SQL.Add(QueryText);
    ExecSQL;
  finally
    Free;
  end;
end;

procedure ExecuteQuery(const DbName, QueryText: string);
begin
  ExecuteQueryEx('', DbName, QueryText);
end;

{ Database Login routine }

function LoginToDatabase(Database: TDatabase; OnLogin: TDatabaseLoginEvent): Boolean;
var
  EndLogin: Boolean;
begin
  Result := Database.Connected;
  if Result then Exit;
  Database.OnLogin := OnLogin;
  EndLogin := True;
  repeat
    try
      Database.Connected := True;
      EndLogin := True;
    except
      on E: EDbEngineError do begin
        EndLogin := (MessageDlg(E.Message + '. ' + LoadStr(SRetryLogin),
          mtConfirmation, [mbYes, mbNo], 0) <> mrYes);
      end;
      on E: EDatabaseError do begin
        { User select "Cancel" in login dialog }
        MessageDlg(E.Message, mtError, [mbOk], 0);
      end;
      else raise;
    end;
  until EndLogin;
  Result := Database.Connected;
end;

{ ReportSmith runtime initialization routine }

procedure InitRSRUN(Database: TDatabase; const ConName: string;
  ConType: Integer; const ConServer: string);
const
  IniFileName = 'RPTSMITH.CON';
  scConNames = 'ConnectNamesSection';
  idConNames = 'ConnectNames';
  idType = 'Type';
  idServer = 'Server';
  idSQLDataFilePath = 'Database';
  idDataFilePath = 'DataFilePath';
  idSQLUserID = 'USERID';
var
  ParamList: TStringList;
  DBPath: string[127];
  TempStr, AppConName: string[127];
  UserName: string[30];
  ExeName: string[12];
  IniFile: TIniFile;
begin
  ParamList := TStringList.Create;
  try
{$IFDEF WIN32}
    Database.Session.GetAliasParams(Database.AliasName, ParamList);
{$ELSE}
    Session.GetAliasParams(Database.AliasName, ParamList);
{$ENDIF}
    if Database.IsSQLBased then DBPath := ParamList.Values['SERVER NAME']
    else DBPath := ParamList.Values['PATH'];
    UserName := ParamList.Values['USER NAME'];
  finally
    ParamList.Free;
  end;
  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
{$IFDEF RX_D3}
    if DatabaseName[I] in LeadBytes then Inc(I) else
{$ENDIF RX_D3}
    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
{$IFDEF WIN32}
      Session.Active := True;
{$ENDIF}
      Session.GetAliasParams(AliasName, Params);
      Result := Params.Values['SERVER NAME'];
    finally
      Params.Free;
    end;
  end;
end;

{ TCloneDataset }

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

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

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

{ TCloneDbDataset }

procedure TCloneDbDataset.InitFromDataSet(Source: TDBDataSet; Reset: Boolean);
begin
  with Source do begin
{$IFDEF WIN32}
    Self.SessionName := SessionName;
{$ENDIF}
    Self.DatabaseName := DatabaseName;
    SetSourceHandle(Handle);
{$IFDEF WIN32}
    Self.Filter := Filter;
    Self.OnFilterRecord := OnFilterRecord;
    if not Reset then Self.Filtered := Filtered;
{$ENDIF}
  end;
  if Reset then begin
{$IFDEF WIN32}
    Filtered := False;
{$ENDIF}
    First;
  end;
end;

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

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

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

{ TCloneTable }

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

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

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

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

{ TDBLocate }

function CreateDbLocate: TLocateObject;
begin
  Result := TDBLocate.Create;
end;

{$IFNDEF WIN32}
function CallbackFilter(pDBLocate: Longint; RecBuf: Pointer;
  RecNo: Longint): Smallint;
  {$IFDEF WIN32} stdcall; {$ELSE} export; {$ENDIF WIN32}
begin
  Result := TDBLocate(pDBLocate).RecordFilter(RecBuf, RecNo);
end;
{$ENDIF WIN32}

destructor TDBLocate.Destroy;
begin
{$IFNDEF WIN32}
  DropFilter;
{$ENDIF}
  inherited Destroy;
end;

procedure TDBLocate.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 TDBLocate.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 AnsiCompareText(Fields, Self.LookupField.FieldName) = 0 then
            begin
              Result := True;
              Exit;
            end;
    end;
end;

function TDBLocate.LocateKey: Boolean;
var
  Clone: TCloneTable;

  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 := TCloneTable.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 TDBLocate.FilterApplicable: Boolean;
begin
  Result := IsFilterApplicable(DataSet);
end;

{$IFDEF WIN32}

function TDBLocate.LocateCallback: Boolean;
var
  Clone: TCloneDbDataset;
begin
  Result := False;
  try
    TBDEDataSet(DataSet).CheckBrowseMode;
    Clone := TCloneDbDataset.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 TDBLocate.RecordFilter(DataSet: TDataSet; var Accept: Boolean);
begin
  Accept := MatchesLookup(DataSet.FieldByName(LookupField.FieldName));