{Copyright(c)2000 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
maley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to maley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
Please note if you are viewing this Delphi unit as a web page all you have to
do to turn it into a Delphi unit is save it with a ".pas" extension. The
html in the unit should not affect its performance.
}
unit ads_DCOMUtil;
(*UnitIndex Master Index Implementation Section Download UnitsDescription: ads_DCOMUtil.pas This unit contains the following routines.
BuildLookup Check_Login ComponentToString ConnectedListUserAdd ConnectedListUserDelete ConnectionHistoryMod ConnectToDCOMServer CreateFieldDefsCompFromString CreateQueryFromString DatabaseHistoryMod DatasetToHTMLTable DCOMLogin DeleteTextTables_ads DlgLogin_ads GetCachedLookup GetConfigData GetConnectionHistory GetDBActivity GetInsertHistory GetPersistantString GetQueryStr GetTokenPairs GetUpdateHistory GetUsersAndRoles InitClientDCOMConnectionStrings_1 InitClientDCOMConnectionStrings_2 InitDatabase_1 InitDatabase_2 InsertHistoryMod ListSaveMemory ListSaveToFile LogPostAttempts_ads LookupIsCached LookupListForOneField LookupManager LookupShouldBeRefreshed NewTextTable_ads OpenClientDataset SaveConfigData SaveConnectionHistory SaveDatabaseHistory SaveInsertHistory SaveTokenPairs SaveUpdateHistory SaveUsersAndRoles SetLookupColText SetPersistantString SetQueryStr SetSessionID SetStoreText StringToComponent TFieldDefsComp.SetFieldDefs TfrmLogin.btnOKClick TfrmLogin.FormActivate TfrmLogin.SetPassword TfrmLogin.SetSuccess TfrmLogin.SetUserName UpdateHistoryMod UpdateMulti_ads ValidateUser
*)
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Indexprocedure 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; //Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Indexprocedure 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; //Unit Description UnitIndex Master Index
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; //Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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.
}
//Unit Description UnitIndex Master Index
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.
}
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master IndexProcedure SaveUsersAndRoles; Begin ProcName := 'SaveUsersAndRoles'; Try UsersAndRoles.SaveToFile(UsersAndRolesFile); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
Procedure SaveTokenPairs; Begin ProcName := 'SaveTokenPairs'; Try UsersAndRoles.SaveToFile(UsersAndRolesFile); TokenPairs.SaveToFile(TokenPairsFile); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master IndexProcedure GetDBActivity(RTF : TRichEdit); Begin ProcName := 'GetDBActivity'; Try SaveDatabaseHistory; RTF.Lines.LoadFromFile(DatabaseHistFile); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
Procedure GetConnectionHistory(RTF : TRichEdit); Begin ProcName := 'GetConnectionHistory'; Try SaveConnectionHistory; RTF.Lines.LoadFromFile(ConnectionHistFile); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
Procedure GetUpdateHistory(RTF : TRichEdit); Begin ProcName := 'GetUpdateHistory'; Try SaveUpdateHistory; RTF.Lines.LoadFromFile(UpdateHistFile); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
Procedure GetInsertHistory(RTF : TRichEdit); Begin ProcName := 'GetInsertHistory'; Try SaveInsertHistory; RTF.Lines.LoadFromFile(InsertHistFile); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master IndexProcedure SaveConfigData; Begin ProcName := 'SaveConfigData'; Try ConfigData.SaveToFile(ConfigFile); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Indexprocedure 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; //Unit Description UnitIndex Master Index
Procedure InitDatabase(dbs : TDatabase);OverLoad; Begin ProcName := 'InitDatabase1'; Try InitDatabase(dbs,ConfigData); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
{!~ 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;
}
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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 := '| ' Else sgCellStart := TagCellStart; sgTableEnd := ' |
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Indexprocedure TFieldDefsComp.SetFieldDefs(const Value: TFieldDefs); begin ProcName := 'TFieldDefsComp.SetFieldDefs'; Try FFieldDefs := Value; Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; end; //Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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.
//