Advanced Delphi Systems- Database haberleşme

[Asri]

Aşağıdaki unit'i unit1'de uses olarak ekleyip bu unit içindeki procedure ve function'ları kullanbilirsiniz.

Bu unit program database haberleşme işleminde kullanılır.

Kod: Tümünü seç

unit ads_DCOMUtil;

interface
Uses Classes, MConnect, DBClient, ComCtrls, DBTables, ads_StrDataSet, Windows,
  Forms,DB, DBGrids;

Type
  TFieldDefsComp = Class(TComponent)
  private
    FFieldDefs: TFieldDefs;
    procedure SetFieldDefs(const Value: TFieldDefs);
  Public
    Constructor Create(AOwner : TComponent); Override;
    Destructor Destroy; Override;
  Published
    property FieldDefs : TFieldDefs read FFieldDefs write SetFieldDefs;
  End;
  
procedure UpdateMulti_ads(
  cds        : TClientDataset;
  out Keys   : String;
  out Fields : String);

//DCOM Client routines
Function  ConnectToDCOMServer(DCOMConnection: TDCOMConnection): Boolean;
Function  DlgLogin_ads(out UserName,Password: String): Boolean;
Function  OpenClientDataset(ClientDataset : TClientDataset): Boolean;
Procedure InitClientDCOMConnectionStrings(
  DCOM                : TDCOMConnection;
  DefaultComputerName : String;
  DefaultServerGUID   : String;
  DefaultServerName   : String
  );OverLoad;
Procedure InitClientDCOMConnectionStrings(
  DCOM                : TDCOMConnection;
  var lst             : TStringList;
  DefaultComputerName : String;
  DefaultServerGUID   : String;
  DefaultServerName   : String
  );OverLoad;
procedure NewTextTable_ads(
  TextTable       : TTable;
  Path            : String;
  TextTableSchema : String;
  TextTableData   : String);
procedure DeleteTextTables_ads(var Form : TForm);

//DCOM Server routines
Procedure InitDatabase(dbs : TDatabase; var lst : TStringList);OverLoad;
Procedure InitDatabase(dbs : TDatabase);OverLoad;
Procedure GetDBActivity(RTF : TRichEdit);
Procedure GetConnectionHistory(RTF : TRichEdit);
Procedure GetUpdateHistory(RTF : TRichEdit);
Procedure GetInsertHistory(RTF : TRichEdit);
Function  SetSessionID: String;
Procedure DatabaseHistoryMod(UserName,SessionID,DBID,DBAction: String; Start:Boolean);
Procedure UpdateHistoryMod(UserName,SessionID,DBID,NewValue,OldValue,WhereString,Success: String);
Procedure InsertHistoryMod(UserName,SessionID,DBID,NewValue,WhereString,Success: String);
Procedure ConnectionHistoryMod(UserName,SessionID: String; SignedOn : Boolean);
procedure Check_Login(LoggedIn : Boolean);
function  ValidateUser(const UserName,FirstToken,SecondToken: WideString;var Role :WideString; Users : TStringList): Boolean;
function  ConnectedListUserDelete(UserName,SessionID: WideString; ConnectedList : TStrings): Boolean;
function  ConnectedListUserAdd(UserName: WideString;var SessionID: String;ConnectedList : TStrings): Boolean;
procedure LogPostAttempts_ads(
  UserName,
  SessionID,
  DBID,
  Success,
  EditMode,
  WhereString,
  Data_Before,
  Data_After: String);
Function  DCOMLogin(
  UserName          : WideString;
  FirstToken        : WideString;
  SecondToken       : WideString;
  Users             : TStringList;
  ConnectedList     : TStrings;
  var Role          : WideString;
  var SessionID     : String;
  var LoggedIn      : Boolean;
  var User_Name     : String):Boolean;
{!~ LookupListForOneField
This is a general purpose routine for returning lookup data for use
in a vcl control that uses TStrings, e.g., TComboBox, TListBox.

  ComboBox1.Items.
    SetText(
      PChar(
        LookupListForOneField(
          DBDemos      , //const DBName        : WideString;
          'Customer.db', //const TableName     : WideString;
          'LastName'   , //const FieldName     : WideString;
          ''           , //const WhereString   : WideString;
          ''           , //const OrderByString : WideString
          True         , //const Distinct      : WordBool;
          True         , //const Ordered       : WordBool;
          False        , //const AllowBlank    : WordBool;
          False        );//const InsertBlank   : WordBool): WideString;

}
function LookupListForOneField(
  const DBName        : WideString;
  const TableName     : WideString;
  const FieldName     : WideString;
  const WhereString   : WideString;
  const OrderByString : WideString;
  const Distinct      : WordBool;
  const Ordered       : WordBool;
  const AllowBlank    : WordBool;
  const InsertBlank   : WordBool): WideString;

Function DatasetToHTMLTable(
  Dataset      : TDataset;
  FieldLabels  : String;
  TagTableStart: String;
  TagRowStart  : String;
  TagCellStart : String
  ): WideString;

function LookupManager(
  const UserName      : WideString;
  const SessionID     : WideString;
  const DBID          : WideString;
  const StaleTolerance: TDateTime;
  const DBName        : WideString;
  const TableName     : WideString;
  const FieldsList    : WideString;
  const WhereString   : WideString;
  const OrderByString : WideString;
  const Distinct      : WordBool;
  const Ordered       : WordBool;
  ColName             : String;    //The Field to be used to populate Column Text
  ColAllowBlanks      : WordBool;  //Used only with First Column
  ColInsertBlank      : WordBool;  //Used only with First Column
  StoreName           : String;    //Field name for values that would be stored in db
  out LookupNumber    : Integer;
  var ColumnText      : WideString;//First Column
  var StoreText       : WideString;//List of values that would be stored in db
  var HTMLTable       : WideString;
  var StrTable        : WideString;
  var TextTableSchema : WideString;
  var TextTableData   : WideString;
  var Data            : OleVariant;
  var Query           : TQuery;
  var FieldDefsStr    : WideString;
  var IndexDefs       : TIndexDefs
  ): WideString;
Function LookupIsCached(DatasetName : String): Boolean;
Function LookupShouldBeRefreshed(DatasetName : String): Boolean;
Function BuildLookup(
  const DBID          : WideString;
  const DatasetName   : WideString;
  const DBName        : WideString;
  const TableName     : WideString;
  const FieldsList    : WideString;
  const WhereString   : WideString;
  const OrderByString : WideString;
  const StaleTolerance: TDateTime;
  const Distinct      : WordBool;
  const Ordered       : WordBool;
  out LookupNumber    : Integer;
  var HTMLTable       : WideString;
  var StrTable        : WideString;
  var TextTableSchema : WideString;
  var TextTableData   : WideString;
  var ColName         : String;    //The Field to be used to populate Column Text
  var ColAllowBlanks  : WordBool;  //Used only with First Column
  var ColInsertBlank  : WordBool;  //Used only with First Column
  var ColumnText      : WideString;//First Column
  var StoreName       : String;    //Field name for values that would be stored in db
  var StoreText       : WideString;//List of values that would be stored in db
  var Data            : OleVariant;
  var Query           : TQuery;
  var FieldDefsStr    : WideString;
  var IndexDefs       : TIndexDefs
  ): WideString;
Function GetCachedLookup(
  DatasetName         : WideString;
  out LookupNumber    : Integer;
  var ColumnText      : WideString;
  var StoreText       : WideString;
  var HTMLTable       : WideString;
  var StrTable        : WideString;
  var TextTableSchema : WideString;
  var TextTableData   : WideString;
  var Data            : OleVariant;
  var Query           : TQuery;
  var FieldDefsStr    : WideString;
  var IndexDefs       : TIndexDefs
  ): WideString;
procedure SetLookupColText(
  Dataset             : TDataset; //The data source
  var ColName         : String;   //The Field to be used to populate Column Text
  var ColAllowBlanks  : WordBool; //Used only with First Column
  var ColInsertBlank  : WordBool; //Used only with First Column
  var ColumnText      : String);  //First Column

procedure SetStoreText(
  Dataset          : TDataset; //The data source
  ColName          : String;   //The Field to be used to populate Column Text
  StoreName        : String;   //The Field to be used to populate Column Text
  ColumnText       : String;
  out StoreText    : WideString
  );

//General Routines
{!~ListSaveToFile

This routine saves a list to file.

Arguments:
  FileName    : String;       The file to which the list will be saved
  var List    : TStringList;  The list
  AllowDups   : Boolean;      If false duplicates will be eliminated
  AppendToFile: Boolean;      If true the list will be added to the end of
                              the current contents of the file.  If false the
                              current contents of the file will be appended
                              to the List.  This is irrelevant if OverWriteOld
                              is true.
  OverWriteOld: Boolean;      If True an existing file is overwritten
  Sort        : Boolean;      If True the contents of the file are sorted
  Ascending   : Boolean;      If Sort is True Then assending defines how sorting
                              will be achieved
  MaxLines    : Integer       If MaxLines = -1 Then there is no File size limit
                              otherwise MaxLines represents the maximum number
                              of lines that will be written to file.
}
Procedure ListSaveToFile(
  FileName      : String;
  var List      : TStringList;
  AllowDups     : Boolean;
  AppendToFile  : Boolean;
  OverWriteOld  : Boolean;
  Sort          : Boolean;
  Ascending     : Boolean;
  MaxLines      : Integer;
  DeleteFromTop : Boolean);

function ComponentToString(Component: TComponent): string;

{!~ListSaveMemory

This routine allows a list in memory to be incrementally written to file
based on the number of lines that are allowed to be retained in memory.
If the list is longer than LinesInMemory then the list is saved to file
and purged.
}
Procedure ListSaveMemory(
  LinesInMemory : Integer;
  FileName      : String;
  var List      : TStringList;
  AllowDups     : Boolean;
  AppendToFile  : Boolean;
  OverWriteOld  : Boolean;
  Sort          : Boolean;
  Ascending     : Boolean;
  MaxLines      : Integer;
  DeleteFromTop : Boolean);

Function  GetPersistantString(ValueName, sgDefault: String; lst: TStringList): String;
Function  CreateQueryFromString(var Query: TQuery; QueryString: String): Boolean;
Function  CreateFieldDefsCompFromString(var FieldDefsComp: TFieldDefsComp; FieldDefsCompString: String): Boolean;
procedure SetPersistantString(var Value, ValueName: String; lst: TStringList);
Procedure SaveConfigData;
function  StringToComponent(Value: string): TComponent;
Function  GetQueryStr(Index: Integer): String;
Procedure SetQueryStr(Index: Integer;QueryStr:String);


Type
  TLookupData = Record
    Number          : Integer;
    DBID            : WideString;
    DatasetName     : WideString;
    Created         : TDateTime;
    StaleTolerance  : TDateTime;
    DBName          : WideString;
    TableName       : WideString;
    FieldList       : WideString;
    WhereString     : WideString;
    OrderByString   : WideString;
    Columns         : Integer;
    Records         : Integer;
    Distinct        : WordBool;
    Ordered         : WordBool;
    StrTable        : String;
    TextTableData   : String;
    TextTableSchema : String;
    ColName         : String;   //The Field to be used to populate Column Text
    ColAllowBlanks  : WordBool; //Used only with First Column
    ColInsertBlank  : WordBool; //Used only with First Column
    ColumnText      : String;   //First Column
    StoreName       : String;   //Field name for values that would be stored in db
    StoreText       : String;   //List of values that would be stored in db
    HTMLTable       : String;
    Data            : OleVariant;
    FieldDefsStr    : WideString;
    IndexDefs       : TIndexDefs;
    Query           : TQuery;
    QueryStr        : String;
  End;

Var
  ConfigData        : TStringList;
  Connections       : TStringList;
  LookupTables      : Array of TLookupData;
implementation
Uses
  ads_Exception,
  Messages,
  SysUtils,
  Graphics,
  Controls,
  Dialogs,
  StdCtrls,
  ExtCtrls,
  Buttons
  ;

Var
  UnitName          : String;
  ProcName          : String;
  ConnectionHistory : TStringList;
  UpdateHistory     : TStringList;
  InsertHistory     : TStringList;
  DatabaseHistory   : TStringList;
  ExecutableName    : String;
  ExecutablePath    : String;
  TokenPairs        : TStringList;
  UsersAndRoles     : TStringList;
  ConfigFile        : String;
  ConnectionHistFile: String;
  DatabaseHistFile  : String;
  UpdateHistFile    : String;
  InsertHistFile    : String;
  TokenPairsFile    : String;
  UsersAndRolesFile : String;


function ValidateUser(const UserName,FirstToken,SecondToken: WideString;var Role :WideString; Users : TStringList): Boolean;
Var
  inIndex   : Integer;
  inCounter : Integer;
  boFound   : Boolean;
  inPos     : Integer;
  lstUsers  : TStringList;
begin
  Result    := False;
  ProcName  := 'ValidateUser'; Try
  lstUsers  := TStringList.Create();
  Try
    lstUsers.Clear;
    If Users = nil Then
    Begin
      lstUsers.SetText(PChar(UsersAndRoles.Text));
    End
    Else
    Begin
      lstUsers.SetText(PChar(Users.Text));
    End;
    inIndex   := TokenPairs.IndexOf(FirstToken+'  '+SecondToken);
    If inIndex = -1 Then Exit;
    Role      := lstUsers.Values[UserName];
    If Role <> '' Then
    Begin
      Result := True;
      Exit;
    End;
    boFound := False;
    For inCounter := 0 To lstUsers.Count - 1 Do
    Begin
      inPos := Pos(LowerCase(Trim(UserName))+'=',LowerCase(Trim(lstUsers[inCounter])));
      If inPos <> 0 Then
      Begin
        boFound := True;
        Break;
      End;
    End;
    Result := boFound;
  Finally
    lstUsers.Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

function ConnectedListUserDelete(UserName,SessionID: WideString; ConnectedList : TStrings): Boolean;
Var
  inIndex      : Integer;
  sgUserName   : String;
  sgSpacer     : String;
  sgTemp       : String;
Begin
  Result       := False;
  ProcName     := 'ConnectedListUserDelete'; Try
  Try
    sgSpacer   := '  ';
    sgUserName := Copy(Trim(UserName)+'        ',1,8);
    SessionID  := Trim(SessionID);
    sgTemp     := sgUserName + sgSpacer + SessionID;
    inIndex    := ConnectedList.IndexOf(sgTemp);
    If inIndex = -1 Then Exit;
    ConnectedList.Delete(inIndex);

    inIndex    := Connections.IndexOf(sgTemp);
    If inIndex = -1 Then Exit;
    Connections.Delete(inIndex);
    ConnectedList.SetText(PChar(Connections.Text));
    ConnectionHistoryMod(UserName,SessionID,False);
    Result := True;
  Except
    Result := False;
    Raise;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

function ConnectedListUserAdd(UserName: WideString;var SessionID: String;ConnectedList : TStrings): Boolean;
Var
  sgSpacer    : String;
Begin
  Result      := False;
  ProcName    := 'ConnectedListUserAdd'; Try
  Try
    sgSpacer  := '  ';
    SessionID := SetSessionID;
    UserName  := Copy(Trim(UserName)+'        ',1,8);
   // ConnectedList.Add(UserName+sgSpacer+SessionID);
    Connections.Add(UserName+sgSpacer+SessionID);
    ConnectedList.SetText(PChar(Connections.Text));
    ConnectionHistoryMod(UserName,SessionID,True);
    Result := True;
  Except
    Result := False;
    Raise;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function DCOMLogin(
  UserName          : WideString;
  FirstToken        : WideString;
  SecondToken       : WideString;
  Users             : TStringList;
  ConnectedList     : TStrings;
  var Role          : WideString;
  var SessionID     : String;
  var LoggedIn      : Boolean;
  var User_Name     : String):Boolean;
begin
  Result    := False;
  ProcName  := 'Login'; Try
  User_Name := '';
  LoggedIn  := False;
  If Not ValidateUser(UserName, FirstToken, SecondToken, Role, Users) Then
  Begin
    LoggedIn  := False;
    User_Name := '';
    SessionID := '00000000000000000000';
    Exit;
  End;
  ConnectedListUserAdd(UserName,SessionID,ConnectedList);
  LoggedIn  := True;
  User_Name := UserName;
  Result    := True;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure Check_Login(LoggedIn : Boolean);
Begin
  If Not LoggedIn Then raise Exception.Create('Not logged in');
End;

type
  TfrmLogin = Class(TScrollingWinControl)
  Public
    Constructor Create(AOwner: TComponent); Override;
    Destructor  Destroy; Override;
  Public
    pnlLoginBase: TPanel;
    pnlButtonsBase: TPanel;
    pnlLoginEditBase0: TPanel;
    pnlLoginEditBase: TPanel;
    pnlServerBase0: TPanel;
    pnlServerBase: TPanel;
    pnlServerLabel: TPanel;
    pnlServerSpacer: TPanel;
    pnlServerName: TPanel;
    pnlIDBase: TPanel;
    pnlIDLabel: TPanel;
    pnlIDSpacer: TPanel;
    pnlIDEdit: TPanel;
    edtLogin: TEdit;
    pnlPwdBase: TPanel;
    pnlPwdLabel: TPanel;
    pnlPwdSpacer: TPanel;
    pnlPwdEdit: TPanel;
    edtPassword: TEdit;
    btnOK: TBitBtn;
    btnCancel: TBitBtn;
    procedure btnOKClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  private
    FSuccess: Boolean;
    FPassword: String;
    FUserName: String;
    procedure SetPassword(const Value: String);
    procedure SetSuccess(const Value: Boolean);
    procedure SetUserName(const Value: String);
    { Private declarations }
  public
    { Public declarations }
  published
    property Success  : Boolean read FSuccess write SetSuccess;
    property UserName : String read FUserName write SetUserName;
    property Password : String read FPassword write SetPassword;
  end;

procedure TfrmLogin.btnOKClick(Sender: TObject);
Var
  sgLogin : String;
  sgPW    : String;
begin
  ProcName  := 'TfrmLogin.btnOKClick'; Try
  Success := False;
  sgLogin := Trim(edtLogin.Text);
  sgPW    := Trim(edtPassword.Text);
  If sgLogin = '' Then Exit;
  If sgPW    = '' Then Exit;
  UserName := sgLogin;
  Password := sgPW;
  Success := True;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure TfrmLogin.FormActivate(Sender: TObject);
Var
  User_Name   : string;
  UserNameLen : Dword;
begin
  ProcName  := 'TfrmLogin.FormActivate'; Try
  FSuccess    := False;
  FPassword   := '';
  UserNameLen := 255;
  SetLength(User_Name, UserNameLen);
  If GetUserName(PChar(User_Name), UserNameLen) Then
    FUserName := Copy(User_Name,1,UserNameLen - 1)
  Else
    FUserName := '';
  edtLogin.Text    := FUserName;
  edtPassword.Text := FPassword;
  pnlServerName.Caption := ExtractFileName(Application.ExeName);
  If FUserName = '' Then
    TForm(Owner).ActiveControl := edtLogin
  Else
    TForm(Owner).ActiveControl := edtPassword;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure TfrmLogin.SetPassword(const Value: String);
begin
  ProcName  := 'TfrmLogin.SetPassword'; Try
  If FPassword <> Value Then FPassword := Value;
  edtPassword.Text := FPassword;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure TfrmLogin.SetSuccess(const Value: Boolean);
begin
  ProcName  := 'TfrmLogin.SetSuccess'; Try
  If FSuccess <> Value Then FSuccess := Value;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure TfrmLogin.SetUserName(const Value: String);
begin
  ProcName  := 'TfrmLogin.SetUserName'; Try
  If FUserName <> Value Then FUserName := Value;
  edtLogin.Text := FUserName;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Constructor TfrmLogin.Create(AOwner: TComponent);
  Function IsControl(Obj: TObject): Boolean;
  Begin
    Result := (Obj is TControl);
  End;
Begin
  ProcName  := 'TfrmLogin.Create'; Try
  inherited;
  Self.Parent := TWincontrol(AOwner);

  pnlLoginBase := TPanel.Create(AOwner);
  With pnlLoginBase Do
  Begin
    If IsControl(pnlLoginBase) Then
    Begin
      Parent      := Self;
    End;
    Left          := 0;
    Top           := 0;
    Width         := 254;
    Height        := 170;
    Align         := alClient;
    BevelOuter    := bvNone;
    BorderWidth   := 5;
    Caption       := '  ';
    TabOrder      := 0;
  End;

  pnlButtonsBase := TPanel.Create(AOwner);
  With pnlButtonsBase Do
  Begin
    Parent        := pnlLoginBase;
    Left          := 5;
    Top           := 126;
    Width         := 244;
    Height        := 39;
    Align         := alBottom;
    BevelOuter    := bvNone;
    BorderWidth   := 5;
    Caption       := '  ';
    TabOrder      := 0;
  End;

  btnOK := TBitBtn.Create(AOwner);
  With btnOK Do
  Begin
    Parent        := pnlButtonsBase;
    Left          := 88;
    Top           := 8;
    Width         := 75;
    Height        := 25;
    Caption       := '&OK';
    TabOrder      := 0;
    OnClick       := btnOKClick;
    Kind          := bkOK;
  End;

  btnCancel := TBitBtn.Create(AOwner);
  With btnCancel Do
  Begin
    Parent        := pnlButtonsBase;
    Left          := 168;
    Top           := 8;
    Width         := 75;
    Height        := 25;
    TabOrder      := 1;
    Kind          := bkCancel;
  End;

  pnlLoginEditBase0 := TPanel.Create(AOwner);
  With pnlLoginEditBase0 Do
  Begin
    Parent        := pnlLoginBase;
    Left          := 5;
    Top           := 41;
    Width         := 244;
    Height        := 85;
    Align         := alClient;
    BevelInner    := bvRaised;
    BevelOuter    := bvLowered;
    BorderWidth   := 1;
    Caption       := '  ';
    TabOrder      := 1;
  End;

  pnlLoginEditBase := TPanel.Create(AOwner);
  With pnlLoginEditBase Do
  Begin
    Parent        := pnlLoginEditBase0;
    Left          := 3;
    Top           := 3;
    Width         := 238;
    Height        := 79;
    Align         := alClient;
    BevelOuter    := bvNone;
    BorderWidth   := 5;
    Caption       := '  ';
    TabOrder      := 0;
  End;

  pnlIDBase := TPanel.Create(AOwner);
  With pnlIDBase Do
  Begin
    Parent        := pnlLoginEditBase;
    Left          := 5;
    Top           := 5;
    Width         := 228;
    Height        := 34;
    Align         := alTop;
    BevelOuter    := bvNone;
    BorderWidth   := 5;
    Caption       := '  ';
    TabOrder      := 0;
  End;

  pnlIDLabel := TPanel.Create(AOwner);
  With pnlIDLabel Do
  Begin
    Parent        := pnlIDBase;
    Left          := 5;
    Top           := 5;
    Width         := 60;
    Height        := 24;
    Align         := alLeft;
    Alignment     := taRightJustify;
    BevelOuter    := bvNone;
    Caption       := '&User Name:';
    TabOrder      := 0;
  End;

  pnlIDSpacer := TPanel.Create(AOwner);
  With pnlIDSpacer Do
  Begin
    Parent        := pnlIDBase;
    Left          := 65;
    Top           := 5;
    Width         := 24;
    Height        := 24;
    Align         := alLeft;
    BevelOuter    := bvNone;
    Caption       := '  ';
    TabOrder      := 1;
  End;

  pnlIDEdit := TPanel.Create(AOwner);
  With pnlIDEdit Do
  Begin
    Parent        := pnlIDBase;
    Left          := 89;
    Top           := 5;
    Width         := 134;
    Height        := 24;
    Align         := alClient;
    Alignment     := taLeftJustify;
    BevelOuter    := bvNone;
    Caption       := '  ';
    TabOrder      := 2;
  End;

  edtLogin := TEdit.Create(AOwner);
  With edtLogin Do
  Begin
    Parent        := pnlIDEdit;
    Left          := 0;
    Top           := 0;
    Width         := 121;
    Height        := 21;
    TabOrder      := 0;
  End;

  pnlPwdBase := TPanel.Create(AOwner);
  With pnlPwdBase Do
  Begin
    Parent        := pnlLoginEditBase;
    Left          := 5;
    Top           := 39;
    Width         := 228;
    Height        := 34;
    Align         := alTop;
    BevelOuter    := bvNone;
    BorderWidth   := 5;
    Caption       := '  ';
    TabOrder      := 1;
  End;

  pnlPwdLabel := TPanel.Create(AOwner);
  With pnlPwdLabel Do
  Begin
    Parent        := pnlPwdBase;
    Left          := 5;
    Top           := 5;
    Width         := 60;
    Height        := 24;
    Align         := alLeft;
    Alignment     := taRightJustify;
    BevelOuter    := bvNone;
    Caption       := '&Password:';
    TabOrder      := 0;
  End;

  pnlPwdSpacer := TPanel.Create(AOwner);
  With pnlPwdSpacer Do
  Begin
    Parent        := pnlPwdBase;
    Left          := 65;
    Top           := 5;
    Width         := 24;
    Height        := 24;
    Align         := alLeft;
    BevelOuter    := bvNone;
    Caption       := '  ';
    TabOrder      := 1;
  End;

  pnlPwdEdit := TPanel.Create(AOwner);
  With pnlPwdEdit Do
  Begin
    Parent        := pnlPwdBase;
    Left          := 89;
    Top           := 5;
    Width         := 134;
    Height        := 24;
    Align         := alClient;
    Alignment     := taLeftJustify;
    BevelOuter    := bvNone;
    Caption       := '  ';
    TabOrder      := 2;
  End;

  edtPassword := TEdit.Create(AOwner);
  With edtPassword Do
  Begin
    Parent        := pnlPwdEdit;
    Left          := 0;
    Top           := 0;
    Width         := 121;
    Height        := 21;
    PasswordChar  := '*';
    TabOrder      := 0;
  End;

  pnlServerBase0 := TPanel.Create(AOwner);
  With pnlServerBase0 Do
  Begin
    Parent        := pnlLoginBase;
    Left          := 5;
    Top           := 5;
    Width         := 244;
    Height        := 36;
    Align         := alTop;
    BevelInner    := bvRaised;
    BevelOuter    := bvLowered;
    BorderWidth   := 1;
    Caption       := '  ';
    TabOrder      := 2;
  End;

  pnlServerBase := TPanel.Create(AOwner);
  With pnlServerBase Do
  Begin
    Parent        := pnlServerBase0;
    Left          := 3;
    Top           := 3;
    Width         := 238;
    Height        := 30;
    Align         := alClient;
    BevelOuter    := bvNone;
    BorderWidth   := 5;
    Caption       := '  ';
    TabOrder      := 0;
  End;

  pnlServerLabel := TPanel.Create(AOwner);
  With pnlServerLabel Do
  Begin
    Parent        := pnlServerBase;
    Left          := 5;
    Top           := 5;
    Width         := 64;
    Height        := 20;
    Align         := alLeft;
    Alignment     := taRightJustify;
    BevelOuter    := bvNone;
    Caption       := 'Server:';
    TabOrder      := 0;
  End;

  pnlServerSpacer := TPanel.Create(AOwner);
  With pnlServerSpacer Do
  Begin
    Parent        := pnlServerBase;
    Left          := 69;
    Top           := 5;
    Width         := 24;
    Height        := 20;
    Align         := alLeft;
    BevelOuter    := bvNone;
    Caption       := '  ';
    TabOrder      := 1;
  End;

  pnlServerName := TPanel.Create(AOwner);
  With pnlServerName Do
  Begin
    Parent        := pnlServerBase;
    Left          := 93;
    Top           := 5;
    Width         := 140;
    Height        := 20;
    Align         := alClient;
    Alignment     := taLeftJustify;
    BevelOuter    := bvNone;
    Caption       := 'Oasis';
    TabOrder      := 2;
  End;

  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Destructor TfrmLogin.Destroy;
Begin
  ProcName  := 'TfrmLogin.Destroy'; Try
  pnlServerName    .Free;
  pnlServerSpacer  .Free;
  pnlServerLabel   .Free;
  pnlServerBase    .Free;
  pnlServerBase0   .Free;
  edtPassword      .Free;
  pnlPwdEdit       .Free;
  pnlPwdSpacer     .Free;
  pnlPwdLabel      .Free;
  pnlPwdBase       .Free;
  edtLogin         .Free;
  pnlIDEdit        .Free;
  pnlIDSpacer      .Free;
  pnlIDLabel       .Free;
  pnlIDBase        .Free;
  pnlLoginEditBase .Free;
  pnlLoginEditBase0.Free;
  btnCancel        .Free;
  btnOK            .Free;
  pnlButtonsBase   .Free;
  pnlLoginBase     .Free;
  inherited Destroy;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function DlgLogin_ads(out UserName,Password: String): Boolean;
Var
  Dialog    : TForm;
  Form      : TfrmLogin;
Begin
  Result    := False;
  Dialog    := nil;
  ProcName  := 'DlgLogin_ads'; Try
  Try
    Dialog  := TForm.Create(nil);
    Form       := TfrmLogin.Create(Dialog);
    Form.Parent:= Dialog;
    Form.Align := alClient;
    With Dialog Do
    Begin
      Left          := 509;
      Top           := 252;
      BorderStyle   := bsDialog;
      Caption       := 'Server Login';
      ClientHeight  := 170;
      ClientWidth   := 254;
      Color         := clBtnFace;
      Font.Color    := clWindowText;
      Font.Height   := -11;
      Font.Name     := 'MS Sans Serif';
      Font.Style    := [];
      FormStyle     := fsNormal;
      OldCreateOrder:= False;
      Position      := poScreenCenter;
      OnActivate    := Form.FormActivate;
      PixelsPerInch := 96;
    End;
    SetActiveWindow(Dialog.Handle);
    Dialog.ShowModal;
    If Dialog.ModalResult = mrOK Then
    Begin
      Result := True;
      UserName := Form.UserName;
      Password := Form.Password;
    End;
  Finally
    Dialog.Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function ConnectToDCOMServer(DCOMConnection: TDCOMConnection): Boolean;
Var
  ID : String;
  PW : String;
begin
  Result := False;
  ProcName  := 'ConnectToDCOMServer'; Try
  Try
    If DCOMConnection.Connected Then
    Begin
      Result := True;
      Exit;
    End;
    DCOMConnection.Connected := True;
    If DCOMConnection.Connected Then
    Begin
      Result := True;
      If DlgLogin_ads(ID,PW) Then
      Begin
        DCOMConnection.AppServer.Login(ID,PW);
      End;
    End;
  Except
    Result := False;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Function OpenClientDataset(ClientDataset : TClientDataset): Boolean;
Var
  DCOMConnection : TDCOMConnection;
begin
  Result := False;
  ProcName  := 'OpenClientDataset'; Try
  Try
    DCOMConnection := TDCOMConnection(ClientDataset.RemoteServer);
    If DCOMConnection = nil Then Exit;
    If Not ConnectToDCOMServer(DCOMConnection) Then Exit;
    ClientDataSet.Open;
    Result := True;
  Except
    Result := False;
    Raise;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

{!~ListSaveToFile

This routine saves a list to file.

Arguments:
  FileName    : String;       The file to which the list will be saved
  var List    : TStringList;  The list
  AllowDups   : Boolean;      If false duplicates will be eliminated
  AppendToFile: Boolean;      If true the list will be added to the end of
                              the current contents of the file.  If false the
                              current contents of the file will be appended
                              to the List.  This is irrelevant if OverWriteOld
                              is true.
  OverWriteOld: Boolean;      If True an existing file is overwritten
  Sort        : Boolean;      If True the contents of the file are sorted

  Ascending   : Boolean;      If Sort is True Then assending defines how sorting
                              will be achieved
  MaxLines    : Integer       If MaxLines = -1 Then there is no File size limit
                              otherwise MaxLines represents the maximum number
                              of lines that will be written to file.
}
Procedure ListSaveToFile(
  FileName      : String;
  var List      : TStringList;
  AllowDups     : Boolean;
  AppendToFile  : Boolean;
  OverWriteOld  : Boolean;
  Sort          : Boolean;
  Ascending     : Boolean;
  MaxLines      : Integer;
  DeleteFromTop : Boolean);
Var
  lst           : TStringList;
  inCounter     : Integer;
  NewFile       : TStringList;
  NewFileName   : String;
  NewFilePath   : String;
  NewFileExt    : String;
  NewFileSuffix : String;
  inPos         : Integer;
begin
  ProcName  := 'ListSaveToFile'; Try
  If List.Count = 0 Then Exit;
  lst       := TStringList.create();
  NewFile   := TStringList.create();
  Try
    lst.Clear;
    If Not OverWriteOld Then
    Begin
      If FileExists(FileName) Then lst.LoadFromFile(FileName);
    End;
    If AppendToFile Then
      List.SetText(PChar(lst.Text+List.Text))
    Else
      List.SetText(PChar(List.Text+lst.Text));
    If Not AllowDups Then
    Begin
      lst.Clear;
      lst.Duplicates := dupIgnore;
      For inCounter := 0 To List.Count - 1 Do
      Begin
        lst.Add(List[inCounter]);
      End;
      List.SetText(PChar(lst.Text));
    End;
    If Sort Then
    Begin
      //Sort Ascending
      List.Sorted := True;
      List.Sorted := False;
      If Not Ascending Then
      Begin
        lst.Clear;
        lst.Sorted := False;
        For inCounter := (List.Count - 1) DownTo 0 Do lst.Add(List[inCounter]);
        List.SetText(PChar(lst.Text));
      End;
    End;
    If (List.Count > MaxLines) And (MaxLines <> -1) Then
    Begin
      NewFile.SetText(PChar(List.Text));
      If DeleteFromTop Then
      Begin
        For inCounter := (MaxLines-1) DownTo 0 Do
        Begin
          If List.Count = 0 Then Break;
          List.Delete(inCounter);
        End;
        For inCounter := (NewFile.Count - 1) Downto (MaxLines-1) Do
        Begin
          If NewFile.Count = 0 Then Break;
          NewFile.Delete(inCounter);
        End;
      End
      Else
      Begin
        For inCounter := (list.Count-1) DownTo (list.Count-MaxLines)-1 Do

        Begin
          If List.Count = 0 Then Break;
          List.Delete(inCounter);
        End;
        For inCounter := (NewFile.Count - MaxLines -1) Downto 0 Do
        Begin
          If NewFile.Count = 0 Then Break;
          NewFile.Delete(inCounter);
        End;
      End;
      NewFileName   := ExtractFileName(FileName);
      inPos         := Pos('.',NewFileName);
      If inPos > 0 Then NewFileName := Copy(NewFileName,1,inPos-1);
      NewFilePath   := ExtractFilePath(FileName);
      If Copy(NewFilePath,Length(NewFilePath),1) <> '\' Then
        NewFilePath := NewFilePath + '\';
      NewFileExt    := ExtractFileExt(FileName);
      NewFileSuffix := FormatDateTime('yyyymmddhhnnss',now());
      NewFileName   := NewFilePath+NewFileName+NewFileSuffix+NewFileExt;
      NewFile.SaveToFile(NewFileName);
    End;
    List.SaveToFile(FileName);
  Finally
    lst.Free;
    List.Clear;
    NewFile.Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

{!~ListSaveMemory

This routine allows a list in memory to be incrementally written to file
based on the number of lines that are allowed to be retained in memory.
If the list is longer than LinesInMemory then the list is saved to file
and purged.
}
Procedure ListSaveMemory(
  LinesInMemory : Integer;
  FileName      : String;
  var List      : TStringList;
  AllowDups     : Boolean;
  AppendToFile  : Boolean;
  OverWriteOld  : Boolean;
  Sort          : Boolean;
  Ascending     : Boolean;
  MaxLines      : Integer;
  DeleteFromTop : Boolean);
Begin
  ProcName := 'ListSaveMemory'; Try
  If List.Count < (LinesInMemory+1) Then Exit;
  ListSaveToFile(
    FileName     , //FileName    : String;
    List         , //var List    : TStringList;
    AllowDups    , //AllowDups   : Boolean;
    AppendToFile , //AppendToFile: Boolean;
    OverWriteOld , //OverWriteOld: Boolean;
    Sort         , //Sort        : Boolean;
    Ascending    , //Ascending   : Boolean);
    MaxLines     , //MaxLines    : Integer);
    DeleteFromTop);//DeleteFromTop : Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure ConnectionHistoryMod(UserName,SessionID: String; SignedOn : Boolean);
Var
  sgUser   : String;
  sgTime   : String;
  sgAction : String;
  sgSpacer : String;
  sgTemp   : String;
Begin
  ProcName := 'ConnectionHistoryMod'; Try
  sgSpacer := '  ';
  If SignedOn Then
    sgAction := 'Connect   '
  Else
    sgAction := 'DisConnect';
  SessionID  := Trim(SessionID);
  sgTime := FormatDateTime('yyyymmddhhnnss',Now());
  sgUser := Copy(UserName + '               ',1,8);
  sgTemp := sgTime+sgSpacer+sgUser+sgSpacer+SessionID+sgSpacer+sgAction;
  ConnectionHistory.Add(sgTemp);
  ListSaveMemory(
    20                                  , //LinesInMemory : Integer;
    ConnectionHistFile                  , //FileName    : String;
    ConnectionHistory                   , //var List    : TStringList;
    True                                , //AllowDups   : Boolean;
    True                                , //AppendToFile: Boolean;
    False                               , //OverWriteOld: Boolean;
    True                                , //Sort        : Boolean;
    False                               , //Ascending   : Boolean);
    200                                 , //MaxLines      : Integer;
    False                               );//DeleteFromTop : Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure UpdateHistoryMod(UserName,SessionID,DBID,NewValue,OldValue,WhereString,Success: String);
Var
  sgUser     : String;
  sgTime     : String;
  sgSpacer   : String;
  sgTemp     : String;
  sgDBID     : String;
  sgNewValue : String;
  sgOldValue : String;
  sgWhere    : String;
  sgSuccess  : String;
Begin
  ProcName   := 'UpdateHistoryMod'; Try
  sgSpacer   := '  ';
  sgDBID     := Copy(Trim(DBID)+'                    ',1,20);
  SessionID  := Trim(SessionID);
  sgTime     := FormatDateTime('yyyymmddhhnnss',Now());
  sgUser     := Copy(UserName + '               ',1,8);

  sgOldValue := Copy(Trim(OldValue)  +'                    ',1,20);
  sgOldValue := StringReplace(sgOldValue,#13,' ',[rfReplaceAll]);
  sgOldValue := StringReplace(sgOldValue,#11,' ',[rfReplaceAll]);
  sgOldValue := StringReplace(sgOldValue,#10,' ',[rfReplaceAll]);
  sgOldValue := Copy(Trim(sgOldValue)+'                    ',1,20);

  sgNewValue := Copy(Trim(NewValue)  +'                    ',1,20);
  sgNewValue := StringReplace(sgNewValue,#13,' ',[rfReplaceAll]);
  sgNewValue := StringReplace(sgNewValue,#11,' ',[rfReplaceAll]);
  sgNewValue := StringReplace(sgNewValue,#10,' ',[rfReplaceAll]);
  sgNewValue := Copy(Trim(sgNewValue)+'                    ',1,20);

  sgWhere    := WhereString;
  sgWhere    := StringReplace(sgWhere,#13,' ',[rfReplaceAll]);
  sgWhere    := StringReplace(sgWhere,#11,' ',[rfReplaceAll]);
  sgWhere    := StringReplace(sgWhere,#10,' ',[rfReplaceAll]);
  sgWhere    := Trim(sgWhere);
  sgWhere    := Copy(sgWhere+'                              ',1,30);
  sgSuccess  := Trim(Success);
  sgSuccess  := Copy(sgSuccess+'     ',1,5);
  sgTemp     :=
    sgTime    +sgSpacer+
    sgUser    +sgSpacer+
    SessionID +sgSpacer+
    sgDBID    +sgSpacer+
    sgSuccess +sgSpacer+
    sgNewValue+sgSpacer+
    sgOldValue+sgSpacer+
    sgWhere;
  UpdateHistory.Add(sgTemp);
  ListSaveMemory(
    20                                  , //LinesInMemory : Integer;
    UpdateHistFile                      , //FileName    : String;
    UpdateHistory                       , //var List    : TStringList;
    True                                , //AllowDups   : Boolean;
    True                                , //AppendToFile: Boolean;
    False                               , //OverWriteOld: Boolean;
    True                                , //Sort        : Boolean;
    False                               , //Ascending   : Boolean);
    200                                 , //MaxLines      : Integer;
    False                               );//DeleteFromTop : Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure InsertHistoryMod(UserName,SessionID,DBID,NewValue,WhereString,Success: String);
Var
  sgUser     : String;
  sgTime     : String;
  sgSpacer   : String;
  sgTemp     : String;
  sgDBID     : String;
  sgNewValue : String;
  sgWhere    : String;
  sgSuccess  : String;
Begin
  ProcName   := 'UpdateHistoryMod'; Try
  sgSpacer   := '  ';
  sgDBID     := Copy(Trim(DBID)+'                    ',1,20);
  SessionID  := Trim(SessionID);
  sgTime     := FormatDateTime('yyyymmddhhnnss',Now());
  sgUser     := Copy(UserName + '               ',1,8);

  sgNewValue := Copy(Trim(NewValue)  +'                    ',1,20);
  sgNewValue := StringReplace(sgNewValue,#13,' ',[rfReplaceAll]);
  sgNewValue := StringReplace(sgNewValue,#11,' ',[rfReplaceAll]);
  sgNewValue := StringReplace(sgNewValue,#10,' ',[rfReplaceAll]);
  sgNewValue := Copy(Trim(sgNewValue)+'                    ',1,20);

  sgWhere    := WhereString;
  sgWhere    := StringReplace(sgWhere,#13,' ',[rfReplaceAll]);
  sgWhere    := StringReplace(sgWhere,#11,' ',[rfReplaceAll]);
  sgWhere    := StringReplace(sgWhere,#10,' ',[rfReplaceAll]);
  sgWhere    := Trim(sgWhere);
  sgWhere    := Copy(sgWhere+'                              ',1,30);
  sgSuccess  := Trim(Success);
  sgSuccess  := Copy(sgSuccess+'     ',1,5);
  sgTemp     :=
    sgTime    +sgSpacer+
    sgUser    +sgSpacer+
    SessionID +sgSpacer+
    sgDBID    +sgSpacer+
    sgSuccess +sgSpacer+
    sgNewValue+sgSpacer+
    sgWhere;
  InsertHistory.Add(sgTemp);
  ListSaveMemory(
    20                                  , //LinesInMemory : Integer;
    InsertHistFile                      , //FileName    : String;
    InsertHistory                       , //var List    : TStringList;
    True                                , //AllowDups   : Boolean;
    True                                , //AppendToFile: Boolean;
    False                               , //OverWriteOld: Boolean;
    True                                , //Sort        : Boolean;
    False                               , //Ascending   : Boolean);
    200                                 , //MaxLines      : Integer;
    False                               );//DeleteFromTop : Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure DatabaseHistoryMod(UserName,SessionID,DBID,DBAction: String; Start:Boolean);
Var
  sgUser   : String;
  sgTime   : String;
  sgAction : String;
  sgEvent  : String;
  sgDBID   : String;
  sgSpacer : String;
  sgTemp   : String;
Begin
  ProcName := 'DatabaseHistoryMod'; Try
  sgSpacer := '  ';
  If Start Then
    sgEvent := 'Start'
  Else
    sgEvent := 'Stop ';
  SessionID := Trim(SessionID);
  sgTime := FormatDateTime('yyyymmddhhnnss',Now());
  sgUser := Copy(UserName + '               ',1,8);
  sgDBID := Copy(DBID + '               ',1,15);
  (*
  Actions:
    Insert
    Delete
    Post
    Edit
    Open
    Close
  *)
  sgAction := Copy(DBAction + '               ',1,6);
  sgTemp := sgTime+sgSpacer+sgUser+sgSpacer+SessionID+sgSpacer+sgDBID+sgSpacer+sgAction+sgSpacer+sgEvent;
  DatabaseHistory.Add(sgTemp);
  ListSaveMemory(
    20                                  , //LinesInMemory : Integer;
    DatabaseHistFile                    , //FileName    : String;
    DatabaseHistory                     , //var List    : TStringList;
    True                                , //AllowDups   : Boolean;
    True                                , //AppendToFile: Boolean;
    False                               , //OverWriteOld: Boolean;
    True                                , //Sort        : Boolean;
    False                               , //Ascending   : Boolean);
    200                                 , //MaxLines      : Integer;
    False                               );//DeleteFromTop : Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function SetSessionID: String;
Var
  sgDay  : String;
  sgTime : String;
  inPos  : Integer;
Begin
  ProcName := 'SetSessionID'; Try
  sgTime := FormatFloat('#.000000000000',now());
  sgDay  := FormatDateTime('yyyymmdd',Now());
  inPos := Pos('.',sgTime);
  If inPos > 0 Then sgTime := Copy(sgTime,inPos+1,Length(sgTime)-inPos+1);
  Result := sgDay+sgTime;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure GetTokenPairs;
Var
  FirstToken  : String;
  SecondToken : String;
  sgSpacer    : String;
  sgTemp      : String;
Begin
  ProcName    := 'GetTokenPairs'; Try
  FirstToken  := 'RichardTheLionHearted';
  SecondToken := 'RichardCoeurDeLion';
  sgSpacer    := '  ';
  sgTemp      := FirstToken+sgSpacer+SecondToken;
  TokenPairs.Clear;
  If FileExists(TokenPairsFile) Then
    TokenPairs.LoadFromFile(TokenPairsFile);
  If TokenPairs.Count = 0 Then
  Begin
    TokenPairs.Add(sgTemp);
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure GetUsersAndRoles;
Begin
  ProcName    := 'GetUsersAndRoles'; Try
  UsersAndRoles.Clear;
  If FileExists(UsersAndRolesFile) Then
    UsersAndRoles.LoadFromFile(UsersAndRolesFile);
  If UsersAndRoles.Count = 0 Then
  Begin
    UsersAndRoles.Add('rmaley=admin');
    UsersAndRoles.Add('hwburks=admin');
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure SaveUsersAndRoles;
Begin
  ProcName    := 'SaveUsersAndRoles'; Try
  UsersAndRoles.SaveToFile(UsersAndRolesFile);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure SaveTokenPairs;
Begin
  ProcName    := 'SaveTokenPairs'; Try
  UsersAndRoles.SaveToFile(UsersAndRolesFile);
  TokenPairs.SaveToFile(TokenPairsFile);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure SaveDatabaseHistory;
Begin
  ProcName    := 'SaveDatabaseHistory'; Try
  ListSaveToFile(
    DatabaseHistFile                    , //FileName    : String;
    DatabaseHistory                     , //var List    : TStringList;
    True                                , //AllowDups   : Boolean;
    True                                , //AppendToFile: Boolean;
    False                               , //OverWriteOld: Boolean;
    True                                , //Sort        : Boolean;
    False                               , //Ascending   : Boolean);
    5000                                , //MaxLines      : Integer;
    False                               );//DeleteFromTop : Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure SaveUpdateHistory;
Begin
  ProcName    := 'SaveUpdateHistory'; Try
  ListSaveToFile(
    UpdateHistFile                      , //FileName    : String;
    UpdateHistory                       , //var List    : TStringList;
    True                                , //AllowDups   : Boolean;
    True                                , //AppendToFile: Boolean;
    False                               , //OverWriteOld: Boolean;
    True                                , //Sort        : Boolean;
    False                               , //Ascending   : Boolean);
    5000                                , //MaxLines      : Integer;
    False                               );//DeleteFromTop : Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure SaveInsertHistory;
Begin
  ProcName    := 'SaveInsertHistory'; Try
  ListSaveToFile(
    InsertHistFile                      , //FileName    : String;
    InsertHistory                       , //var List    : TStringList;
    True                                , //AllowDups   : Boolean;
    True                                , //AppendToFile: Boolean;
    False                               , //OverWriteOld: Boolean;
    True                                , //Sort        : Boolean;
    False                               , //Ascending   : Boolean);
    5000                                , //MaxLines      : Integer;
    False                               );//DeleteFromTop : Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure SaveConnectionHistory;
Begin
  ProcName    := 'SaveConnectionHistory'; Try
  ListSaveToFile(
    ConnectionHistFile                  , //FileName    : String;
    ConnectionHistory                   , //var List    : TStringList;
    True                                , //AllowDups   : Boolean;
    True                                , //AppendToFile: Boolean;
    False                               , //OverWriteOld: Boolean;
    True                                , //Sort        : Boolean;
    False                               , //Ascending   : Boolean);
    5000                                , //MaxLines      : Integer;
    False                               );//DeleteFromTop : Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure GetDBActivity(RTF : TRichEdit);
Begin
  ProcName    := 'GetDBActivity'; Try
  SaveDatabaseHistory;
  RTF.Lines.LoadFromFile(DatabaseHistFile);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure GetConnectionHistory(RTF : TRichEdit);
Begin
  ProcName    := 'GetConnectionHistory'; Try
  SaveConnectionHistory;
  RTF.Lines.LoadFromFile(ConnectionHistFile);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure GetUpdateHistory(RTF : TRichEdit);
Begin
  ProcName    := 'GetUpdateHistory'; Try
  SaveUpdateHistory;
  RTF.Lines.LoadFromFile(UpdateHistFile);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure GetInsertHistory(RTF : TRichEdit);
Begin
  ProcName    := 'GetInsertHistory'; Try
  SaveInsertHistory;
  RTF.Lines.LoadFromFile(InsertHistFile);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure GetConfigData;
Begin
  ProcName    := 'GetConfigData'; Try
  ConfigData.Clear;
  If FileExists(ConfigFile) Then
    ConfigData.LoadFromFile(ConfigFile);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure SaveConfigData;
Begin
  ProcName    := 'SaveConfigData'; Try
  ConfigData.SaveToFile(ConfigFile);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function GetPersistantString(ValueName, sgDefault: String; lst: TStringList): String;
Var
  sgIniValue : String;
  boModified : Boolean;
Begin
  Result     := '';
  ProcName   := 'GetPersistantString'; Try
  boModified := False;
  sgIniValue := lst.Values[ValueName];
  If sgIniValue = '' Then
  Begin
    If sgDefault <> '' Then
    Begin
      sgIniValue := sgDefault;
      boModified := True;
    End;
  End;
  If boModified Then lst.Values[ValueName] := sgIniValue;
  Result     := sgIniValue;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

procedure SetPersistantString(var Value, ValueName: String; lst: TStringList);
Begin
  ProcName   := 'SetPersistantString'; Try
  lst.Values[ValueName] := Value;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure InitDatabase(dbs : TDatabase);OverLoad;
Begin
  ProcName   := 'InitDatabase1'; Try
  InitDatabase(dbs,ConfigData);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure InitDatabase(dbs : TDatabase; var lst : TStringList);OverLoad;
Begin
  ProcName   := 'InitDatabase'; Try
  If dbs.Connected Then Exit;
  dbs.Params.Values['SERVER NAME']         := GetPersistantString('SERVER NAME','UNKNOWN',lst);
  dbs.Params.Values['DATABASE NAME']       := GetPersistantString('DATABASE NAME','UNKNOWN',lst);
  dbs.Params.Values['USER NAME']           := GetPersistantString('USER NAME','UNKNOWN',lst);
  dbs.Params.Values['OPEN MODE']           := GetPersistantString('OPEN MODE','READ/WRITE',lst);
  dbs.Params.Values['SCHEMA CACHE SIZE']   := GetPersistantString('SCHEMA CACHE SIZE','8',lst);
  dbs.Params.Values['SQLPASSTHRU MODE']    := GetPersistantString('SQLPASSTHRU MODE','SHARED AUTOCOMMIT',lst);
  dbs.Params.Values['LOCK MODE']           := GetPersistantString('LOCK MODE','5',lst);
  dbs.Params.Values['DATE MODE']           := GetPersistantString('DATE MODE','0',lst);
  dbs.Params.Values['DATE SEPARATOR']      := GetPersistantString('DATE SEPARATOR','/',lst);
  dbs.Params.Values['SCHEMA CACHE TIME']   := GetPersistantString('SCHEMA CACHE TIME','-1',lst);
  dbs.Params.Values['MAX ROWS']            := GetPersistantString('MAX ROWS','-1',lst);
  dbs.Params.Values['BATCH COUNT']         := GetPersistantString('BATCH COUNT','200',lst);
  dbs.Params.Values['ENABLE SCHEMA CACHE'] := GetPersistantString('ENABLE SCHEMA CACHE','FALSE',lst);
  dbs.Params.Values['ENABLE BCD']          := GetPersistantString('ENABLE BCD','FALSE',lst);
  dbs.Params.Values['LIST SYNONYMS']       := GetPersistantString('LIST SYNONYMS','NONE',lst);
  dbs.Params.Values['BLOBS TO CACHE']      := GetPersistantString('BLOBS TO CACHE','64',lst);
  dbs.Params.Values['BLOB SIZE']           := GetPersistantString('BLOB SIZE','32',lst);
  dbs.Params.Values['PASSWORD']            := GetPersistantString('PASSWORD','UNKNOWN',lst);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure InitClientDCOMConnectionStrings(
  DCOM                : TDCOMConnection;
  var lst             : TStringList;
  DefaultComputerName : String;
  DefaultServerGUID   : String;
  DefaultServerName   : String
  );OverLoad;
Begin
  ProcName            := 'InitClientDCOMConnectionStrings'; Try
  DCOM.ComputerName   := GetPersistantString('ComputerName',DefaultComputerName,lst);
  DCOM.ServerGUID     := GetPersistantString('ServerGUID'  ,DefaultServerGUID  ,lst);
  DCOM.ServerName     := GetPersistantString('ServerName'  ,DefaultServerName  ,lst);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure InitClientDCOMConnectionStrings(
  DCOM                : TDCOMConnection;
  DefaultComputerName : String;
  DefaultServerGUID   : String;
  DefaultServerName   : String
  );OverLoad;
Begin
  ProcName            := 'InitClientDCOMConnectionStrings1'; Try
  InitClientDCOMConnectionStrings(
    DCOM                ,  //DCOM                : TDCOMConnection;
    ConfigData          ,  //var lst             : TStringList;
    DefaultComputerName ,  //DefaultComputerName : String;
    DefaultServerGUID   ,  //DefaultServerGUID   : String;
    DefaultServerName      //DefaultServerName   : String
                        ); //);OverLoad;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

//Devamı bir sonraki sayfada

[Asri]

Bir önceki sayfanın devamı..........

Kod: Tümünü seç

{!~ LookupListForOneField
This is a general purpose routine for returning lookup data for use
in a vcl control that uses TStrings, e.g., TComboBox, TListBox.

  ComboBox1.Items.
    SetText(
      PChar(
        LookupListForOneField(
          DBDemos      , //const DBName        : WideString;
          'Customer.db', //const TableName     : WideString;
          'LastName'   , //const FieldName     : WideString;
          ''           , //const WhereString   : WideString;
          ''           , //const OrderByString : WideString
          True         , //const Distinct      : WordBool;
          True         , //const Ordered       : WordBool;
          False        , //const AllowBlank    : WordBool;
          False        );//const InsertBlank   : WordBool): WideString;

}
function LookupListForOneField(
  const DBName        : WideString;
  const TableName     : WideString;
  const FieldName     : WideString;
  const WhereString   : WideString;
  const OrderByString : WideString;
  const Distinct      : WordBool;
  const Ordered       : WordBool;
  const AllowBlank    : WordBool;
  const InsertBlank   : WordBool): WideString;
Var
  qry                 : TQuery;
  inPos               : Integer;
  lst                 : TStringList;
  sgTemp              : String;
  boBlankFound        : Boolean;
begin
  Result              := '';
  ProcName            := 'LookupListForOneField'; Try
  If Trim(DBName)     = '' Then Exit;
  If Trim(TableName)  = '' Then Exit;
  If Trim(FieldName)  = '' Then Exit;
  qry                 := TQuery.Create(nil);
  lst                 := TStringList.Create();
  Try
    With qry Do
    Begin
      Active          := False;
      RequestLive     := False;
      DatabaseName    := DBName;
      With Sql Do
      Begin
        Clear;
        Add('Select');
        If Distinct Then Add('Distinct');
        Add(FieldName);
        Add('From');
        inPos := Pos('.DB',UpperCase(TableName));
        If inPos > 0 Then
        Begin
          Add('"'+TableName+'"');
        End
        Else
        Begin
          Add(TableName);
        End;
        If Trim(WhereString) <> '' Then
        Begin
          inPos := (Pos('WHERE',UpperCase(WhereString)));
          If inPos = 0 Then Add('Where');
          Add(Trim(WhereString));
        End;
        If Ordered Then
        Begin
          If Trim(OrderByString) <> '' Then
          Begin
            inPos := (Pos('ORDER BY',UpperCase(OrderByString)));
            If inPos = 0 Then Add('Order By');
            Add(Trim(OrderByString));
          End;
        End;
      End;

      Active := True;
      boBlankFound := False;
      lst.Clear;
      First;
      While Not EOF Do
      Begin
        sgTemp := FieldByName(FieldName).AsString;
        sgTemp := Trim(sgTemp);
        If sgTemp = '' Then
        Begin
          boBlankFound := True;
          Next;
          Continue;
        End;
        lst.Add(sgTemp);
        Next;
      End;
      If AllowBlank Then
      Begin
        If boBlankFound Then
        Begin
          lst.Insert(0,'');
        End
        Else
        Begin
          If InsertBlank Then lst.Insert(0,'');
        End;
      End;
    End;
    Result := lst.Text;
  Finally
    qry.Free;
    lst.Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Function BuildLookup(
  const DBID          : WideString;
  const DatasetName   : WideString;
  const DBName        : WideString;
  const TableName     : WideString;
  const FieldsList    : WideString;
  const WhereString   : WideString;
  const OrderByString : WideString;
  const StaleTolerance: TDateTime;
  const Distinct      : WordBool;
  const Ordered       : WordBool;
  out LookupNumber    : Integer;
  var HTMLTable       : WideString;
  var StrTable        : WideString;
  var TextTableSchema : WideString;
  var TextTableData   : WideString;
  var ColName         : String;    //The Field to be used to populate Column Text
  var ColAllowBlanks  : WordBool;  //Used only with First Column
  var ColInsertBlank  : WordBool;  //Used only with First Column
  var ColumnText      : WideString;//First Column
  var StoreName       : String;    //Field name for values that would be stored in db
  var StoreText       : WideString;//List of values that would be stored in db
  var Data            : OleVariant;
  var Query           : TQuery;
  var FieldDefsStr    : WideString;
  var IndexDefs       : TIndexDefs
  ): WideString;
Var
  qry                 : TQuery;
  inPos               : Integer;
  sgTextTableSchema   : String;
  sgTextTableData     : String;
  sgColumnText        : String;
  QueryStr            : String;
  lst                 : TStringList;
  FieldDefsComp       : TFieldDefsComp;
begin
  Result              := '';
  ProcName            := 'BuildLookup'; Try
  If Trim(DBName)     = '' Then Exit;
  If Trim(TableName)  = '' Then Exit;
  If Trim(FieldsList) = '' Then Exit;
  qry                 := TQuery.Create(nil);
  Try
    With qry Do
    Begin
      Active          := False;
      RequestLive     := False;
      DatabaseName    := DBName;
      With Sql Do
      Begin
        Clear;
        Add('Select');
        If Distinct Then Add('Distinct');
        Add(FieldsList);
        Add('From');
        inPos := Pos('.DB',UpperCase(TableName));
        If inPos > 0 Then
        Begin
          Add('"'+TableName+'"');
        End
        Else
        Begin
          Add(TableName);
        End;
        If Trim(WhereString) <> '' Then
        Begin
          inPos := (Pos('WHERE',UpperCase(WhereString)));
          If inPos = 0 Then Add('Where');
          Add(Trim(WhereString));
        End;
        If Ordered Then
        Begin
          If Trim(OrderByString) <> '' Then
          Begin
            inPos := (Pos('ORDER BY',UpperCase(OrderByString)));
            If inPos = 0 Then Add('Order By');
            Add(Trim(OrderByString));
          End;
        End;
      End;
      Active       := True;
      Data         := qry.Provider.Data;
      ConvTDataSetToTextTable_ads(
        Qry            , //DataSet:TDataSet;
        DBID           , //TableName: String;
        sgTextTableSchema, //out TextTableSchema,
        sgTextTableData);//TextTableData:String;): Boolean; OverLoad;

      TextTableSchema := sgTextTableSchema;
      TextTableData   := sgTextTableData;

      SetLookupColText(
        Qry             ,//Dataset             : TDataset; //The data source
        ColName         , //var ColName         : String;   //The Field to be used to populate Column Text
        ColAllowBlanks  , //var ColAllowBlanks  : WordBool; //Used only with First Column
        ColInsertBlank  , //var ColInsertBlank  : WordBool; //Used only with First Column
        sgColumnText    );//var ColumnText      : String);  //First Column
      ColumnText := sgColumnText;
      SetStoreText(
        Qry       , //Dataset          : TDataset; //The data source
        ColName   , //ColName          : String;   //The Field to be used to populate Column Text
        StoreName , //StoreName        : String;   //The Field to be used to populate Column Text
        ColumnText, //ColumnText       : String;
        StoreText); //out StoreText    : WideString
      HTMLTable :=
        DatasetToHTMLTable(
          Qry, //Dataset      : TDataset;
          '' , //FieldLabels  : String;
          '' , //TagTableStart: String;
          '' , //TagRowStart  : String;
          ''   //TagCellStart : String
             );//): WideString;
      StrTable := ConvTDataSetToStrTable(DatasetName,qry);
      SetLength(LookupTables,Length(LookupTables)+1);
      LookupNumber                                       := Length(LookupTables);
      LookupTables[Length(LookupTables)-1].HTMLTable     := HTMLTable;
      LookupTables[Length(LookupTables)-1].Number        := LookupNumber;
      LookupTables[Length(LookupTables)-1].DBID          := DBID;
      LookupTables[Length(LookupTables)-1].DatasetName   := DatasetName;
      LookupTables[Length(LookupTables)-1].Created       := Now();
      LookupTables[Length(LookupTables)-1].StaleTolerance:= StaleTolerance;
      LookupTables[Length(LookupTables)-1].DBName        := DBName;
      LookupTables[Length(LookupTables)-1].TableName     := TableName;
      LookupTables[Length(LookupTables)-1].FieldList     := FieldsList;
      LookupTables[Length(LookupTables)-1].WhereString   := WhereString;
      LookupTables[Length(LookupTables)-1].OrderByString := OrderByString;
      LookupTables[Length(LookupTables)-1].Distinct      := Distinct;
      LookupTables[Length(LookupTables)-1].Ordered       := Ordered;
      LookupTables[Length(LookupTables)-1].StrTable      := StrTable;
      LookupTables[Length(LookupTables)-1].Columns       := FieldCount;
      LookupTables[Length(LookupTables)-1].Records       :=
        StrDBGetTableRecordCount(
          LookupTables[Length(LookupTables)-1].StrTable,
          LookupTables[Length(LookupTables)-1].DatasetName);
      LookupTables[Length(LookupTables)-1].TextTableSchema:= TextTableSchema;
      LookupTables[Length(LookupTables)-1].TextTableData  := TextTableData;
      LookupTables[Length(LookupTables)-1].ColName        := ColName;
      LookupTables[Length(LookupTables)-1].ColAllowBlanks := ColAllowBlanks;
      LookupTables[Length(LookupTables)-1].ColInsertBlank := ColInsertBlank;
      LookupTables[Length(LookupTables)-1].ColumnText     := ColumnText;
      LookupTables[Length(LookupTables)-1].StoreName      := StoreName;
      LookupTables[Length(LookupTables)-1].StoreText      := StoreText;
      LookupTables[Length(LookupTables)-1].Data           := Data;
      Result := LookupTables[Length(LookupTables)-1].StrTable;
    End;


    FieldDefsComp       := TFieldDefsComp.Create(nil);
    lst                 := TStringList.Create();
    Try
      FieldDefsComp.FieldDefs := qry.FieldDefs;
      FieldDefsStr := ComponentToString(FieldDefsComp);
      lst.SetText(PChar(String(FieldDefsStr)));
      LookupTables[Length(LookupTables)-1].FieldDefsStr       := FieldDefsStr;
      lst.SetText(PChar(String(LookupTables[Length(LookupTables)-1].FieldDefsStr)));
    Finally
      FieldDefsComp.Free;
      lst.Free;
    End;

    IndexDefs := TIndexDefs.Create(qry);
    LookupTables[Length(LookupTables)-1].IndexDefs      := IndexDefs;
    qry.Tag := 9;
    QueryStr                                            := ComponentToString(qry);
    LookupTables[Length(LookupTables)-1].QueryStr       := QueryStr;
    lst                 := TStringList.Create();
    Try
      lst.SetText(PChar(QueryStr));
      lst.SetText(PChar(LookupTables[Length(LookupTables)-1].QueryStr));
    Finally
      lst.Free;
    End;
    LookupTables[Length(LookupTables)-1].Query          := qry;
    LookupTables[Length(LookupTables)-1].Query.Active   := False;
    Query                                               :=
      LookupTables[Length(LookupTables)-1].Query;
    
    qry.Active := False;
  Finally
    qry := nil;
    qry.Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

function LookupManager(
  const UserName      : WideString;
  const SessionID     : WideString;
  const DBID          : WideString;
  const StaleTolerance: TDateTime;
  const DBName        : WideString;
  const TableName     : WideString;
  const FieldsList    : WideString;
  const WhereString   : WideString;
  const OrderByString : WideString;
  const Distinct      : WordBool;
  const Ordered       : WordBool;
  ColName             : String;    //The Field to be used to populate Column Text
  ColAllowBlanks      : WordBool;  //Used only with First Column
  ColInsertBlank      : WordBool;  //Used only with First Column
  StoreName           : String;    //Field name for values that would be stored in db
  out LookupNumber    : Integer;
  var ColumnText      : WideString;//First Column
  var StoreText       : WideString;//List of values that would be stored in db
  var HTMLTable       : WideString;
  var StrTable        : WideString;
  var TextTableSchema : WideString;
  var TextTableData   : WideString;
  var Data            : OleVariant;
  var Query           : TQuery;
  var FieldDefsStr    : WideString;
  var IndexDefs       : TIndexDefs
  ): WideString;
Var
  boExists        : Boolean;
  sgLUName        : String;
  boRefresh       : Boolean;
Begin
  ProcName  := 'LookupManager'; Try
  DatabaseHistoryMod(
    UserName  , //UserName,
    SessionID , //SessionID
    DBID      , //DBID,
    'Open'    , //DBAction: String;
    True      );//Start:Boolean);
  boRefresh:= True;
  sgLUName :=
    UpperCase(
      DBName                       +'_'+
      TableName                    +'_'+
      FieldsList                   +'_'+
      WhereString                  +'_'+
      OrderByString                +'_');
  If Distinct Then sgLUName := sgLUName + 'T_' Else sgLUName := sgLUName + 'F_';
  If Ordered  Then sgLUName := sgLUName + 'T_' Else sgLUName := sgLUName + 'F_';

  boExists := LookupIsCached(sgLUName);
  If boExists Then boRefresh:= LookupShouldBeRefreshed(sgLUName);
  If Not boRefresh Then
  Begin
    //Use it;
    Result :=
      GetCachedLookup(
        sgLUName        , //DatasetName         : String;
        LookupNumber    , //out LookupNumber    : Integer;
        ColumnText      , //var ColumnText      : String;
        StoreText       , //var StoreText       : String;
        HTMLTable       , //var HTMLTable       : WideString;
        StrTable        , //var StrTable        : String;
        TextTableSchema , //var TextTableSchema : String;
        TextTableData   , //var TextTableData   : String
        Data            , //var Data            : OleVariant
        Query           , //var Query           : TQuery;
        FieldDefsStr    , //var FieldDefsStr    : WideString;
        IndexDefs         //var IndexDefs       : TIndexDefs
                        );//): WideString;
  End
  Else
  Begin
    //Build it;
    Result :=
      BuildLookup(
        DBID            ,  //const DBID            : WideString;
        sgLUName        ,  //const DatasetName     : WideString;
        DBName          ,  //const DBName          : WideString;
        TableName       ,  //const TableName       : WideString;
        FieldsList      ,  //const FieldsList      : WideString;
        WhereString     ,  //const WhereString     : WideString;
        OrderByString   ,  //const OrderByString   : WideString;
        StaleTolerance  ,  //const StaleTolerance  : TDateTime;
        Distinct        ,  //const Distinct        : WordBool;
        Ordered         ,  //const Ordered         : WordBool;
        LookupNumber    ,  //out   LookupNumber    : Integer;
        HTMLTable       ,  //var   HTMLTable       : WideString;
        StrTable        ,  //var   StrTable        : WideString;
        TextTableSchema ,  //var   TextTableSchema : WideString;
        TextTableData   ,  //var   TextTableData   : WideString;
        ColName         ,  //var   ColName         : String;    //The Field to be used to populate Column Text
        ColAllowBlanks  ,  //var   ColAllowBlanks  : WordBool;  //Used only with First Column
        ColInsertBlank  ,  //var   ColInsertBlank  : WordBool;  //Used only with First Column
        ColumnText      ,  //var   ColumnText      : WideString;//First Column
        StoreName       ,  //var   StoreName       : String;    //Field name for values that would be stored in db
        StoreText       ,  //var   StoreText       : WideString;//List of values that would be stored in db
        Data            ,  //var   Data            : OleVariant;
        Query           ,  //var   Query           : TQuery;
        FieldDefsStr    ,  //var   FieldDefsStr    : WideString;
        IndexDefs          //var   IndexDefs       : TIndexDefs
                        ); //): WideString;
  End;
  DatabaseHistoryMod(
    UserName  , //UserName,
    SessionID , //SessionID
    DBID      , //DBID,
    'Open'    , //DBAction: String;
    False      );//Start:Boolean);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;  
End;

Function LookupIsCached(DatasetName : String): Boolean;
Var
  inCounter : Integer;
  inLast    : Integer;
Begin
  Result    := False;
  ProcName  := 'LookupIsCached'; Try
  inLast    := Length(LookupTables)-1;
  //EnterCriticalSection(CS);
  For inCounter := 0 To inLast Do
  Begin
    If LookupTables[inCounter].DatasetName = DatasetName Then
    Begin
      Result := True;
      Break;
    End;
  End;
  //LeaveCriticalSection(CS);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function LookupShouldBeRefreshed(DatasetName : String): Boolean;
Var
  inCounter : Integer;
  inLast    : Integer;
  dtNow     : TDateTime;
  dtStale   : TDateTime;
  Rec       : TLookupData;
Begin
  Result    := True;
  ProcName  := 'LookupShouldBeRefreshed'; Try
  inLast    := Length(LookupTables)-1;
  dtNow     := Now();
  For inCounter := 0 To inLast Do
  Begin
    If LookupTables[inCounter].DatasetName = DatasetName Then
    Begin
      dtStale := dtNow - LookupTables[inCounter].Created;
      Rec       := LookupTables[inCounter];
      If dtStale <= Rec.StaleTolerance Then Result := False;
      Break;
    End;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function GetCachedLookup(
  DatasetName         : WideString;
  out LookupNumber    : Integer;
  var ColumnText      : WideString;
  var StoreText       : WideString;
  var HTMLTable       : WideString;
  var StrTable        : WideString;
  var TextTableSchema : WideString;
  var TextTableData   : WideString;
  var Data            : OleVariant;
  var Query           : TQuery;
  var FieldDefsStr    : WideString;
  var IndexDefs       : TIndexDefs
  ): WideString;
Var
  inCounter : Integer;
  inLast    : Integer;
Begin
  Result    := '';
  ProcName  := 'GetCachedLookup'; Try
  inLast    := Length(LookupTables)-1;
  LookupNumber := -1;
  For inCounter := 0 To inLast Do
  Begin
    If LookupTables[inCounter].DatasetName = DatasetName Then
    Begin
      ColumnText      := LookupTables[inCounter].ColumnText;
      StoreText       := LookupTables[inCounter].StoreText;
      StrTable        := LookupTables[inCounter].StrTable;
      HTMLTable       := LookupTables[inCounter].HTMLTable;
      TextTableSchema := LookupTables[inCounter].TextTableSchema;
      TextTableData   := LookupTables[inCounter].TextTableData;
      Data            := LookupTables[inCounter].Data;
      Query           := LookupTables[inCounter].Query;
      LookupNumber    := LookupTables[inCounter].Number;
      FieldDefsStr    := LookupTables[inCounter].FieldDefsStr;
      IndexDefs       := LookupTables[inCounter].IndexDefs;
      Result          := LookupTables[inCounter].ColumnText;
      Break;
    End;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

procedure SetLookupColText(
  Dataset             : TDataset; //The data source
  var ColName         : String;   //The Field to be used to populate Column Text
  var ColAllowBlanks  : WordBool; //Used only with First Column
  var ColInsertBlank  : WordBool; //Used only with First Column
  var ColumnText      : String);  //First Column
Var
  inCounter : Integer;
  boFound   : Boolean;
  sgTemp    : String;
  lst       : TStringList;
  NoDups    : TStringList;
  wasActive : Boolean;
Begin
  ProcName  := 'SetLookupColText'; Try
  If Not ColAllowBlanks Then
  Begin
    If ColInsertBlank Then
    Begin
      ColAllowBlanks := True;
    End
    Else
    Begin
      ColAllowBlanks := False;
    End;
  End;
  ColumnText := '';
  If Dataset.FieldList.Count = 0 Then Exit;

  If Trim(ColName) = '' Then
  Begin
    If Dataset.FieldList.Count > 0 Then
      ColName := Dataset.FieldList.Fields[0].DisplayName;
  End;
  boFound := False;
  For inCounter := 0 To Dataset.FieldList.count -1 Do
  Begin
    sgTemp := UpperCase(Dataset.FieldList.Fields[inCounter].DisplayName);
    If UpperCase(ColName) = sgTemp Then
    Begin
      boFound := True;
      Break;
    End;
  End;
  If Not boFound Then ColName := Dataset.FieldList.Fields[0].DisplayName;
  lst    := TStringList.Create();
  NoDups := TStringList.Create();
  Try
    lst.Clear;
    With DataSet Do
    Begin
      wasActive := Dataset.Active;
      If Not Dataset.Active Then Dataset.Active := True;
      First;
      boFound := False;
      While Not EOF Do
      Begin
        sgTemp := FieldByName(ColName).AsString;
        sgTemp := Trim(sgTemp);
        If sgTemp = '' Then
        Begin
          boFound := True;
          Next;
          Continue;
        End;
        lst.Add(sgTemp);
        Next;
      End;
      If wasActive <> Dataset.Active Then Dataset.Active := wasActive;
    End;
    NoDups.Clear;
    NoDups.Duplicates := dupIgnore;
    NoDups.Sorted     := True;
    For inCounter := 0 To lst.Count - 1 Do
    Begin
      NoDups.Add(lst[inCounter]);
    End;
    NoDups.Sorted := False;
    lst.SetText(PChar(NoDups.Text));
    If ColAllowBlanks Then
    Begin
      If boFound Then
      Begin
        lst.Insert(0,'');
      End
      Else
      Begin
        If ColInsertBlank Then lst.Insert(0,'');
      End;
    End;
    ColumnText := lst.Text;
  Finally
    lst   .Free;
    NoDups.Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function DatasetToHTMLTable(
  Dataset      : TDataset;
  FieldLabels  : String;
  TagTableStart: String;
  TagRowStart  : String;
  TagCellStart : String
  ): WideString;
Var
  inCols       : Integer;
  lst          : TStringList;
  sgRow        : String;
  sgField      : String;
  sgTableStart : String;
  sgRowStart   : String;
  sgCellStart  : String;
  sgTableEnd   : String;
  sgRowEnd     : String;
  sgCellEnd    : String;
  WasActive    : Boolean;
  inCounter    : Integer;
  lstLabels    : TStringList;
  sgTable      : String;
Begin
  ProcName     := 'DatasetToHTMLTable'; Try
  TagTableStart:= Trim(TagTableStart);
  If TagTableStart = '' Then
    sgTableStart := '<table>'
  Else
    sgTableStart := TagTableStart;
  TagRowStart  := Trim(TagRowStart);
  If TagRowStart = '' Then
    sgRowStart := '<tr>'
  Else
    sgRowStart := TagRowStart;
  TagCellStart := Trim(TagCellStart);
  If TagCellStart = '' Then
    sgCellStart := '<td>'
  Else
    sgCellStart := TagCellStart;
  lst          := TStringList.Create();
  lstLabels    := TStringList.Create();
  Try
    lst        .Clear;
    lstLabels  .Clear;
    If Trim(FieldLabels) <> '' Then
    Begin
      FieldLabels := StringReplace(FieldLabels,#13,#200,[rfReplaceAll]);
      FieldLabels := StringReplace(FieldLabels,',',#200,[rfReplaceAll]);
      FieldLabels := StringReplace(FieldLabels,#10,#200,[rfReplaceAll]);
      FieldLabels := StringReplace(FieldLabels,#200#200#200,#200,[rfReplaceAll]);
      FieldLabels := StringReplace(FieldLabels,#200#200,#200,[rfReplaceAll]);
      FieldLabels := StringReplace(FieldLabels,#200,#13,[rfReplaceAll]);
      lstLabels.SetText(PChar(FieldLabels));
    End
    Else
    Begin
      lstLabels.Clear;
      For inCounter := 0 To DataSet.FieldCount - 1 Do
      Begin
        lstLabels.Add(Dataset.Fields[inCounter].DisplayLabel);
      End;
    End;
    sgTable      := '';
    With DataSet Do
    Begin
      WasActive := Active;
      If Not Active Then Active := True;
      inCols := Dataset.FieldCount;
      //lst.Add(sgTableStart);
      sgTable := sgTable + sgTableStart;
      If lstLabels.Text <> '' Then
      Begin
        sgRow         := sgRowStart;
        For inCounter := 0 To inCols - 1 Do
        Begin
          If inCounter < lstLabels.Count Then
          Begin
            sgField     := lstLabels[inCounter];
            sgField     := sgCellStart+sgField+sgCellEnd;
          End
          Else
          Begin
            sgField     := '';
            sgField     := sgCellStart+sgField+sgCellEnd;
          End;
          sgRow       := sgRow+sgField;
        End;
        sgRow         := sgRow+sgRowEnd;
        //lst.Add(sgRow);
        sgTable := sgTable + sgRow;
      End;
      First;
      While Not EOF Do
      Begin
        sgRow         := sgRowStart;
        For inCounter := 0 To inCols - 1 Do
        Begin
          sgField     := Dataset.Fields[inCounter].AsString;
          sgField     := sgCellStart+sgField+sgCellEnd;
          sgRow       := sgRow+sgField;
        End;
        sgRow         := sgRow+sgRowEnd;
        //lst.Add(sgRow);
        sgTable := sgTable + sgRow;
        Next;
      End;
      lst.Add(sgTableEnd);
      sgTable := sgTable + sgTableEnd;
      If WasActive <> Active Then Active := WasActive;
    End;
    Result := sgTable;
  Finally
    lst.Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

procedure NewTextTable_ads(
  TextTable       : TTable;
  Path            : String;
  TextTableSchema : String;
  TextTableData   : String);
Var
  inCounter : Integer;
  sgTblName : String;
  Text_Table: String;
  lst       : TStringList;
begin
  ProcName     := 'NewTextTable_ads'; Try
    Path := Trim(Path);
    If Path <> '' Then
    Begin
      If Copy(Path,Length(Path),1) <> '\' Then Path := Path + '\';
    End
    Else
    Begin
      Path := ExtractFileDir(ParamStr(0));
      If Copy(Path,Length(Path),1) <> '\' Then Path := Path + '\';
    End;
    For inCounter := 1 To 1000 Do
    Begin
      sgTblName := Path + 'Text'+IntToStr(inCounter)+'.txt';
      If FileExists(sgTblName) Then
      Begin
        sgTblName := '';
        Continue;
      End;
      sgTblName := 'Text'+IntToStr(inCounter);
      Break;
    End;
    If sgTblName = '' Then Exit;
    Text_Table := sgTblName;
    lst        := TStringList.Create();
    Try
      lst.Clear;
      lst.SetText(PChar(String(TextTableSchema)));
      Try lst[0] := '['+Text_Table+']'; Except End;
      lst.Clear;
      lst.SetText(PChar(String(TextTableData)));
      TextTable.Active       := False;
      TextTable.DatabaseName := Path;
      TextTable.TableName    := Text_Table+'.txt';
      TextTable.TableType    := ttAscii;
      For inCounter := 1 To 100 Do
      Begin
        Try
          TextTable.Active       := True;
        Except
          Sleep(100);
        End;
        If TextTable.Active Then Break;
      End;
    Finally
      lst.Free;
    End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure DeleteTextTables_ads(var Form : TForm);
Var
  Table     : TTable;
  inCounter : Integer;
Begin
  ProcName     := 'DeleteTextTables_ads'; Try
  With Form Do
  Begin
    For inCounter := 0 To ComponentCount - 1 Do
    Begin
      If Components[inCounter] is TTable Then
      Begin
        Table := TTable(Components[inCounter]);
        If Table.TableType = ttAscii Then
        Begin
          Table.Active := False;
          Table.DeleteTable;
        End;
      End;
    End;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

function ComponentToString(Component: TComponent): string;
var
  BinStream:TMemoryStream;
  StrStream: TStringStream;
  s: string;
begin
  ProcName  := 'ComponentToString'; Try
  BinStream := TMemoryStream.Create;
  try
    StrStream := TStringStream.Create(s);
    try
      BinStream.WriteComponent(Component);
      BinStream.Seek(0, soFromBeginning);
      ObjectBinaryToText(BinStream, StrStream);
      StrStream.Seek(0, soFromBeginning);
      Result:= StrStream.DataString;
    finally
      StrStream.Free;
    end;
  finally
    BinStream.Free
  end;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Function CreateQueryFromString(var Query: TQuery; QueryString: String): Boolean;
Begin
  Result     := True;
  ProcName   := 'CreateQueryFromString'; Try
  Try
    Query    := TQuery.Create(nil);
    Query    := TQuery(StringToComponent(QueryString));
  Except
    Result   := False;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function CreateFieldDefsCompFromString(var FieldDefsComp: TFieldDefsComp; FieldDefsCompString: String): Boolean;
Begin
  Result     := True;
  ProcName   := 'CreateFieldDefsCompFromString'; Try
  Try
    FieldDefsComp    := TFieldDefsComp.Create(nil);
    FieldDefsComp    := TFieldDefsComp(StringToComponent(FieldDefsCompString));
  Except
    Result   := False;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;



function StringToComponent(Value: string): TComponent;
var
  StrStream:TStringStream;
  BinStream: TMemoryStream;
begin
  Result    := nil;
  ProcName  := 'StringToComponent'; Try
  StrStream := TStringStream.Create(Value);
  try
    BinStream := TMemoryStream.Create;
    try
      ObjectTextToBinary(StrStream, BinStream);
      BinStream.Seek(0, soFromBeginning);
      Result := BinStream.ReadComponent(nil);
    finally
      BinStream.Free;
    end;
  finally
    StrStream.Free;
  end;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Function GetQueryStr(Index: Integer): String;
Var
  inCounter : Integer;
  inLast    : Integer;
Begin
  Result    := '';
  ProcName  := 'GetQueryStr'; Try
  inLast    := Length(LookupTables)-1;
  For inCounter := 0 To inLast Do
  Begin
    If LookupTables[inCounter].Number = Index Then
    Begin
      Result        := LookupTables[inCounter].QueryStr;
      Break;
    End;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Procedure SetQueryStr(Index: Integer;QueryStr:String);
Var
  inCounter : Integer;
  inLast    : Integer;
begin
  ProcName  := 'SetQueryStr'; Try
  inLast    := Length(LookupTables)-1;
  For inCounter := 0 To inLast Do
  Begin
    If LookupTables[inCounter].Number = Index Then
    Begin
      LookupTables[inCounter].QueryStr := QueryStr;
      Break;
    End;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

{ TFieldDefsComp }

constructor TFieldDefsComp.Create(AOwner: TComponent);
begin
  ProcName  := 'TFieldDefsComp.Create'; Try
  inherited;
  FieldDefs := TFieldDefs.Create(AOwner);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

destructor TFieldDefsComp.Destroy;
begin
  ProcName  := 'TFieldDefsComp.Destroy'; Try
  FieldDefs.Free;
  inherited;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure TFieldDefsComp.SetFieldDefs(const Value: TFieldDefs);
begin
  ProcName  := 'TFieldDefsComp.SetFieldDefs'; Try
  FFieldDefs := Value;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure SetStoreText(
  Dataset          : TDataset; //The data source
  ColName          : String;   //The Field to be used to populate Column Text
  StoreName        : String;   //The Field to be used to populate Column Text
  ColumnText       : String;
  out StoreText    : WideString
  );
Var
  sgDisplay        : String;
  sgStore          : String;
  lstDisplay       : TStringList;
  lstStore         : TStringList;
  ActiveWas        : Boolean;
  inCount          : Integer;
  inCounter        : Integer;
Begin
  ProcName         := 'SetStoreText'; Try
  lstDisplay       := TStringList.Create();
  lstStore         := TStringList.Create();
  Try
    lstDisplay.SetText(PChar(String(ColumnText)));
    ActiveWas      := DataSet.Active;
    Dataset.Active := True;
    inCount        := lstDisplay.Count;
    lstStore.Clear;
    For inCounter := 0 To inCount - 1 Do
    Begin
      lstStore.Add('');
    End;
    For inCounter := 0 To inCount - 1 Do
    Begin
      sgDisplay := lstDisplay[inCounter];
      If sgDisplay = '' Then Continue;
      sgStore := '';
      Dataset.First;
      While Not Dataset.EOF Do
      Begin
        If Trim(UpperCase(Dataset.FieldByName(ColName).AsString)) = Trim(UpperCase(sgDisplay)) Then
        Begin
          sgStore := Dataset.FieldByName(StoreName).AsString;
          Break;
        End;
        Dataset.Next;
      End;
      lstStore[inCounter] := sgStore;
    End;
    StoreText := lstStore.Text;
    If Dataset.Active <> ActiveWas Then Dataset.Active := ActiveWas;
  Finally
    lstDisplay   .Free;
    lstStore     .Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

procedure UpdateMulti_ads(
  cds        : TClientDataset;
  out Keys   : String;
  out Fields : String);
Var
  inCounter  : Integer;
  lstKeys    : TStringList;
Begin
  ProcName   := 'UpdateMulti_ads'; Try
  lstKeys    := TStringList.Create();
  Try
    lstKeys.Clear;
    For inCounter := 0 To cds.FieldCount Do
    Begin
      //If cds.FieldDefs[inCounter].Tag = 1 Then
      //Begin
     //   lstKeys.Add(cds.FieldDefs[inCounter].Name+'='+cds.Fields[inCounter].AsString);
     // End;
    End;
    ShowMessage(lstKeys.Text);
  Finally
    lstKeys.Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

procedure LogPostAttempts_ads(
  UserName,
  SessionID,
  DBID,
  Success,
  EditMode,
  WhereString,
  Data_Before,
  Data_After: String);
Var
  lstBefore : TStringList;
  lstAfter  : TStringList;
  sgBefore  : String;
  sgAfter   : String;
  inCounter : Integer;
  IsUpdate  : Boolean;
begin
  ProcName := 'LogPostAttempts_ads'; Try
  lstBefore := TStringList.Create();
  lstAfter  := TStringList.Create();
  Try
    IsUpdate    := (UpperCase(EditMode)='UPDATE');
    Data_Before := StringReplace(Data_Before,#200,#13,[rfReplaceAll]);
    Data_After  := StringReplace(Data_After ,#200,#13,[rfReplaceAll]);
    lstBefore   .SetText(PChar(Data_Before));
    lstAfter    .SetText(PChar(Data_After));
    If lstBefore.Count <> lstAfter.Count Then Exit;
    For inCounter := 0 To lstBefore.Count -1 Do
    Begin
      sgBefore  := lstBefore[inCounter];
      sgAfter   := lstAfter[inCounter];
      If sgBefore = sgAfter Then Continue;
      If IsUpdate Then
      Begin
        UpdateHistoryMod(UserName,SessionID,DBID+IntToStr(inCounter),sgAfter,sgBefore,WhereString,Success);
      End
      Else
      Begin
        InsertHistoryMod(UserName,SessionID,DBID+IntToStr(inCounter),sgAfter,WhereString,Success);
      End;
    End;
  Finally
    lstBefore .Free;
    lstAfter  .Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Initialization
  UnitName          := 'ads_DCOMUtil';
  RegisterClasses([TQuery,TStringField,TFieldDefs,TComponent,TFieldDefsComp]);
  SetLength(LookupTables,1);
  ProcName          := 'Unknown';
  ConnectionHistory := TStringList.Create();
  UpdateHistory     := TStringList.Create();
  InsertHistory     := TStringList.Create();
  DatabaseHistory   := TStringList.Create();
  TokenPairs        := TStringList.Create();
  UsersAndRoles     := TStringList.Create();
  ConfigData        := TStringList.Create();
  Connections       := TStringList.Create();
  ExecutableName    := ExtractFileName(ParamStr(0));
  ExecutableName    := Copy(ExecutableName,1,Length(ExecutableName)-4);
  ExecutablePath    := ExtractFilePath(ParamStr(0));
  If Copy(ExecutablePath,Length(ExecutablePath),1) <> '\' Then
    ExecutablePath  := ExecutablePath+'\';
  ConfigFile        := ExecutablePath+ExecutableName+'.svr';
  ConnectionHistFile:= ExecutablePath+ExecutableName+'.hcn';
  DatabaseHistFile  := ExecutablePath+ExecutableName+'.hdb';
  UpdateHistFile    := ExecutablePath+ExecutableName+'.hup';
  InsertHistFile    := ExecutablePath+ExecutableName+'.hin';
  TokenPairsFile    := ExecutablePath+ExecutableName+'.tok';
  UsersAndRolesFile := ExecutablePath+ExecutableName+'.usr';
  GetConfigData;
  GetTokenPairs;
  GetUsersAndRoles;
Finalization
  SaveConnectionHistory;
  ConnectionHistory.Free;
  SaveDatabaseHistory;
  DatabaseHistory.Free;
  SaveTokenPairs;
  TokenPairs.Free;
  SaveUsersAndRoles;
  UsersAndRoles.Free;
  SaveConfigData;
  ConfigData.Free;
  Connections.Free;
  SaveUpdateHistory;
  UpdateHistory.Free;
  SaveInsertHistory;
  InsertHistory.Free;
end.