Unit Ads_Com;
{Copyright(c)2016 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
dickmaley@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 dickmaley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
{
Things to do:
1. Make a generic about box with title, bmp, and version info
}
(*UnitIndex Master Index Implementation Section Download UnitsDescription: ads_Com.pas This unit contains the following routines.
AboutBox_ads AddTables AppClose AppExecute AppHandle AppIsRunning AppLoad AppSwitchTo AppTerminate ButtonReSizer CD CenterChild CenterChildren_H CenterComponent CenterForm CenterFormHorizontally CenterFormVertically CompDimensions ConvertIntegerToBinaryString ConvertPCharToString ConvertStringToChar ConvertStringToInteger ConvertStringToPChar ConvertWordToBinaryString CopyDirectory CopyFile CopyFiles CreateTableFromQuery Date_DaysInMonth Date_FirstDayOfLastWeek Date_FirstDayOfNextMonth Date_FirstDayOfNextWeek Date_FirstDayOfWeek Date_LastDayOfMonth Date_Month Date_MonthNext Date_MonthPrior Date_MoveNDays Date_NextDay Date_NextWeek Date_PriorDay Date_PriorWeek DBAddQueryToTable DBAddTables DBCopyFieldAToB DBCopyTable DBCopyTableAToB DBCopyTableToServer DBCreateTableBorrowStr DBCreateTableFromQuery DBDeleteTable DBDropTable DBEmptyTable DBFieldNameByNo DBFieldNamesCommonToString DBFieldNamesCommonToTStrings DBFieldNamesToTStrings DBFieldNo DBFieldSize DBFieldType DBFieldTypeByNo DBGlobalStringFieldChange DBGlobalStringFieldChangeWhere DBGlobalStringFieldChangeWhere2 DBInsertMatchingFields DBKeyFieldNamesToTStrings DBLookUpDialog DBMedianSingle DBMoveTable DBNextAlphaKey DBNextInteger DBNFields DBParadoxCreateNKeys DBRecordMove DBReNameTable DBSchemaSame DBSessionCreateNew DBSqlValueQuoted DBSubtractTable DBTrimBlanksLeft DBTrimBlanksRight DBUpdateMatchingFields DeleteCharacterInString DeleteFiles DeleteLineBreaks DeleteSubStringInString DeleteSubStringInStringNoCase DeleteTable DelphiCheck DelphiChecker DelphiIsRunning DelTree DialogAboutBox_ads DialogDBLookUp DialogInputBoxOnlyAToZ DialogInputBoxOnlyNumbers DialogInputBoxOnlyNumbersAbsolute DialogLookup DialogLookupDetail Directory DirectoryCopy DirectoryHide DirectoryMove DirectoryUnHide DropTable EmptyDirectory EmptyTable ErrorMeaning ExecutableUpdate ExecuteExe ExecuteExeParams ExecuteKnownFileType ExtractFileExtNoPeriod ExtractFileNameNoExt FieldNo FieldSize FieldType FieldTypeFromDataSet File_CopyDirectory File_DeleteDirectory File_DelTree File_DirOperations_Detail File_GetCreationDate File_GetLastAccessDate File_GetLastModifiedDate File_GetLongFileName File_GetShortFileName File_KillDirectory File_MoveDirectory File_RemoveDirectory File_ReNameDirectory FileDate FileDatesSame FileExt FileMove FileName FileNextNumberName FileNotTextSize FilePath FilesInDirDetail FormCenterHorizontal FormCenterVertical FormDimensions GetCenterFormLeft GetCenterFormTop GridDeleteRow GridMoveRowToBottom ImageFadeAway ImageFadeIn ImageFadeInAndOut ImageFadeInAndOutDetail ImageFlipHoriz ImageFlipVert ImageFlutterHoriz ImageFlutterHorizDetail ImageFlutterVert ImageFlutterVertDetail ImagePulsate ImageRotateDetail IniGetIntegerValue IniGetStringValue IniSetIntegerValue IniSetStringValue IniUpdateFromTStringList IniUpdateTStringList InputBoxFilterDetail InputBoxOnlyAToZ InputBoxOnlyNumbers InputBoxOnlyNumbersAbsolute Internet_EmptyCacheDirectories Internet_GetURLsFromCachePages InternetCopyURLToFile InternetGetBaseURL InternetIsUrl IsDate IsDelphiRunning IsDir IsDirEmpty IsEmptyDataSource IsEmptyTable IsEmptyTable2 IsEmptyTQuery IsEmptyTTable IsField IsFieldKeyed IsFile IsRecord IsSchemaSame IsStructureSame IsTable IsTableKeyed KeyPressOnlyAToZ KeyPressOnlyLettersAbsolute KeyPressOnlyNumbers KeyPressOnlyNumbersAbsolute KeySend KillDirectory Len LettersOnlyAbsolute LookupDialog Lower Max MD Min Min_I MoveDirectory MoveTable Msg NFields NumbersOnly NumbersOnlyAbsolute NumVal PanelBevel Pi_Real ProgressScreenCursor Proper PurgeInternetCache Rand RandImage RandomInteger RD ReNameDir ReNameDirectory ReplaceCharacterInString ReplaceCharInString ReplaceSubStringInString ReplaceSubStringInStringNoCase ReSizeTuner ScaleForm SendKey SetChildWidths SetFileDate String_Grep_Contents String_Grep_Detail String_GrepAllToStringList String_LineFeed_Format String_LineFeed_Insert String_Replace String_Replace_NoCase String_Reverse StringPad SubStr SubtractTable TableAdd TableCreateFromQuery TableMove TableSubtract TEditKeyFilter.OnlyAToZ TEditKeyFilter.OnlyNumbers TEditKeyFilter.OnlyNumbersAbsolute TForm1.Button1Click TForm1.Button2Click TForm1.Button3Click TForm1.SpeedButton2Click TimeDeltaInMinutes TimeDeltaInMSeconds TimeDeltaInSeconds Today ToolBarButtonVisibleOne TPanel_Cmp_Sec_ads.ResizeShadowLabel TrimBlanksFromEnds TrimBlanksLeft TrimBlanksRight TypeField TypeFieldFromDataSet Upper UserIDFromWindows VersionInformation WinExecute WinExecute32
*)
Interface
Uses
SysUtils, StdCtrls, Dialogs, Forms, ExtCtrls,
Messages, WinProcs, WinTypes, Buttons, Classes,
DB, DBTables, Controls, Grids, IniFiles, Graphics,
ShellAPI, FileCtrl, wininet {$IFNDEF WIN32}, ToolHelp{$ENDIF};
Const RunOutsideIDE_ads = True;
Const RunOutsideIDEDate_ads = '12/1/98';
Const RunOutsideIDECompany_ads = 'Advanced Delphi Systems';
Const RunOutsideIDEPhone_ads = 'Please purchase at (301) 840-1554';
{!~ ABOUTBOX_ADS
This procedure presents an About Box.
TITLE The title is set by the AboutTitle parameter.
INFORMATION
The information displayed in the about box is pulled directly
from the executable. The programmer can configure this information
in Delphi by doing the following:
(1) in Delphi go to Project|Options|VersionInfo and make sure
that the check box for Include Version information in project
is checked.
(2)Auto-increment build number should also be checked so
that each time a build-all is run the version number is
automatically updated. This makes life simple and in automatic.
(3)Edit/Add items in the section at the bottom of this page
where key and value items are listed. Whatever you put in
this section is what will appear in the about box.
(2) Save the project and recompile
(3) The newly edited information will appear in the about box.
IMAGE
The Application Icon is presented as the image. To change the
image do the following:
(1) in Delphi go to Project|Options|Application|Load Icon
and select an Icon for the application
(2) Save the project and
recompile
(3) The newly selected Icon will appear in the about box.
SIZE
The About box size can be passed as the parameters AboutWidth
and AboutHeight. If however you wish to have the procedure
size the About Box automatically set these two parameters to
zero. }
Procedure AboutBox_ads(
AboutTitle : String;
AboutWidth : Integer;
AboutHeight : Integer
);
{!~ Add source table to destination table}
Function AddTables(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
{!~ Closes a Windows Application:
ExecutableName is usually the name of the executable
WinClassName can be found by inspecting the messaging
using WinSight that ships with Delphi}
procedure AppClose(ExecutableName,WinClassName : String);
{!~ Executes a Windows Application:
ExecutableName is usually the name of the executable
WinClassName can be found by inspecting the messaging
using WinSight that ships with Delphi
If the application is already running this function
brings it to the front}
procedure AppExecute(
ExecutableName : String;
WinClassName : String);
{!~ Returns the handle of a Windows Application}
function AppHandle(WinClassName : String): THandle;
{!~ Returns True if Application is running, False otherwise}
Function AppIsRunning(AppName: String): Boolean;
{!~ a subroutine of AppExecute}
Function AppLoad(const ExecutableName: string; show : word) : THandle;
{!~ a subroutine of AppExecute}
function AppSwitchTo(WinClassName : String): boolean;
{!~ A SubRoutine of AppClose}
Function AppTerminate(AppName: String): Boolean;
{!~ Handles button alignment}
procedure ButtonReSizer(
ButtonBase : TPanel;
ButtonSlider : TPanel;
ButtonWidth : Integer;
ButtonSpacer : Integer;
ButtonsReSize : Boolean;
ButtonsAlignment: TAlignment;
Beveled : Boolean);
{!~ Changes Directory}
Function CD(DirName: String): Boolean;
{!~ Centers a child component on a TPanel}
procedure CenterChild(Panel : TPanel);
{!~ Horizontally Centers all children of a TPanel }
procedure CenterChildren_H(Panel : TPanel);
{!~ Centers a Control Inside its Parent}
Procedure CenterComponent(ParentControl, ChildControl: TControl);
{!~ Centers A Form}
Procedure CenterForm(f : TForm);
{!~ Centers A Form Horizontally}
Procedure CenterFormHorizontally(f : TForm);
{!~ Centers A Form Vertically}
Procedure CenterFormVertically(f : TForm);
{!~ Sets The Dimensions Of A Component}
procedure CompDimensions(
Comp: TControl;
TopDim,
LeftDim,
HeightDim,
WidthDim: Integer);
{!~ Converts an integer value to its binary equivalent
as a ShortString }
Function ConvertIntegerToBinaryString(Int, Length : Integer) : ShortString;
{!~ Converts A PChar To String}
Function ConvertPCharToString(PCharValue: PChar): String;
{!~ Converts A String To Char}
Function ConvertStringToChar(InputString: String; CharPosition: Integer): Char;
{!~ Converts A String To Integer, If An Error Occurrs The Function Returns -0}
Function ConvertStringToInteger(StringValue: String): Integer;
{!~ Converts A String To A PChar, If An Error Occurrs The Function Returns 0}
Function ConvertStringToPChar(StringValue: String): PChar;
{!~ Converts a word value to its binary equivalent
as a ShortString }
Function ConvertWordToBinaryString(InputWord : Word; Length : Integer) : ShortString;
{!~ Copies a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise. If the destination directory already exists the process
fails and returns false.}
Function CopyDirectory(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
{!~ Copies A File}
Function CopyFile(FromFile,ToFile:String): Boolean;
{!~ Copy Files}
Function CopyFiles(FromPath,ToPath,FileMask: String): Boolean;
{!~ Creates a new table from a Query.
Complex joins can be output to a new table.}
Function CreateTableFromQuery(
Query: TQuery;
NewTableName,
TableDatabaseName: String): Boolean;
{!~ Returns The Number Of Days In The Month}
Function Date_DaysInMonth(DateValue: TDateTime): Integer;
{!~ Returns The First Day Of The Month}
Function Date_FirstDayOfNextMonth(DateValue: TDateTime): TDateTime;
{Returns The First Day Of the Week, i.e., Sunday, As A TDateTime. If an
error occurs then zero is returned.}
Function Date_FirstDayOfWeek(DateValue: TDateTime): TDateTime;
{Returns The First Day Of Last Week, i.e., Sunday, As A TDateTime. If an
error occurs then zero is returned.}
Function Date_FirstDayOfLastWeek(DateValue: TDateTime): TDateTime;
{Returns The First Day Of next Week, i.e., Sunday, As A TDateTime. If an
error occurs then zero is returned.}
Function Date_FirstDayOfNextWeek(DateValue: TDateTime): TDateTime;
{!~ Returns The Last Day Of The Month}
Function Date_LastDayOfMonth(DateValue: TDateTime): TDateTime;
{!~ Returns The Month}
Function Date_Month(DateValue: TDateTime): Integer;
{!~ Returns The Next Month}
Function Date_MonthNext(DateValue: TDateTime): Integer;
{!~ Returns The Prior Month}
Function Date_MonthPrior(DateValue: TDateTime): Integer;
{!~ Returns A Date N Days Different Than
The Input Date}
Function Date_MoveNDays(
DateValue : TDateTime;
DateMovement : Integer): TDateTime;
{!~ Returns The Next Day As A TDateTime}
Function Date_NextDay(DateValue: TDateTime): TDateTime;
{!~ Returns The Next Week As A TDateTime}
Function Date_NextWeek(DateValue: TDateTime): TDateTime;
{!~ Returns The Prior Day As A TDateTime}
Function Date_PriorDay(DateValue: TDateTime): TDateTime;
{!~ Returns The Prior Week As A TDateTime}
Function Date_PriorWeek(DateValue: TDateTime): TDateTime;
{!~ Add source query to destination table}
Procedure DBAddQueryToTable(
DataSet : TQuery;
const
DestDatabaseName,
DestinationTable: string);
{!~ Add source table to destination table}
Function DBAddTables(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
{!~ Copies Field A To Field B.}
function DBCopyFieldAToB(
DatabaseName,
TableName,
SourceField,
DestField: String): Boolean;
{!~ Copies SourceTable To DestTable.
If DestTable exists it is deleted}
Function DBCopyTable(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestTable: String): Boolean;
{!~ Copies Table A To Table B. If Table B exists it
is emptied}
Function DBCopyTableAToB(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestTable: String): Boolean;
{!~ Copies a table from the source to the destination.
If the destination table exists the function will not
throw an error, the existing table will be replaced with the new
table.}
Function DBCopyTableToServer(
SourceDatabaseName : String;
SourceTableName : String;
DestDatabaseName : String;
DestTableName : String): Boolean;
{!~ Creates an empty table with indices by borrowing the structure
of a source table. Source and destination can be remote or local
tables. If the destination table exists the function will not
throw an error, the existing table will be replaced with the new
table.}
Function DBCreateTableBorrowStr(
SourceDatabaseName : String;
SourceTableName : String;
DestDatabaseName : String;
DestTableName : String): Boolean;
{!~ Creates a new table from a Query.
Complex joins can be output to a new table.}
Function DBCreateTableFromQuery(
Query: TQuery;
NewTableName,
TableDatabaseName: String): Boolean;
{!~ Deletes A Table}
Function DBDeleteTable(const DatabaseName, TableName : string):Boolean;
{!~ Drops A Table}
Function DBDropTable(const DatabaseName, TableName : string):Boolean;
{!~ Empties a table of all records}
Function DBEmptyTable(
const DatabaseName,
TableName : string): Boolean;
{!~ Returns the field Name as a String. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason '' is returned.}
Function DBFieldNameByNo(
DatabaseName : String;
TableName : String;
FieldNo : Integer): String;
{!~ Copies Table Field Names to a TStrings object.
Returns the true if successful. If there
is an error, the DatabaseName doesn't exist, the table doesn't
exist or some other reason False is returned. }
Function DBFieldNamesToTStrings(
DatabaseName : String;
TableName : String;
Strings : TStrings): Boolean;
{!~ Returns Field Names shared by 2 tables as a string.
Fields are separated by commas with no trailing comma.}
Function DBFieldNamesCommonToString(
DatabaseName1 : String;
TableName1 : String;
DatabaseName2 : String;
TableName2 : String): String;
{!~ Copies Field Names shared by 2 tables to a TStrings object.
Returns true if successful. If there
is an error, the DatabaseName doesn't exist, the table doesn't
exist or some other reason False is returned. }
Function DBFieldNamesCommonToTStrings(
DatabaseName1 : String;
TableName1 : String;
DatabaseName2 : String;
TableName2 : String;
Strings : TStrings): Boolean;
{!~ Returns the field Number as an integer. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason -1 is returned.}
Function DBFieldNo(DatabaseName, TableName, FieldName: String): Integer;
{!~ Returns the database field Size as an integer. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason 0 is returned.}
Function DBFieldSize(DatabaseName, TableName, FieldName: String): Integer;
{!~ Returns the database field type as a string. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason a null string is returned.}
Function DBFieldType(DatabaseName, TableName, FieldName: String): String;
{!~ Returns the database field type as a string. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason a null string is returned.}
Function DBFieldTypeByNo(DatabaseName, TableName: String; FieldNo: Integer): String;
{!~ Replace all the values in a field that match a
condition value with a new value}
procedure DBGlobalStringFieldChange(
const DatabaseName,
TableName,
FieldName,
NewValue : string);
{!~ Replace all the values in a field with a new value}
procedure DBGlobalStringFieldChangeWhere(
const DatabaseName,
TableName,
FieldName,
CurrentValue,
NewValue : string);
{!~ Replace values in a field (NewValueField) with NewValue
based on a where condition in CurrentValueField with a value
of CurrentValue}
procedure DBGlobalStringFieldChangeWhere2(
const DatabaseName,
TableName,
NewValueField,
NewValue,
CurrentValueField,
CurrentValue: string);
{!~ Inserts matching fields in a destination table.
Source Table records are deleted if the record was inserted properly.
Records unsuccessfully inserted are retained and the problems recorded
in the ErrorField.}
Function DBInsertMatchingFields(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable,
ErrorField: string): Boolean;
{!~ Copies Table Key Field Names to a TStrings object.
Returns the true if successful. If there
is an error, the DatabaseName doesn't exist, the table doesn't
exist or some other reason False is returned. }
Function DBKeyFieldNamesToTStrings(
DatabaseName : String;
TableName : String;
Strings : TStrings): Boolean;
{!~ Presents a lookup Dialog to the user. The selected
value is returned if the user presses OK and the Default
value is returned if the user presses Cancel unless the
TStringList is nil in which case a blank string is returned}
Function DBLookUpDialog(
Const DataBaseName : String;
Const TableName : String;
Const FieldName : String;
Const SessionName : String;
Const DefaultValue : String;
const DialogCaption : string;
const InputPrompt : string;
const DialogWidth : Integer
): String;
{!~ Returns the median value for a column in a table
as type single}
Function DBMedianSingle(
const DatabaseName,
TableName,
FieldName,
WhereString
: string): Single;
{!~ Moves SourceTable From SourceDatabaseName
To DestDatabasename. If a table exists
with the same name at DestDatabaseName it
is overwritten.}
Function DBMoveTable(
SourceTable,
SourceDatabaseName,
DestDatabaseName: String): Boolean;
{!~ Returns the number of fields in a table}
Function DBNFields(DatabaseName, TableName: String): Integer;
{!~ Returns the next key value when the table keys are
numbers as strings, e.g., ' 12' key would return
' 13'}
Function DBNextAlphaKey(DatabaseName, TableName, FieldName: String):String;
{!~ Returns the next key value when the table keys are
integers, e.g., 12 key would return 13}
Function DBNextInteger(
DatabaseName,
TableName,
FieldName: String):LongInt;
{!~ ReKeys a Paradox Table to the first N fields}
Function DBParadoxCreateNKeys(
DatabaseName : String;
TableName : String;
NKeys : Integer): Boolean;
{!~ ReNames a table}
Function DBReNameTable(
DatabaseName,
TableNameOld,
TableNameNew: String): Boolean;
{!~ Applies BatchMode Types As Appropriate To
Source and Destination Tables}
Function DBRecordMove(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestTable: String;
BMode: TBatchMode): Boolean;
{!~ Returns True If The Tables Have Identical Structures, False Otherwise.
If 1 Local Table is involved then Indices are ignored!!!!!!}
Function DBSchemaSame(const
DatabaseName1,
Table1,
DatabaseName2,
Table2: string): Boolean;
{$IFDEF WIN32}
{!~ Returns a new TSession Object. Nil is returned if something
goes wrong.}
Function DBSessionCreateNew: TSession;
{$ENDIF}
{!~ Returns a value for use in a sql where clause with the
appropriate Quoting of the value based on its datatype. If
an error occurs the original string value is returned unchanged}
Function DBSqlValueQuoted(
const
DatabaseName,
TableName,
FieldName,
FieldValue: string): String;
{!~ Subtracts the records in the source
table from the destination table}
Function DBSubtractTable(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
{!~ Trims blank spaces from the Left of the string}
Function DBTrimBlanksLeft(
DatabaseName : String;
TableName : String;
FieldName : String): Boolean;
{!~ Trims blank spaces from the right of the string}
Function DBTrimBlanksRight(
DatabaseName : String;
TableName : String;
FieldName : String): Boolean;
{!~ Updates matching fields in a destination table.
Source Table records are deleted if the record was updated properly.
Records unsuccessfully updated are retained and the problems recorded
in the ErrorField.}
Function DBUpdateMatchingFields(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable,
ErrorField: string;
MsgPanel: TPanel;
FilePath: String): Boolean;
{!~ Deletes all occurances of a Character in a String}
Function DeleteCharacterInString(InputCharacter,InputString: String): String;
{!~ Deletes Files}
Function DeleteFiles(FilePath,FileMask: String): Boolean;
{!~ Deletes all LineFeed Carriage Returns}
Function DeleteLineBreaks(const S: string): string;
{!~ Deletes all occurances of specified substring in a String}
Function DeleteSubStringInString(substring,InputString: String): String;
{Deletes all occurances of specified substring in a String and is case
insensitive.}
Function DeleteSubStringInStringNoCase(substring,InputString: String): String;
{!~ Deletes A Table}
Function DeleteTable(const DatabaseName, TableName : string):Boolean;
{!~ Checks whether Delphi is Running and
issues a message if the user doesn't have
the right to use the component}
procedure DelphiCheck(CanRunOutSide: Boolean);
{!~ Checks whether Delphi is Running and
issues a message if the user doesn't have
the right to use the component}
procedure DelphiChecker(
CanRunOutSide : Boolean;
ComponentName : String;
OwnerName : String;
PurchaseMessage : String;
ActivateDate : String);
{!~ Returns True if delphi is running, False otherwise}
Function DelphiIsRunning: Boolean;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
Function DelTree(DirectoryName: String): Boolean;
{!~ DIALOGABOUTBOX_ADS
This procedure presents an About Box.
TITLE The title is set by the AboutTitle parameter.
INFORMATION
The information displayed in the about box is pulled directly
from the executable. The programmer can configure this information
in Delphi by doing the following:
(1) in Delphi go to Project|Options|VersionInfo and make sure
that the check box for Include Version information in project
is checked.
(2)Auto-increment build number should also be checked so
that each time a build-all is run the version number is
automatically updated. This makes life simple and in automatic.
(3)Edit/Add items in the section at the bottom of this page
where key and value items are listed. Whatever you put in
this section is what will appear in the about box.
(2) Save the project and recompile
(3) The newly edited information will appear in the about box.
IMAGE
The Application Icon is presented as the image. To change the
image do the following:
(1) in Delphi go to Project|Options|Application|Load Icon
and select an Icon for the application
(2) Save the project and
recompile
(3) The newly selected Icon will appear in the about box.
SIZE
The About box size can be pased as the parameters AboutWidth
and AboutHeight. If however you wish to have the procedure
size the About Box automatically set these two parameters to
zero. }
Procedure DialogAboutBox_ads(
AboutTitle : String;
AboutWidth : Integer;
AboutHeight : Integer
);
{!~ Presents a lookup Dialog to the user. The selected
value is returned if the user presses OK and the Default
value is returned if the user presses Cancel unless the
TStringList is nil in which case a blank string is returned}
Function DialogDBLookUp(
Const DataBaseName : String;
Const TableName : String;
Const FieldName : String;
Const SessionName : String;
Const DefaultValue : String;
const DialogCaption : string;
const InputPrompt : string;
const DialogWidth : Integer
): String;
{!~ Presents an input dialog that accepts a-z and A-Z only.
All other keys are thrown away except for the backspace key.
The result is returned as a string}
Function DialogInputBoxOnlyAToZ(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
{!~ Presents an input dialog that accepts 0-9,-,+,".".
All other keys are thrown away except for the backspace key.
The result is returned as a string}
Function DialogInputBoxOnlyNumbers(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
{!~ Presents an input dialog that accepts 0-9.
All other keys are thrown away except for the backspace key.
The result is returned as a string}
Function DialogInputBoxOnlyNumbersAbsolute(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
{!~ Presents a lookup Dialog to the user. The selected
value is returned if the user presses OK and the Default
value is returned if the user presses Cancel unless the
TStringList is nil in which case a blank string is returned}
Function DialogLookup(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string;
const Values : TStringList
): string;
{!~ Returns Current Working Directory}
Function Directory: String;
{!~ Copies a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise. If the destination directory already exists the process
fails and returns false.}
Function DirectoryCopy(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
{!~ Moves a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise.}
Function DirectoryMove(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
{!~ Drops A Table}
Function DropTable(const DatabaseName, TableName : string):Boolean;
{!~ Empties a directory of normal files.}
Function EmptyDirectory(Directory : String): Boolean;
{!~ Empties a table of all records}
Function EmptyTable(
const DatabaseName,
TableName : string): Boolean;
{!~ Returns the meaning of the given result code. Error codes are for
Delphi 1.0.}
Function ErrorMeaning (ResultCode: Integer): string;
{Triggers an Executable to update itself.
Don't worry about the handle parameter,
just pass HANDLE which is the applications
handle. This can be run in the Application's
Main Form Create method.}
Function ExecutableUpdate(
ExecutablePath : String;
ExecutableName : String;
InstallPath : String;
Handle : THandle): Boolean;
{!~Executes an executable with no parameters}
Function ExecuteExe(FileName : String): Boolean;
{!~Executes an executable with parameters}
Function ExecuteExeParams(
FileName : String;
ParamString : String;
DefaultDir : String): Boolean;
{!~ Loads a known file type using the appropriate
executable, e.g., WinWord for *.Doc, Paradox for *.db.}
Function ExecuteKnownFileType(
Handle : THandle;
FileName : String): Boolean;
{!~ Returns The File Extension Without The Path, Name Or Period}
Function ExtractFileExtNoPeriod(FileString: String): String;
{!~ Returns The File Name Without The Path, Extension Or Period}
Function ExtractFileNameNoExt(FileString: String): String;
{!~ Returns the field Number as an integer. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason 0 is returned.}
Function FieldNo(DatabaseName, TableName, FieldName: String): Integer;
{!~ Returns the database field Size as an integer. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason 0 is returned.}
Function FieldSize(DatabaseName, TableName, FieldName: String): Integer;
{!~ Returns the database field type as a string. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason a null string is returned.}
Function FieldType(DatabaseName, TableName, FieldName: String): String;
{!~ Returns the database field type as a string. If there
is an error a null string is returned.}
Function FieldTypeFromDataSet(DataSet: TDataSet; FieldName: String): String;
{!~ Returns The Files Date Time Stamp as TDateTime}
Function FileDate(FileString: String): TDateTime;
{!~ Returns True is the filoe dates are the same, False otherwise.}
Function FileDatesSame(FileString1,FileString2: String): Boolean;
{!~ Returns The File Extension Without The Path, Name Or Period}
Function FileExt(FileString: String): String;
{!~ Returns the next available file name number as a string
in the format 00000001}
Function FileNextNumberName(
Directory : String;
Mask : String
): String;
{!~ Hides a directory. Returns true if
successful and false otherwise}
Function DirectoryHide(Const FileString : String): Boolean;
{!~ Copies a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise. If the destination directory already exists the process
fails and returns false.}
Function File_CopyDirectory(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
Function File_DeleteDirectory(DirectoryName: String): Boolean;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
Function File_DelTree(DirectoryName: String): Boolean;
{!~ Moves a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise.}
Function File_DirOperations_Detail(
Action : String; //COPY, DELETE, MOVE, RENAME
RenameOnCollision : Boolean; //Renames if directory exists
NoConfirmation : Boolean; //Responds "Yes to All" to any dialogs
Silent : Boolean; //No progress dialog is shown
ShowProgress : Boolean; //displays progress dialog but no file names
FromDir : String; //From directory
ToDir : String //To directory
): Boolean;
{!~ Returns the Creation Date for a file.}
Function File_GetCreationDate(FileName : String): TDateTime;
{!~ Returns the Date a file was last accessed.}
Function File_GetLastAccessDate(FileName : String): TDateTime;
{!~ Returns the Date a file was last modified.}
Function File_GetLastModifiedDate(FileName : String): TDateTime;
{!~ Returns the Long File Name of a file.}
Function File_GetLongFileName(FileName : String): String;
{!~ Returns the Short File Name of a file.}
Function File_GetShortFileName(FileName : String): String;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
Function File_KillDirectory(DirectoryName: String): Boolean;
{!~ Moves a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise.}
Function File_MoveDirectory(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
Function File_RemoveDirectory(DirectoryName: String): Boolean;
{!~ ReNames a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
Function File_ReNameDirectory(
OldDirectoryName: String;
NewDirectoryName: String): Boolean;
{!~ Moves a File From Source To Destination}
Function FileMove(SourceFile, DestinationFile: String): Boolean;
{!~ Returns The File Name Without The Path, Extension Or Period}
Function FileName(FileString: String): String;
{!~ Returns The File Path Without The Name, Extension ,Period or trailing Backslash}
Function FilePath(FileString: String): String;
{!~ Returns The File size in bytes. Does not work on a text file.}
Function FileNotTextSize(FileString: String): LongInt;
{!~ Populates a TStrings FileList with the files meeting selected
file attribute criteria in a directory. The mask argument is a
standard DOS file argument like '*.*. The InclDotFiles argument
allows the user to exclude the system files "." and ".." by
setting the value to False. If the Intersection argument is set
to true then the result will reflect only those files that satisfy
all attribute criteria. If Intersection is set to false then the
result will be a union of files that meet any of the criteria.}
Function FilesInDirDetail(
FileList : TStrings;
Directory : String;
Mask : String;
Intersection: Boolean;
IsReadOnly : Boolean;
IsHidden : Boolean;
IsSystem : Boolean;
IsVolumeID : Boolean;
IsDirectory : Boolean;
IsArchive : Boolean;
IsNormal : Boolean;
InclDotFiles: Boolean): Boolean;
{!~ UnHides a directory. Returns true if
successful and false otherwise}
Function DirectoryUnHide(Const FileString : String): Boolean;
{!~ Returns The Left Property To Center A Form}
Function FormCenterHorizontal(FormWidth: Integer): Integer;
{!~ Returns The Top Property To Center A Form}
Function FormCenterVertical(FormHeight: Integer): Integer;
{!~ Sets The Dimensions Of A Form}
procedure FormDimensions(
Form: TForm;
TopDim,
LeftDim,
HeightDim,
WidthDim: Integer);
{!~ Returns the form's left value that will center the form horizontally}
Function GetCenterFormLeft(FormWidth : Integer): Integer;
{!~ Returns the form's Top value that will center the form vertically}
Function GetCenterFormTop(FormHeight : Integer): Integer;
{!~ Deletes a row in a TStringGrid}
procedure GridDeleteRow(RowNumber : Integer; Grid : TStringGrid);
{!~ Moves a row in a TStringGrid to the bottom of the grid}
procedure GridMoveRowToBottom(RowNumber : Integer; Grid : TStringGrid);
{!~ Causes an image to fade away.
Example code:
procedure TForm1.Button7Click(Sender: TObject);
begin
Timer1.OnTimer := Button7Click;
ImageFadeAway(
Image1,
Timer1,
False);
end;}
Procedure ImageFadeAway(
Image : TImage;
Timer : TTimer;
Transparent : Boolean);
{!~ Causes an image to fade in.
Example code:
procedure TForm1.Button6Click(Sender: TObject);
begin
Timer1.OnTimer := Button6Click;
ImageFadeIn(
Image1,
Timer1,
False);
end;}
Procedure ImageFadeIn(
Image : TImage;
Timer : TTimer;
Transparent : Boolean);
{!~ Causes an image to fade in and out.
Setting cycles to 0 makes it continuous.
Example code:
procedure TForm1.Button10Click(Sender: TObject);
begin
Timer1.OnTimer := Button10Click;
ImageFadeInAndOut(
Image1,
Timer1,
False,
0);
end;}
Procedure ImageFadeInAndOut(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Cycles : Integer);
{!~ Causes an image to flip horizontally.
Setting cycles to 0 makes it continuous.
Example code:
procedure TForm1.Button4Click(Sender: TObject);
begin
Timer1.OnTimer := Button4Click;
ImageFlipHoriz(
Image1,
Timer1,
False,
3,
3);
end;}
Procedure ImageFlipHoriz(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Const MinLeft : Integer;
Cycles : Integer);
{!~ Causes an image to flip vertically.
Setting cycles to 0 makes it continuous.
Example code:
procedure TForm1.Button5Click(Sender: TObject);
begin
Timer1.OnTimer := Button5Click;
ImageFlipVert(
Image1,
Timer1,
False,
3,
3);
end;}
Procedure ImageFlipVert(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Const MinTop : Integer;
Cycles : Integer);
{!~ Causes an image to flutter horizontally.
Setting cycles to 0 makes it continuous.
Example code:
procedure TForm1.Button9Click(Sender: TObject);
begin
Timer1.OnTimer := Button9Click;
ImageFlutterHoriz(
Image1,
Timer1,
False,
0);
end;}
Procedure ImageFlutterHoriz(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Cycles : Integer);
{!~ Causes an image to flutter vertically.
Example code:
procedure TForm1.Button8Click(Sender: TObject);
begin
Timer1.OnTimer := Button8Click;
ImageFlutterVert(
Image1,
Timer1,
False,
0);
end;}
Procedure ImageFlutterVert(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Cycles : Integer);
{!~ Causes an image to pulsate in and out.
Example code:
procedure TForm1.Button11Click(Sender: TObject);
begin
Timer1.OnTimer := Button11Click;
ImagePulsate(
Image1,
Timer1,
False,
0);
end;}
Procedure ImagePulsate(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Cycles : Integer);
{!~ Returns the ini value for a variable (IntegerName)
in the ini section (IniSection) of the ini file (TheIniFile).}
Function IniGetIntegerValue(
TheIniFile : String;
IniSection : String;
IntegerName : String;
DefaultInteger : Integer): Integer;
{!~ Returns the ini value for a variable (StringName)
in the ini section (IniSection) of the ini file (TheIniFile).}
Function IniGetStringValue(
TheIniFile : String;
IniSection : String;
StringName : String;
DefaultString : String): String;
{!~ Sets a variable (IntegerName) in the ini section (IniSection)
of the ini file (TheIniFile) with the value (IntegerValue).
If an exception is thrown the function returns False,
True otherwise.}
Function IniSetIntegerValue(
TheIniFile : String;
IniSection : String;
IntegerName : String;
IntegerValue : Integer): Boolean;
{!~ Sets a variable (StringName) in the ini section (IniSection)
of the ini file (TheIniFile) with the value (StringValue).
If an exception is thrown the function returns False,
True otherwise.}
Function IniSetStringValue(
TheIniFile : String;
IniSection : String;
StringName : String;
StringValue : String): Boolean;
{!~ Updates an ini file from a TStringList}
Procedure IniUpdateFromTStringList(
TheIniFile : String;
IniSection : String;
StringListName : String;
CountField : String;
StringList : TStringList);
{!~ Updates a TStringList from an ini file}
Procedure IniUpdateTStringList(
TheIniFile : String;
IniSection : String;
StringListName : String;
CountField : String;
StringList : TStringList);
{!~ Presents an input dialog that accepts a-z and A-Z only.
All other keys are thrown away except for the backspace key.
The result is returned as a string}
Function InputBoxOnlyAToZ(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
{!~ Presents an input dialog that accepts 0-9,-,+,".".
All other keys are thrown away except for the backspace key.
The result is returned as a string}
Function InputBoxOnlyNumbers(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
{!~ Presents an input dialog that accepts 0-9.
All other keys are thrown away except for the backspace key.
The result is returned as a string}
Function InputBoxOnlyNumbersAbsolute(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
{!~ Empties the Temporary Internet Files directory}
procedure Internet_EmptyCacheDirectories(
TemporaryInternetDirectory : String);
{!~ The purpose of this procedure is to extract URL information from
web pages stored in the Temporary Internet Files Directory.
The URL's gathered by this procedure are stored in a new HTML page given
by the OutputFile argument.
This procedure needs a working directory designated
by the WorkingDirectoryName argument. This working directory should
be for the exclusive use of this procedure because all files in the
directory are deleted at the beginning of the process.
The location of the Temporary Internet Files Directory is provided by
the TemporaryInternetDirectory argument.
A number of boolean options are provided in this procedure:
SortByLabels : Sort the Results by the Unit Description UnitIndex Master Index
procedure TPanel_Cmp_Sec_ads.ResizeShadowLabel(
Sender : TObject);
Var
PH, PW : Integer;
LH, LW : Integer;
begin
PH := TPanel(Sender).Height;
PW := TPanel(Sender).Width;
LH := TLabel(Controls[0]).Height;
LW := TLabel(Controls[0]).Width;
TLabel(Controls[0]).Top := ((PH-LH) div 2)-3;
TLabel(Controls[0]).Left := ((Pw-Lw) div 2)-3;
end;
Type
TEditKeyFilter = Class(TEdit)
Published
{!~ Throws away all keys except 0-9,-,+,.}
Procedure OnlyNumbers(Sender: TObject; var Key: Char);
{!~ Throws away all keys except 0-9}
Procedure OnlyNumbersAbsolute(Sender: TObject; var Key: Char);
{!~ Throws away all keys except a-z and A-Z}
Procedure OnlyAToZ(Sender: TObject; var Key: Char);
End;
{!~ Throws away all keys except 0-9,-,+,.}
//Unit Description UnitIndex Master Index
Procedure TEditKeyFilter.OnlyNumbers(Sender: TObject; var Key: Char);
Begin
KeyPressOnlyNumbers(Key);
End;
{!~ Throws away all keys except 0-9}
//Unit Description UnitIndex Master Index
Procedure TEditKeyFilter.OnlyNumbersAbsolute(Sender: TObject; var Key: Char);
Begin
KeyPressOnlyNumbersAbsolute(Key);
End;
{!~ Throws away all keys except a-z and A-Z}
//Unit Description UnitIndex Master Index
Procedure TEditKeyFilter.OnlyAToZ(Sender: TObject; var Key: Char);
Begin
KeyPressOnlyAToZ(Key);
End;
{Add source table to destination table}
//Unit Description UnitIndex Master Index
Function AddTables(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
Var
BMode : TBatchMode;
Begin
If IsTableKeyed(DestDatabaseName,DestinationTable) Then
Begin
If IsTableKeyed(SourceDatabaseName,SourceTable) Then
Begin
BMode := BatAppendUpdate;
End
Else
Begin
BMode := BatAppend;
End;
End
Else
Begin
BMode := BatAppend;
End;
Result := DBRecordMove(SourceDatabaseName,SourceTable,
DestDatabaseName,DestinationTable,BMode);
End;
{Closes a Windows Application:
ExecutableName is usually the name of the executable
WinClassName can be found by inspecting the messaging
using WinSight that ships with Delphi}
//Unit Description UnitIndex Master Index
procedure AppClose(ExecutableName,WinClassName : String);
{Var}{zzz}
{ Handle : THandle;}{zzz}
Begin
If AppIsRunning(WinClassName) Then
Begin
If AppTerminate(ExecutableName) Then Exit;;
End;
end;
{
This ButtonClick Closes Solitaire if it is open
//Unit Description UnitIndex Master Index
procedure TForm1.Button2Click(Sender: TObject);
begin
AppClose('Sol','Solitaire');
end;
}
{Executes a Windows Application:
ExecutableName is usually the name of the executable
WinClassName can be found by inspecting the messaging
using WinSight that ships with Delphi
If the application is already running this function
brings it to the front}
//Unit Description UnitIndex Master Index
procedure AppExecute(
ExecutableName : String;
WinClassName : String);
{Var}{zzz}
{ Handle : THandle;}{zzz}
Begin
If Not AppSwitchTo(WinClassName) Then
Begin
{Handle := }{zzz}AppLoad(ExecutableName,SW_SHOWNORMAL)
End;
End;
{
This ButtonClick activates Solitaire
//Unit Description UnitIndex Master Index
procedure TForm1.Button1Click(Sender: TObject);
begin
AppExecute('SOL.EXE','Sol');
end;
}
{Returns the handle of a Windows Application}
//Unit Description UnitIndex Master Index
function AppHandle(WinClassName : String): THandle;
Var
Handle : THandle;
WinClassNamePChar : array[0..32] of char;
Begin
StrPLCopy(WinClassNamePChar,WinClassName,32);
Handle := FindWindow(WinClassNamePChar,nil);
If Handle = 0 Then
Begin
Result := 0;
End
Else
Begin
Result := Handle;
End;
End;
{Returns True if Application is running, False otherwise}
//Unit Description UnitIndex Master Index
Function AppIsRunning(AppName: String): Boolean;
var WindHand : THandle;
wcnPChar : array[0..32] of char;
ClName : array[0..32] of char;
{$IFDEF WIN32}
WinClassNameShort : ShortString;
AppNameShort : ShortString;
{$ELSE}
WinClassNameShort : String;
AppNameShort : String;
{$ENDIF}
Begin
{$IFDEF WIN32}
WinClassNameShort := ''{ShortString(WinClassName)};
AppNameShort := ShortString(AppName);
StrPLCopy(wcnPChar,WinClassNameShort,Length(WinClassNameShort));
StrPLCopy(ClName,AppNameShort,Length(AppNameShort));
{$ELSE}
WinClassNameShort := ''{WinClassName};
AppNameShort := AppName;
StrPLCopy(wcnPChar,WinClassNameShort,Length(WinClassNameShort)+1);
StrPLCopy(ClName,AppNameShort,Length(AppNameShort)+1);
{$ENDIF}
WindHand := FindWindow(wcnPChar,ClName);
If WindHand = 0 Then
Begin
WindHand := FindWindow(nil,ClName);
If WindHand = 0 Then
Begin
WindHand := FindWindow(wcnPChar,nil);
If WindHand = 0 Then
Begin
Result := False;
End
Else
Begin
Result := True;
End;
End
Else
Begin
Result := True;
End;
End
Else
Begin
Result := True;
End;
End;
{
An Edit Field is Set to True or False
depending on whether Solitaire is running
//Unit Description UnitIndex Master Index
procedure TForm1.Button3Click(Sender: TObject);
begin
If AppIsRunning('Solitaire') Then
Edit1.Text := 'True'
Else
Edit1.Text := 'False';
end;
}
{a subroutine of AppExecute}
//Unit Description UnitIndex Master Index
Function AppLoad(const ExecutableName: string; show : word) : THandle;
Type
SHOWBLOCK = record
two : word;
cmdShow : word;
end;
SHOWBLOCK_PTR = ^SHOWBLOCK;
PARAMBLOCK = record
wEnvSeg : word;
cmdLine : PChar;
show : SHOWBLOCK_PTR;
reserved1 : word;
reserved2 : word;
End;
Var
showCmd : SHOWBLOCK;
appletBlock : PARAMBLOCK;
appletPChar : array [0..255] of char;
cmdLinePChar : array [0..1] of char;
Begin
With showCmd do begin
two := 2;
cmdShow := show;
End;
With appletBlock do begin
wEnvSeg := 0;
cmdLine := StrPLCopy(cmdLinePChar,'',1);
show := @showCmd;
reserved1 := 0;
reserved2 := 0;
End;
Result := LoadModule(
StrPLCopy(appletPChar,ExecutableName,255),
@appletBlock);
End;
{a subroutine of AppExecute}
//Unit Description UnitIndex Master Index
function AppSwitchTo(WinClassName : String): boolean;
Var
Handle : THandle;
WinClassNamePChar : array[0..32] of char;
Begin
StrPLCopy(WinClassNamePChar,WinClassName,32);
Handle := FindWindow(WinClassNamePChar,nil);
If Handle = 0 Then
Begin
Result := False;
End
Else
Begin
Result := True;
If IsIconic(Handle) Then
Begin
ShowWindow(Handle,SW_RESTORE);
End
Else
Begin
BringWindowToTop(GetLastActivePopup(Handle));
End;
End;
End;
{A SubRoutine of AppClose}
//Unit Description UnitIndex Master Index
Function AppTerminate(AppName: String): Boolean;
{$IFDEF WIN32}
{ CurName : String;}{zzz}
{ i : Integer;}{zzz}
{$ELSE}
Var
Task : TTaskEntry;
CurName : String;
i : Integer;
{$ENDIF}
Begin
Result := False;
If AppName <> '' Then
Begin
{$IFDEF WIN32}
{$ELSE}
Task.DwSize := SizeOf (TTaskEntry);
If TaskFirst(@task) Then
Begin
Repeat
CurName := '';
For i := 0 To SizeOf(Task.szModule) Do
Begin
If Task.szModule[i] = #0 Then
Begin
Break;
End
Else
Begin
CurName := CurName + Task.szModule[i];
End;
End;
If UpperCase(CurName) = UpperCase(AppName) Then
Begin
TerminateApp(task.hTask, NO_UAE_BOX);
Result := True;
Exit;
end;
Until not TaskNext(@task);
End;
{$ENDIF}
End;
end;
{Handles button alignment}
//Unit Description UnitIndex Master Index
procedure ButtonReSizer(
ButtonBase : TPanel;
ButtonSlider : TPanel;
ButtonWidth : Integer;
ButtonSpacer : Integer;
ButtonsReSize : Boolean;
ButtonsAlignment: TAlignment;
Beveled : Boolean);
Var
MinFormWidth : Integer;
NButtons : Integer;
i : Integer;
NSpacers : Integer;
SpacerWidth : Integer;
SpacersWidth : Integer;
W : Integer;
LeftPos : Integer;
Begin
NButtons := ButtonSlider.ControlCount;
If ButtonSpacer > 0 Then
Begin
SpacerWidth := ButtonSpacer;
NSpacers := NButtons +1;
SpacersWidth := ButtonSpacer * NSpacers;
{LeftPos := SpacerWidth;}{zzz}
End
Else
Begin
SpacerWidth := 0;
{NSpacers := 0;}{zzz}
SpacersWidth:= 0;
{LeftPos := 0;}{zzz}
End;
MinFormWidth :=
SpacersWidth +
(NButtons * ButtonWidth) +
(ButtonBase.BorderWidth * 2) +
(ButtonBase.BevelWidth * 4) +
25;
Try
If ButtonBase.Parent is TForm Then
Begin
If ButtonBase.Parent.Width < MinFormWidth Then
Begin
ButtonBase.Parent.Width := MinFormWidth;
End;
End
Else
Begin
Try
If ButtonBase.Parent.Parent is TForm Then
Begin
If ButtonBase.Parent.Parent.Width < MinFormWidth Then
Begin
ButtonBase.Parent.Parent.Width := MinFormWidth;
End;
End
Else
Begin
Try
If ButtonBase.Parent.Parent.Parent is TForm Then
Begin
If ButtonBase.Parent.Parent.Parent.Width < MinFormWidth Then
Begin
ButtonBase.Parent.Parent.Parent.Width := MinFormWidth;
End;
End
Else
Begin
Try
If ButtonBase.Parent.Parent.Parent.Parent is TForm Then
Begin
If ButtonBase.Parent.Parent.Parent.Parent.Width < MinFormWidth Then
Begin
ButtonBase.Parent.Parent.Parent.Parent.Width := MinFormWidth;
End;
End
Else
Begin
{Not going to set a minimum form width}
End;
Except
End;
End;
Except
End;
End;
Except
End;
End;
Except
End;
If Beveled Then
Begin
ButtonBase.Height :=
(ButtonBase.BorderWidth * 2) +
(ButtonBase.BevelWidth * 4) +
2 {for borderStyle} +
25 {for standard button height} +
3;
End
else
Begin
ButtonBase.Height :=
(ButtonBase.BorderWidth * 2) +
25 {for standard button height} +
4;
End;
If ButtonsReSize Then
Begin
Buttonslider.Align := alClient;
W := (Buttonslider.Width - SpacersWidth) div NButtons;
LeftPos := SpacerWidth;
For i := 0 To NButtons - 1 Do
Begin
ButtonSlider.Controls[i].Align := alNone;
ButtonSlider.Controls[i].Top := 0;
ButtonSlider.Controls[i].Height := 25;
ButtonSlider.Controls[i].Width := W;
ButtonSlider.Controls[i].Left := LeftPos;
LeftPos := LeftPos + W + SpacerWidth;
End;
End
Else
Begin
ButtonSlider.Align := alNone;
If Beveled Then
Begin
ButtonSlider.Top :=
ButtonBase.BorderWidth +
(ButtonBase.BevelWidth * 2)+
1 + {For BorderStyle}
0; {For Margin}
End
Else
Begin
ButtonSlider.Top :=
ButtonBase.BorderWidth +
1; {For Margin}
End;
ButtonSlider.Height := 25;
ButtonSlider.Width :=
SpacersWidth +
(NButtons * ButtonWidth);
If (Not Beveled) Then
Begin
{Align totally left with not leftmost spacer}
If ButtonsAlignment = taLeftJustify Then
Begin
LeftPos := 0;
End
Else
Begin
If ButtonsAlignment = taRightJustify Then
Begin
{Align totally Right with not rightmost spacer}
LeftPos := 2 * SpacerWidth;
End
Else
Begin
LeftPos := SpacerWidth;
End;
End;
End
Else
Begin
LeftPos := SpacerWidth;
End;
For i := 0 To NButtons - 1 Do
Begin
ButtonSlider.Controls[i].Align := alNone;
ButtonSlider.Controls[i].Top := 0;
ButtonSlider.Controls[i].Height := 25;
ButtonSlider.Controls[i].Width := ButtonWidth;
ButtonSlider.Controls[i].Left := LeftPos;
LeftPos := LeftPos + ButtonWidth+ SpacerWidth;
End;
If ButtonsAlignment = taLeftJustify Then ButtonSlider.Align := alLeft;
If ButtonsAlignment = taRightJustify Then ButtonSlider.Align := alRight;
If ButtonsAlignment = taCenter Then
Begin
ButtonSlider.Align := alNone;
ButtonSlider.Left :=
(ButtonBase.Width -
ButtonSlider.Width) div 2;
End;
End;
ButtonBase.Refresh;
End;
{Changes Directory}
//Unit Description UnitIndex Master Index
Function CD(DirName: String): Boolean;
Begin
If Not IsDir(DirName) Then
Begin
Result := False;
End
Else
Begin
ChDir(DirName);
If IOResult <> 0 Then
Begin
Result := False;
End
Else
Begin
Result := True;
End;
End;
End;
{Centers a child component on a TPanel}
//Unit Description UnitIndex Master Index
procedure CenterChild(Panel : TPanel);
Begin
Panel.Controls[0].Left :=
(Panel.Width - Panel.Controls[0].Width) div 2;
Panel.Controls[0].Top :=
(Panel.Height - Panel.Controls[0].Height) div 2;
End;
{Horizontally Centers all children of a TPanel }
//Unit Description UnitIndex Master Index
procedure CenterChildren_H(Panel : TPanel);
Var
i : Integer;
Begin
For i := 0 To Panel.ControlCount - 1 Do
Begin
Panel.Controls[i].Left :=
(Panel.Width - Panel.Controls[i].Width) div 2;
End;
End;
{Centers a Control Inside its Parent}
//Unit Description UnitIndex Master Index
Procedure CenterComponent(ParentControl, ChildControl: TControl);
Var
ChildControlTop,ChildControlLeft: Integer;
Begin
ChildControlTop := (ParentControl.Height-ChildControl.Height) div 2;
ChildControlLeft := (ParentControl.Width -ChildControl.Width) div 2;
If ChildControlTop < 0 Then
Begin
ChildControl.Top := 0;
End
Else
Begin
ChildControl.Top := ChildControlTop;
End;
If ChildControlLeft < 0 Then
Begin
ChildControl.Left := 0;
End
Else
Begin
ChildControl.Left := ChildControlLeft;
End;
End;
{Centers A Form}
//Unit Description UnitIndex Master Index
Procedure CenterForm(f : TForm);
Begin
f.left := (Screen.width - f.width) div 2;
f.top := (Screen.height - f.height) div 2;
End;
{Centers A Form Horizontally}
//Unit Description UnitIndex Master Index
Procedure CenterFormHorizontally(f : TForm);
Begin
f.left := (Screen.width - f.width) div 2;
End;
{Centers A Form Vertically}
//Unit Description UnitIndex Master Index
Procedure CenterFormVertically(f : TForm);
Begin
f.top := (Screen.height - f.height) div 2;
End;
{Sets The Dimensions Of A Component}
//Unit Description UnitIndex Master Index
procedure CompDimensions(
Comp: TControl;
TopDim,
LeftDim,
HeightDim,
WidthDim: Integer);
Begin
With Comp Do
Begin
Left := LeftDim;
Top := TopDim;
Height := HeightDim;
Width := WidthDim;
End;
End;
{Converts A PChar To String}
//Unit Description UnitIndex Master Index
Function ConvertPCharToString(PCharValue: PChar): String;
Begin
Result := StrPas(PCharValue);
End;
{Converts A String To Char}
//Unit Description UnitIndex Master Index
Function ConvertStringToChar(InputString: String; CharPosition: Integer): Char;
Begin
Result := InputString[CharPosition];
End;
{Converts A String To Integer, If An Error Occurrs The Function Returns -0}
//Unit Description UnitIndex Master Index
Function ConvertStringToInteger(StringValue: String): Integer;
Var
I, Code: Integer;
Begin
VAL(StringValue, I, Code);
{Was There An Error}
If Not (Code=0) Then
Begin
{An Error Occurred}
Result := 0;
End
Else
Begin
{Conversion Ran Properly}
Result := I;
End;
End;
{Converts A String To A PChar, If An Error Occurrs The Function Returns 0}
//Unit Description UnitIndex Master Index
Function ConvertStringToPChar(StringValue: String): PChar;
Var
PCharString: Array[0..255] of Char;
Begin
Result := StrPCopy(PCharString,StringValue);
End;
{Copies A File}
//Unit Description UnitIndex Master Index
Function CopyFile(FromFile,ToFile:String): Boolean;
Var
FromF, ToF: file;
{$IFDEF WIN32}
NumRead, NumWritten: Integer;
{$ELSE}
NumRead, NumWritten: Word;
{$ENDIF}
Buf: array[1..2048] of Char;
Begin
If IsDir(FromFile) Then
Begin
{MessageDlg('Problem! There Was A Problem Copying '+FromFile,
mtWarning, [mbOk], 0);}
Result := False;
End
Else
Begin
AssignFile(FromF, FromFile);
AssignFile(ToF, ToFile);
{ Result := False;}{zzz}
Try
FileMode := 0; {Sets Reset To ReadOnly}
Reset(FromF, 1);{ Record size = 1 }
FileMode := 2; {Sets Reset To ReadWrite}
Rewrite(ToF, 1);{ Record size = 1 }
repeat
BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
BlockWrite(ToF, Buf, NumRead, NumWritten);
until (NumRead = 0) or (NumWritten <> NumRead);
System.CloseFile(FromF);
System.CloseFile(ToF);
Result := True;
Except
On EInOutError Do
Begin
Result := False;
End;
Else Result := False;
End;
If Result = False Then
MessageDlg('Problem! There Was A Problem Copying '+FromFile,
mtWarning, [mbOk], 0);
End;
End;
{Copy Files}
//Unit Description UnitIndex Master Index
Function CopyFiles(FromPath,ToPath,FileMask: String): Boolean;
var
CopyFilesSearchRec: TSearchRec;
FindFirstReturn: Integer;
Begin
Result := False;
FindFirstReturn :=
FindFirst(FromPath+'\'+FileMask, faAnyFile, CopyFilesSearchRec);
If Not (CopyFilesSearchRec.Name = '') And
Not (FindFirstReturn = -18) Then
Begin
Result := True;
CopyFile(FromPath+'\'+CopyFilesSearchRec.Name,ToPath+'\'+CopyFilesSearchRec.Name);
While True Do
Begin
If FindNext(CopyFilesSearchRec)<0 Then
Begin
Break;
End
Else
Begin
CopyFile(FromPath+'\'+CopyFilesSearchRec.Name,ToPath+'\'+CopyFilesSearchRec.Name);
End;
End;
End;
End;
{Creates a new table from a Query.
Complex joins can be output to a new table.}
//Unit Description UnitIndex Master Index
Function CreateTableFromQuery(
Query: TQuery;
NewTableName,
TableDatabaseName: String): Boolean;
Begin
Result := DBCreateTableFromQuery(Query,NewTableName,TableDatabaseName);
End;
{Add source query to destination table}
//Unit Description UnitIndex Master Index
Procedure DBAddQueryToTable(
DataSet : TQuery;
const
DestDatabaseName,
DestinationTable: string);
var
DTable : TTable;
BMove : TBatchMove;
begin
DTable := TTable.Create(nil);
BMove := TBatchMove.Create(nil);
Try
DataSet.Active := True;
DTable.DatabaseName := DestDatabaseName;
DTable.TableName := DestinationTable;
DTable.Active := True;
BMove.AbortOnKeyViol := False;
BMove.AbortOnProblem := False;
BMove.ChangedTableName := 'CTable';
BMove.Destination := DTable;
BMove.KeyViolTableName := 'KTable';
BMove.Mode := batAppend;
BMove.ProblemTableName := 'PTable';
BMove.Source := DataSet;
BMove.Execute;
Finally
DTable.Active := False;
DTable.Free;
BMove.Free;
End;
End;
{Add source table to destination table}
//Unit Description UnitIndex Master Index
Function DBAddTables(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
begin
Result := AddTables(SourceDatabaseName,SourceTable,
DestDatabaseName,DestinationTable);
End;
{Copies Field A To Field B.}
//Unit Description UnitIndex Master Index
function DBCopyFieldAToB(
DatabaseName,
TableName,
SourceField,
DestField: String): Boolean;
var
Query : TQuery;
CursorWas : TCursor;
Sess : TSession;
begin
CursorWas := Screen.Cursor;
Sess := DBSessionCreateNew;
Sess.Active := True;
Query := TQuery.Create(sess);
Query.SessionName := Sess.SessionName;
Sess.Active := True;
Query.Active := False;
Query.RequestLive := True;
try
Result := False;
Query.DatabaseName := DatabaseName;
Query.SQL.Clear;
Query.SQL.Add('Select ');
Query.SQL.Add(SourceField+',');
Query.SQL.Add(DestField);
Query.SQL.Add('From '+TableName);
Query.Open;
Query.First;
While Not Query.EOF Do
Begin
ProgressScreenCursor;
Try
Query.Edit;
Query.FieldByName(DestField).AsString :=
Query.FieldByName(SourceField).AsString;
Query.Post;
Except
End;
Query.Next;
End;
Result := True;
finally
Query.Free;
Screen.Cursor := CursorWas;
Sess.Active := False;
end;
end;
{Copies SourceTable To DestTable.
If DestTable exists it is deleted}
//Unit Description UnitIndex Master Index
Function DBCopyTable(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestTable: String): Boolean;
Begin
Result := DBRecordMove(SourceDatabaseName,SourceTable,
DestDatabaseName,DestTable,batCopy);
End;
{Copies Table A To Table B. If Table B exists it
is emptied}
//Unit Description UnitIndex Master Index
Function DBCopyTableAToB(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestTable: String): Boolean;
begin
Result :=
DBCopyTable(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestTable);
End;
{Creates a new table from a Query.
Complex joins can be output to a new table.}
//Unit Description UnitIndex Master Index
Function DBCreateTableFromQuery(
Query: TQuery;
NewTableName,
TableDatabaseName: String): Boolean;
var
D : TTable;
ActiveWas : Boolean;
begin
D := nil;
{ Result := False;}{zzz}
try
{The Source Table}
ActiveWas := Query.Active;
Query.Active := true;
{Create The Destination Table}
D := TTable.Create(nil);
D.Active := False;
D.DatabaseName := TableDatabaseName;
D.TableName := NewTableName;
D.ReadOnly := False;
{Make the table copy}
D.BatchMove(Query,batCopy);
Query.Active := ActiveWas;
Result := True;
finally
D.Free;
end;
End;
{Deletes A Table}
//Unit Description UnitIndex Master Index
Function DBDeleteTable(const DatabaseName, TableName : string):Boolean;
Begin
{ Result := False;}{zzz}
Try
If Not IsTable(DatabaseName, TableName) Then
Begin
Result := False;
Exit;
End;
Result := DBDropTable(DatabaseName, TableName);
Except
Result := False;
End;
End;
{Drops A Table}
//Unit Description UnitIndex Master Index
Function DBDropTable(const DatabaseName, TableName : string):Boolean;
var Query : TQuery;
begin
Result := False;
If Not IsTable(DatabaseName, TableName) Then
Begin
Exit;
End;
Query := TQuery.Create(nil);
try
Query.DatabaseName := DatabaseName;
Query.SQL.Clear;
Query.SQL.Add('Drop Table ');
If (Pos('.DB', UpperCase(TableName)) > 0) Or
(Pos('.DBF',UpperCase(TableName)) > 0) Then
Begin
Query.Sql.Add('"'+TableName+'"');
End
Else
Begin
Query.Sql.Add(TableName);
End;
Result := True;
Try
Query.ExecSQL;
Except
Result := False;
End;
finally
Query.Free;
end;
end;
{Empties a table of all records}
//Unit Description UnitIndex Master Index
Function DBEmptyTable(
const DatabaseName,
TableName : string): Boolean;
var Query : TQuery;
begin
{ Result := False;}{zzz}
Query := TQuery.Create(nil);
try
Query.DatabaseName := DatabaseName;
Query.SQL.Clear;
Query.SQL.Add('DELETE FROM '+TableName);
Query.ExecSQL;
Result := True;
finally
Query.Free;
end;
end;
{Returns the field Number as an integer. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason -1 is returned.}
//Unit Description UnitIndex Master Index
Function DBFieldNo(DatabaseName, TableName, FieldName: String): Integer;
Var
Table : TTable;
FieldIndex : Integer;
FieldNumber: Integer;
Begin
Result := -1;
If Not IsTable(DatabaseName, TableName) Then Exit;
If Not IsField(DatabaseName, TableName, FieldName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
FieldIndex :=
Table.FieldDefs.IndexOf(FieldName);
FieldNumber :=
Table.FieldDefs[FieldIndex].FieldNo;
Result := FieldNumber;
Except
End;
Finally
Table.Free;
End;
End;
{Returns the database field Size as an integer. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason 0 is returned.}
//Unit Description UnitIndex Master Index
Function DBFieldSize(DatabaseName, TableName, FieldName: String): Integer;
Var
Table : TTable;
FieldIndex : Integer;
FieldSize : Integer;
Begin
Result := 0;
If Not IsTable(DatabaseName, TableName) Then Exit;
If Not IsField(DatabaseName, TableName, FieldName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
FieldIndex :=
Table.FieldDefs.IndexOf(FieldName);
FieldSize :=
Table.FieldDefs[FieldIndex].Size;
Result := FieldSize;
Except
End;
Finally
Table.Free;
End;
End;
{Returns the database field type as a string. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason a null string is returned.}
//Unit Description UnitIndex Master Index
Function DBFieldType(DatabaseName, TableName, FieldName: String): String;
Begin
Result := TypeField(DatabaseName, TableName, FieldName);
End;
{Returns the database field type as a string. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason a null string is returned.}
//Unit Description UnitIndex Master Index
Function DBFieldTypeByNo(DatabaseName, TableName: String; FieldNo: Integer): String;
Var
Table : TTable;
FieldIndex : Integer;
FieldType : TFieldType;
Begin
Result := '';
If Not IsTable(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
FieldIndex := FieldNo;
Try
FieldType :=
Table.FieldDefs[FieldIndex].DataType;
Except
FieldType := ftUnknown;
End;
{TFieldType Possible values are
ftUnknown, ftString, ftSmallint,
ftInteger, ftWord, ftBoolean,
ftFloat, ftCurrency, ftBCD, ftDate,
ftTime, ftDateTime, ftBytes, ftVarBytes,
ftBlob, ftMemo or ftGraphic}
If FieldType=ftUnknown Then Result := 'Unknown';
If FieldType=ftString Then Result := 'String';
If FieldType=ftSmallInt Then Result := 'SmallInt';
If FieldType=ftInteger Then Result := 'Integer';
If FieldType=ftWord Then Result := 'Word';
If FieldType=ftBoolean Then Result := 'Boolean';
If FieldType=ftFloat Then Result := 'Float';
If FieldType=ftCurrency Then Result := 'Currency';
If FieldType=ftBCD Then Result := 'BCD';
If FieldType=ftDate Then Result := 'Date';
If FieldType=ftTime Then Result := 'Time';
If FieldType=ftDateTime Then Result := 'DateTime';
If FieldType=ftBytes Then Result := 'Bytes';
If FieldType=ftVarBytes Then Result := 'VarBytes';
If FieldType=ftBlob Then Result := 'Blob';
If FieldType=ftMemo Then Result := 'Memo';
If FieldType=ftGraphic Then Result := 'Graphic';
Except
End;
Finally
Table.Free;
End;
End;
{Replace all the values in a field that match a
condition value with a new value}
//Unit Description UnitIndex Master Index
procedure DBGlobalStringFieldChange(
const DatabaseName,
TableName,
FieldName,
NewValue : string);
begin
DBGlobalStringFieldChangeWhere(
DatabaseName,
TableName,
FieldName,
'',
NewValue);
End;
{Replace all the values in a field with a new value}
//Unit Description UnitIndex Master Index
procedure DBGlobalStringFieldChangeWhere(
const DatabaseName,
TableName,
FieldName,
CurrentValue,
NewValue : string);
var
Query : TQuery;
begin
Query := TQuery.Create(nil);
Try
Query.Active := False;
Query.DatabaseName := DatabaseName;
Query.RequestLive := True;
Query.RequestLive := True;
Query.Sql.Clear;
Query.Sql.Add('UpDate');
Query.Sql.Add('"'+TableName+'"');
Query.Sql.Add('Set');
Query.Sql.Add(
'"'+TableName+'"."'+FieldName+'"'+
' = '+
'"'+NewValue+'"');
Query.Sql.Add('Where');
Query.Sql.Add(
'"'+TableName+'"."'+FieldName+'"'+
' <> '+
'"'+NewValue+'"');
If Not (CurrentValue = '') Then
Begin
Query.Sql.Add('And ');
Query.Sql.Add(
'"'+TableName+'"."'+FieldName+'"'+
' = '+
'"'+CurrentValue+'"');
End;
Query.ExecSql;
Query.Active := False;
Finally
Query.Free;
End;
End;
{Returns the median value for a column in a table
as type single}
//Unit Description UnitIndex Master Index
Function DBMedianSingle(
const DatabaseName,
TableName,
FieldName,
WhereString
: string): Single;
Var
Query : TQuery;
NRecords : LongInt;
NMedian : LongInt;
Value1 : Single;
Value2 : Single;
Begin
Query := TQuery.Create(nil);
{ Result := 0;}{zzz}
Try
{Get the number of values}
Query.Active := False;
Query.DatabaseName := DatabaseName;
Query.SQL.Clear;
Query.SQL.Add('Select Count(*)');
Query.SQL.Add('From');
If (Pos('.DB', UpperCase(TableName)) > 0) Or
(Pos('.DBF',UpperCase(TableName)) > 0) Then
Begin
Query.Sql.Add('"'+TableName+'"');
End
Else
Begin
Query.Sql.Add(TableName);
End;
Query.SQL.Add('Where');
Query.SQL.Add(FieldName+' is not null');
If Not (WhereString = '') Then
Begin
Query.SQL.Add('And');
Query.SQL.Add(WhereString);
End;
Query.Active := True;
NRecords := Query.Fields[0].AsInteger;
NMedian := NRecords div 2;
{Get the median value}
Query.Active := False;
Query.DatabaseName := DatabaseName;
Query.SQL.Clear;
Query.SQL.Add('Select');
Query.SQL.Add(FieldName);
Query.SQL.Add('From');
If (Pos('.DB', UpperCase(TableName)) > 0) Or
(Pos('.DBF',UpperCase(TableName)) > 0) Then
Begin
Query.Sql.Add('"'+TableName+'"');
End
Else
Begin
Query.Sql.Add(TableName);
End;
Query.SQL.Add('Where');
Query.SQL.Add(FieldName+' is not null');
If Not (WhereString = '') Then
Begin
Query.SQL.Add('And');
Query.SQL.Add(WhereString);
End;
Query.SQL.Add('Order By');
Query.SQL.Add(FieldName);
Query.Active := True;
Query.First;
If Odd(NRecords) Then
Begin
{Odd Number of records}
Query.MoveBy(NMedian);
Result := Query.FieldByName(FieldName).AsFloat;
End
Else
Begin
{Even Number of records}
Query.MoveBy(NMedian-1);
Value1 := Query.FieldByName(FieldName).AsFloat;
Query.Next;
Value2 := Query.FieldByName(FieldName).AsFloat;
Result := (Value1+Value2)/2;
End;
Finally
Query.Free;
End;
End;
{Moves SourceTable From SourceDatabaseName
To DestDatabasename. If a table exists
with the same name at DestDatabaseName it
is overwritten.}
//Unit Description UnitIndex Master Index
Function DBMoveTable(
SourceTable,
SourceDatabaseName,
DestDatabaseName: String): Boolean;
Begin
Result := True;
Try
{First Copy The Source Table To The New Table}
If Not DBCopyTable(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
SourceTable) Then
Begin
Result := False;
Exit;
End;
{Now Drop The Source Table}
If Not DBDropTable(SourceDatabaseName, SourceTable) Then
Begin
Result := False;
Exit;
End;
Except
Result := False;
End;
End;
{Returns the number of fields in a table}
//Unit Description UnitIndex Master Index
Function DBNFields(DatabaseName, TableName: String): Integer;
Begin
Result := NFields(DatabaseName, TableName);
End;
{Returns the next key value when the table keys are
numbers as strings, e.g., ' 12' key would return
' 13'}
//Unit Description UnitIndex Master Index
Function DBNextAlphaKey(DatabaseName, TableName, FieldName: String):String;
Var
Query : TQuery;
CurrentMax_S : String;
CurrentLen_I : Integer;
CurrentMax_I : LongInt;
NewMax_S : String;
NewMax_I : LongInt;
Counter : Integer;
Begin
Result := '';
Query := TQuery.Create(nil);
Try
Result := '1';
CurrentMax_S := '';
CurrentMax_I := 0;
CurrentLen_I := 0;
NewMax_S := '1';
{NewMax_I := 1;}{zzz}
Query.DatabaseName := DatabaseName;
Query.SQL.Clear;
Query.SQL.Add('Select ');
Query.SQL.Add('Max('+FieldName+')');
Query.SQL.Add('From '+TableName);
Query.Open;
Try
CurrentMax_S := Query.Fields[0].AsString;
Except
End;
Try
CurrentLen_I := Length(CurrentMax_S);
Except
End;
Try
CurrentMax_I := StrToInt(CurrentMax_S);
Except
End;
NewMax_I := CurrentMax_I + 1;
NewMax_S := IntToStr(NewMax_I);
For Counter := 1 To CurrentLen_I Do
Begin
If Length(NewMax_S) >= CurrentLen_I Then Break;
NewMax_S := ' '+NewMax_S;
End;
Result := NewMax_S;
Finally
Query.Free;
End;
End;
{Returns the next key value when the table keys are
integers, e.g., 12 key would return 13}
//Unit Description UnitIndex Master Index
Function DBNextInteger(
DatabaseName,
TableName,
FieldName: String):LongInt;
Var
Query : TQuery;
CurrentMax : LongInt;
NewMax : LongInt;
Begin
{ Result := 1;}{zzz}
CurrentMax := 0;
{NewMax := 1;}{zzz}
Query := TQuery.Create(nil);
Try
Query.DatabaseName := DatabaseName;
Query.SQL.Clear;
Query.SQL.Add('Select ');
Query.SQL.Add('Max('+FieldName+')');
Query.SQL.Add('From ');
If (Pos('.DB', UpperCase(TableName)) > 0) Or
(Pos('.DBF',UpperCase(TableName)) > 0) Then
Begin
Query.Sql.Add('"'+TableName+'"');
End
Else
Begin
Query.Sql.Add(TableName);
End;
Query.Open;
Try
CurrentMax := Query.Fields[0].AsInteger;
Except
End;
NewMax := CurrentMax + 1;
Result := NewMax;
Finally
Query.Free;
End;
End;
{ReNames a table}
//Unit Description UnitIndex Master Index
Function DBReNameTable(
DatabaseName,
TableNameOld,
TableNameNew: String): Boolean;
Begin
Result := True;
Try
If Not IsTable(DatabaseName, TableNameOld) Then
Begin
Result := False;
Exit;
End;
{First Copy The Source Table To The New Table}
If Not DBCopyTable(
DatabaseName,
TableNameOld,
DatabaseName,
TableNameNew) Then
Begin
Result := False;
Exit;
End;
{Now Drop The Source Table}
If Not DBDropTable(DatabaseName, TableNameOld) Then
Begin
Result := False;
Exit;
End;
Except
Result := False;
End;
End;
{Applies BatchMode Types As Appropriate To
Source and Destination Tables}
//Unit Description UnitIndex Master Index
Function DBRecordMove(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestTable: String;
BMode: TBatchMode): Boolean;
var S : TTable;
D : TTable;
B : TBatchMove;
begin
{S := nil;}{zzz}
{D := nil;}{zzz}
{B := nil;}{zzz}
{ Result := False;}{zzz}
S := TTable.Create(nil);
D := TTable.Create(nil);
B := TBatchMove.Create(nil);
try
{Create The Source Table}
S.Active := False;
S.DatabaseName := SourceDatabaseName;
S.ReadOnly := False;
S.TableName := SourceTable;
S.Active := true;
{Create The Destination Table}
D.Active := False;
D.DatabaseName := DestDatabaseName;
D.TableName := DestTable;
D.ReadOnly := False;
{Make the table copy}
B.AbortOnKeyViol := False;
B.AbortOnProblem := False;
B.Destination := D;
B.Source := S;
B.Mode := BMode;
Try
B.Execute;
Except
End;
Result := True;
finally
S.Free;
D.Free;
B.Free;
end;
End;
{Returns True If The Tables Have Identical Structures, False Otherwise.
If 1 Local Table is involved then Indices are ignored!!!!!!}
//Unit Description UnitIndex Master Index
Function DBSchemaSame(const
DatabaseName1,
Table1,
DatabaseName2,
Table2: string): Boolean;
Begin
Result := IsStructureSame(DatabaseName1,Table1,DatabaseName2,Table2);
End;
{Subtracts the records in the source
table from the destination table}
//Unit Description UnitIndex Master Index
Function DBSubtractTable(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
Begin
Result := SubtractTable(SourceDatabaseName,SourceTable,
DestDatabaseName,DestinationTable);
End;
{Deletes all occurances of a Character in a String}
//Unit Description UnitIndex Master Index
Function DeleteCharacterInString(InputCharacter,InputString: String): String;
Var
CharPos : Integer;
Begin
Result := InputString;
While True Do
Begin
CharPos := Pos(InputCharacter,InputString);
If Not (CharPos = 0) Then
Begin
Delete(InputString,CharPos,1);
End
Else
Begin
Break;
End;
End;
Result := InputString;
End;
{Deletes Files}
//Unit Description UnitIndex Master Index
Function DeleteFiles(FilePath,FileMask: String): Boolean;
var
DeleteFilesSearchRec: TSearchRec;
begin
Result := False;
FindFirst(FilePath+'\'+FileMask, faAnyFile, DeleteFilesSearchRec);
If Not (DeleteFilesSearchRec.Name = '') Then
Begin
Result := True;
DeleteFile(
{$IFDEF WIN32}ConvertStringToPChar({$ENDIF}
FilePath+'\'+DeleteFilesSearchRec.Name
{$IFDEF WIN32}){$ENDIF}
);
While True Do
Begin
If FindNext(DeleteFilesSearchRec)<0 Then
Begin
Break;
End
Else
Begin
DeleteFile(
{$IFDEF WIN32}ConvertStringToPChar({$ENDIF}
FilePath+'\'+DeleteFilesSearchRec.Name
{$IFDEF WIN32}){$ENDIF}
);
End;
End;
End;
End;
{Deletes all occurances of specified substring in a String}
//Unit Description UnitIndex Master Index
Function DeleteSubStringInString(substring,InputString: String): String;
Var
CharPos : Integer;
l : Integer;
Begin
Result := InputString;
l := Length(SubString);
While True Do
Begin
CharPos := Pos(substring,InputString);
If Not (CharPos = 0) Then
Delete(InputString,CharPos,l)
Else
Break;
End;
Result := InputString;
End;
{Deletes A Table}
//Unit Description UnitIndex Master Index
Function DeleteTable(const DatabaseName, TableName : string):Boolean;
Begin
Result := DBDropTable(DatabaseName, TableName);
End;
{Checks whether Delphi is Running and
issues a message if the user doesn't have
the right to use the component}
//Unit Description UnitIndex Master Index
procedure DelphiCheck(CanRunOutSide: Boolean);
var WindHand : THandle;
wcnPChar : array[0..32] of char;
ClName : array[0..32] of char;
Begin
If CanRunOutSide Then Exit;
StrPLCopy(wcnPChar,'TApplication',13);
{$IFDEF WIN32}
StrPLCopy(ClName,'Delphi 2.0',11);
{$ELSE}
StrPLCopy(ClName,'Delphi',7);
{$ENDIF}
WindHand := FindWindow(wcnPChar,ClName);
If WindHand = 0 Then
Begin
MessageDlg(
'The T*_ads component belongs to Advanced Delphi Systems!',
mtInformation,
[mbOk], 0);
MessageDlg(
'Please purchase at (301)840-1554',
mtInformation,
[mbOk], 0);
End;
End;
{Checks whether Delphi is Running and
issues a message if the user doesn't have
the right to use the component}
//Unit Description UnitIndex Master Index
procedure DelphiChecker(
CanRunOutSide : Boolean;
ComponentName : String;
OwnerName : String;
PurchaseMessage : String;
ActivateDate : String);
var WindHand : THandle;
wcnPChar : array[0..32] of char;
ClName : array[0..32] of char;
Begin
If CanRunOutSide Then Exit;
StrPLCopy(wcnPChar,'TApplication',13);
{$IFDEF WIN32}
StrPLCopy(ClName,'Delphi 2.0',11);
{$ELSE}
StrPLCopy(ClName,'Delphi',7);
{$ENDIF}
WindHand := FindWindow(wcnPChar,ClName);
If WindHand = 0 Then
Begin
If Date > StrToDate(ActivateDate) Then
Begin
MessageDlg(
ComponentName+' belongs to '+OwnerName+'!',
mtInformation,
[mbOk], 0);
MessageDlg(
PurchaseMessage,
mtInformation,
[mbOk], 0);
End;
End;
End;
{Returns True if delphi is running, False otherwise}
//Unit Description UnitIndex Master Index
Function DelphiIsRunning: Boolean;
var WindHand : THandle;
wcnPChar : array[0..32] of char;
ClName : array[0..32] of char;
Begin
StrPLCopy(wcnPChar,'TApplication',13);
{$IFDEF WIN32}
StrPLCopy(ClName,'Delphi 2.0',11);
{$ELSE}
StrPLCopy(ClName,'Delphi',7);
{$ENDIF}
WindHand := FindWindow(wcnPChar,ClName);
If WindHand = 0 Then
Begin
Result := false;
End
Else
Begin
Result := True;
End;
End;
{Returns Current Working Directory}
//Unit Description UnitIndex Master Index
Function Directory: String;
Var
DirName: String;
Begin
GetDir(0,DirName);
Result := DirName;
End;
{Drops A Table}
//Unit Description UnitIndex Master Index
Function DropTable(const DatabaseName, TableName : string):Boolean;
Begin
Result := DBDropTable(DatabaseName, TableName);
End;
{Empties a table of all records}
//Unit Description UnitIndex Master Index
Function EmptyTable(
const DatabaseName,
TableName : string): Boolean;
Begin
Result := DBEmptyTable(DatabaseName, TableName);
End;
{Returns The File Extension Without The Path, Name Or Period}
//Unit Description UnitIndex Master Index
Function ExtractFileExtNoPeriod(FileString: String): String;
Var
FileWithExtString: String;
FileExtString: String;
{FileNameNoExtString: String;}{zzz}
LenExt: Integer;
{ LenNameWithExt: Integer;}{zzz}
Begin
FileWithExtString := ExtractFileName(FileString);
{ LenNameWithExt := Length(FileWithExtString);}{zzz}
FileExtString := ExtractFileExt(FileString);
LenExt := Length(FileExtString);
If LenExt = 0 Then
Begin
Result := '';
End
Else
Begin
If SubStr(FileExtString,1,1) = '.' Then
Begin
FileExtString := SubStr(FileExtString,2,LenExt-1);
If Length(FileExtString) > 0 Then
Begin
Result := FileExtString;
End
Else
Begin
Result := '';
End;
End
Else
Begin
Result := FileExtString;
End;
End;
End;
{Returns The File Name Without The Path, Extension Or Period}
//Unit Description UnitIndex Master Index
Function ExtractFileNameNoExt(FileString: String): String;
Var
FileWithExtString: String;
FileExtString: String;
{FileNameNoExtString: String;}{zzz}
LenExt: Integer;
LenNameWithExt: Integer;
Begin
FileWithExtString := ExtractFileName(FileString);
LenNameWithExt := Length(FileWithExtString);
FileExtString := ExtractFileExt(FileString);
LenExt := Length(FileExtString);
If LenExt = 0 Then
Begin
Result := FileWithExtString;
End
Else
Begin
Result := SubStr(FileWithExtString,1,(LenNameWithExt-LenExt));
End;
End;
{Returns the field Number as an integer. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason 0 is returned.}
//Unit Description UnitIndex Master Index
Function FieldNo(DatabaseName, TableName, FieldName: String): Integer;
Begin
Result := DBFieldNo(DatabaseName, TableName, FieldName);
End;
{Returns the database field Size as an integer. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason 0 is returned.}
//Unit Description UnitIndex Master Index
Function FieldSize(DatabaseName, TableName, FieldName: String): Integer;
Begin
Result := FieldSize(DatabaseName, TableName, FieldName);
End;
{Returns the database field type as a string. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason a null string is returned.}
//Unit Description UnitIndex Master Index
Function FieldType(DatabaseName, TableName, FieldName: String): String;
Begin
Result := TypeField(DatabaseName, TableName, FieldName);
End;
{Returns the database field type as a string. If there
is an error a null string is returned.}
//Unit Description UnitIndex Master Index
Function FieldTypeFromDataSet(DataSet: TDataSet; FieldName: String): String;
Begin
Result := TypeFieldFromDataSet(DataSet, FieldName);
End;
{Returns The File Extension Without The Path, Name Or Period}
//Unit Description UnitIndex Master Index
Function FileExt(FileString: String): String;
Begin
Result := ExtractFileExtNoPeriod(FileString);
End;
{Moves a File From Source To Destination}
//Unit Description UnitIndex Master Index
Function FileMove(SourceFile, DestinationFile: String): Boolean;
Var
DestFileName: String;
FS,FD: TextFile;
Begin
If Not IsFile(SourceFile) Then
Begin
Result := False;
Exit;
End
Else
Begin
AssignFile(FS, SourceFile);
Reset(FS);
CloseFile(FS);
End;
If IsFile(DestinationFile) Then
Begin
AssignFile(FD, SourceFile);
Reset(FD);
CloseFile(FD);
If Length(FileExt(DestinationFile)) > 0 Then
Begin
DestFileName := FileName(DestinationFile)+'.'+FileExt(DestinationFile);
End
Else
Begin
DestFileName := FileName(DestinationFile);
End;
If Not DeleteFiles(FilePath(DestinationFile),DestFileName) Then
Begin
Result := False;
Exit;
End;
End;
Result := ReNameFile(SourceFile,DestinationFile);
End;
{Returns The File Name Without The Path, Extension Or Period}
//Unit Description UnitIndex Master Index
Function FileName(FileString: String): String;
Begin
Result := ExtractFileNameNoExt(FileString);
End;
{Returns The File Path Without The Name, Extension ,Period or trailing Backslash}
//Unit Description UnitIndex Master Index
Function FilePath(FileString: String): String;
Begin
Try
Result := ExtractFilePath(FileString);
Except
Result := '';
End;
End;
{Returns The Left Property To Center A Form}
//Unit Description UnitIndex Master Index
Function FormCenterHorizontal(FormWidth: Integer): Integer;
Var
ScreenWidth: Integer;
ScreenCenter: Integer;
FormCenter: Integer;
NewLeft: Integer;
Begin
ScreenWidth := Screen.Width;
ScreenCenter := ScreenWidth Div 2;
FormCenter := FormWidth Div 2;
NewLeft := ScreenCenter-FormCenter;
Result := NewLeft;
End;
{Returns The Top Property To Center A Form}
//Unit Description UnitIndex Master Index
Function FormCenterVertical(FormHeight: Integer): Integer;
Var
ScreenHeight: Integer;
ScreenCenter: Integer;
FormCenter: Integer;
NewTop: Integer;
Begin
ScreenHeight := Screen.Height;
ScreenCenter := ScreenHeight Div 2;
FormCenter := FormHeight Div 2;
NewTop := ScreenCenter-FormCenter;
If NewTop < 0 Then
NewTop := 0;
Result := NewTop;
End;
{Sets The Dimensions Of A Form}
//Unit Description UnitIndex Master Index
procedure FormDimensions(
Form: TForm;
TopDim,
LeftDim,
HeightDim,
WidthDim: Integer);
Begin
With Form Do
Begin
Left := LeftDim;
Top := TopDim;
ClientHeight := HeightDim;
ClientWidth := WidthDim;
End;
End;
{Returns the form's left value that will center the form horizontally}
//Unit Description UnitIndex Master Index
Function GetCenterFormLeft(FormWidth : Integer): Integer;
Begin
If Screen.Width < FormWidth Then
Begin
Result := Screen.Width-26;
End
Else
Begin
Result := (Screen.Width - FormWidth) div 2;
End;
End;
{Returns the form's Top value that will center the form vertically}
//Unit Description UnitIndex Master Index
Function GetCenterFormTop(FormHeight : Integer): Integer;
Begin
If Screen.Height < FormHeight Then
Begin
Result := Screen.Height-26;
End
Else
Begin
Result := (Screen.Height - FormHeight) div 2;
End;
End;
{Deletes a row in a TStringGrid}
//Unit Description UnitIndex Master Index
procedure GridDeleteRow(RowNumber : Integer; Grid : TStringGrid);
Var
i : Integer;
Begin
Grid.Row := RowNumber;
If (Grid.Row = Grid.RowCount -1) Then
Begin
{On the last row}
Grid.RowCount := Grid.RowCount - 1;
End
Else
Begin
{Not the last row}
For i := RowNumber To Grid.RowCount - 1 Do
Begin
Grid.Rows[i] := Grid.Rows[i+ 1];
End;
Grid.RowCount := Grid.RowCount - 1;
End;
End;
{Moves a row in a TStringGrid to the bottom of the grid}
//Unit Description UnitIndex Master Index
procedure GridMoveRowToBottom(RowNumber : Integer; Grid : TStringGrid);
Var
i : Integer;
Begin
Grid.Row := RowNumber;
Grid.RowCount := Grid.RowCount + 1;
Grid.Rows[Grid.RowCount-1] := Grid.Rows[Grid.Row];
For i := RowNumber+1 To Grid.RowCount -1 Do
Begin
Grid.Rows[i-1] := Grid.Rows[i];
End;
Grid.RowCount := Grid.RowCount - 1;
End;
{Returns True if Delphi is currently running}
//Unit Description UnitIndex Master Index
Function IsDelphiRunning: Boolean;
Begin
Result := DelphiIsRunning;
End;
{Tests Directory Existence}
//Unit Description UnitIndex Master Index
Function IsDir(IsDirPath: String): Boolean;
Var
FileGetAttrValue: Integer;
Begin
{$IFDEF WIN32}
Result := DirectoryExists(IsDirPath);
Exit;
{$ENDIF}
FileGetAttrValue := FileGetAttr(IsDirPath);
If FileGetAttrValue = 16 Then
Begin
Result := True
End
Else
Begin
Result := False
End;
End;
{Returns True If Directory Is Empty, False Otherwise}
//Unit Description UnitIndex Master Index
Function IsDirEmpty(DirName: String): Boolean;
Begin
If IsDir(DirName) Then
Begin
If IsFile(DirName+'\*.*') Then
Begin
Result := False;
End
Else
Begin
Result := True;
End;
End
Else
Begin
Result := False;
End;
End;
{Tests whether a TDataSource is empty, i.e., has no records }
//Unit Description UnitIndex Master Index
Function IsEmptyDataSource(DS: TDataSource): Boolean;
Var
IsError : Boolean;
BOF : Boolean;
EOF : Boolean;
ActiveWas : Boolean;
Begin
ActiveWas := DS.DataSet.Active;
IsError := False;
BOF := False;
EOF := False;
{ Result := False;}{zzz}
Try
If Not DS.DataSet.Active Then DS.DataSet.Active := True;
BOF := DS.DataSet.BOF;
EOF := DS.DataSet.EOF;
Except
IsError := True
End;
If IsError Then
Begin
Result := False;
End
Else
Begin
If BOF And EOF Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
End;
DS.DataSet.Active := ActiveWas;
End;
{Tests whether a TQuery is empty, i.e., has no records }
//Unit Description UnitIndex Master Index
Function IsEmptyTQuery(Query: TQuery): Boolean;
Var
IsError : Boolean;
BOF : Boolean;
EOF : Boolean;
ActiveWas : Boolean;
Begin
ActiveWas := Query.Active;
IsError := False;
BOF := False;
EOF := False;
{ Result := False;}{zzz}
Try
If Not Query.Active Then Query.Active := True;
BOF := Query.BOF;
EOF := Query.EOF;
Except
IsError := True
End;
If IsError Then
Begin
Result := False;
End
Else
Begin
If BOF And EOF Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
End;
Query.Active := ActiveWas;
End;
{Tests whether a TTable is empty, i.e., has no records }
//Unit Description UnitIndex Master Index
Function IsEmptyTTable(Table: TTable): Boolean;
Var
IsError : Boolean;
BOF : Boolean;
EOF : Boolean;
ActiveWas : Boolean;
Begin
ActiveWas := Table.Active;
IsError := False;
BOF := False;
EOF := False;
{ Result := False;}{zzz}
Try
If Not Table.Active Then Table.Active := True;
BOF := Table.BOF;
EOF := Table.EOF;
Except
IsError := True
End;
If IsError Then
Begin
Result := False;
End
Else
Begin
If BOF And EOF Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
End;
Table.Active := ActiveWas;
End;
{Tests whether a table is empty, i.e., has no records }
//Unit Description UnitIndex Master Index
Function IsEmptyTable(DatabaseName, TableName: String): Boolean;
Var
Query : TQuery;
IsError : Boolean;
BOF : Boolean;
EOF : Boolean;
Begin
IsError := False;
BOF := False;
EOF := False;
Result := False;{zzz}
Query := TQuery.Create(nil);
Try
Try
Query.DatabaseName := DatabaseName;
Query.Sql.Clear;
Query.Sql.Add('Select *');
Query.Sql.Add('From');
If (Pos('.DB', UpperCase(TableName)) > 0) Or
(Pos('.DBF', UpperCase(TableName)) > 0) Then
Begin
Query.Sql.Add('"'+TableName+'"');
End
Else
Begin
Query.Sql.Add(TableName);
End;
Query.Active := True;
Query.First;
BOF := Query.BOF;
EOF := Query.EOF;
Except
IsError := True
End;
Finally
Query.Free;
End;
If IsError Then
Begin
Result := False;
End
Else
Begin
If BOF And EOF Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
End;
End;
{Tests whether a table is empty, i.e., has no records }
//Unit Description UnitIndex Master Index
Function IsEmptyTable2(DatabaseName, TableName: String): Boolean;
Var
T : TTable;
IsError : Boolean;
BOF : Boolean;
EOF : Boolean;
Begin
IsError := False;
BOF := False;
EOF := False;
Result := False;{zzz}
BOF := False;
EOF := False;
T := TTable.Create(nil);
Try
Try
T.DatabaseName := DatabaseName;
T.TableName := TableName;
T.Active := True;
T.First;
BOF := T.BOF;
EOF := T.EOF;
Except
IsError := True
End;
Finally
T.Free;
End;
If IsError Then
Begin
Result := False;
End
Else
Begin
If BOF And EOF Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
End;
End;
{Returns True If DatabaseName:TableName:FieldName Exists,
False Otherwise}
//Unit Description UnitIndex Master Index
Function IsField(DatabaseName, TableName, FieldName: String): Boolean;
Var
Query : TQuery;
T : TTable;
i : Integer;
UpperFN : String;
TestFN : String;
Begin
Result := False;
UpperFN := UpperCase(FieldName);
If Not IsTable(DatabaseName, TableName) Then Exit;
Query := TQuery.Create(nil);
T := TTable.Create(nil);
Try
Try
Query.DatabaseName := DatabaseName;
Query.Sql.Clear;
Query.Sql.Add('Select ');
Query.Sql.Add('a.'+FieldName+' XYZ');
Query.Sql.Add('From');
If (Pos('.DB', UpperCase(TableName)) > 0) Or
(Pos('.DBF',UpperCase(TableName)) > 0) Then
Begin
Query.Sql.Add('"'+TableName+'" a');
End
Else
Begin
Query.Sql.Add(TableName+' a');
End;
Query.Active := True;
Result := True;
Except
Try
T.Active := False;
T.DatabaseName := DatabaseName;
T.TableName := TableName;
T.Active := True;
If T.FieldDefs.IndexOf(FieldName) > -1 Then
Begin
Result := True;
End
Else
Begin
For i := 0 To T.FieldDefs.Count -1 Do
Begin
TestFN := UpperCase(T.FieldDefs[i].Name);
If TestFN = UpperFN Then
Begin
Result := True;
Break;
End;
End;
End;
T.Active := False;
Except
End;
End;
Finally
Query.Free;
T.Free;
End;
End;
{Returns True If DatabaseName:TableName:FieldName
Exists and is Keyed, False Otherwise}
//Unit Description UnitIndex Master Index
Function IsFieldKeyed(DatabaseName, TableName, FieldName: String): Boolean;
Var
Table : TTable;
FieldIndex : Integer;
i : Integer;
KeyCount : Integer;
LocalTable : Boolean;
ParadoxTbl : Boolean;
DBaseTable : Boolean;
TempString : String;
Begin
Result := False;
If Not IsTable(DatabaseName, TableName) Then Exit;
If Not IsField(DatabaseName, TableName, FieldName) Then Exit;
TempString := UpperCase(SubStr(TableName,Length(TableName)-2,3));
ParadoxTbl := (Pos('.DB',TempString) > 0);
TempString := UpperCase(SubStr(TableName,Length(TableName)-3,4));
DBaseTable := (Pos('.DBF',TempString) > 0);
LocalTable := (ParadoxTbl Or DBaseTable);
Table := TTable.Create(nil);
Try
Try
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
KeyCount := Table.IndexFieldCount;
FieldIndex := Table.FieldDefs.IndexOf(FieldName);
If LocalTable Then
Begin
If ParadoxTbl Then
Begin
Result := (FieldIndex < KeyCount);
End
Else
Begin
Table.IndexDefs.UpDate;
For i := 0 To Table.IndexDefs.Count-1 Do
Begin
{Need to check if FieldName is in the Expression listing}
If Pos(UpperCase(FieldName),UpperCase(Table.IndexDefs[i].Expression))>0 Then
Begin
Result := True;
Break;
End;
{Need to check if FieldName is in the Fields listing}
If Pos(UpperCase(FieldName),UpperCase(Table.IndexDefs[i].Fields))>0 Then
Begin
Result := True;
Break;
End;
End;
End;
End
Else
Begin
If Table.
FieldDefs[FieldIndex].
Required
Then
Begin
Result := True;
End;
End;
// If Table.
// FieldDefs[FieldIndex].
// Required
// Then
// Begin
// Result := True;
// End
// Else
// Begin
// Result := False;
// {Need to examine indexdefs}
// If (Pos('.DB', UpperCase(TableName)) > 0) Then
// Begin
// {Table is either Paradox or DBase}
// Table.IndexDefs.UpDate;
// If (Pos('.DBF', UpperCase(TableName)) > 0) Then
// Begin
// {Table is a DBase Table}
// For i := 0 To Table.IndexDefs.Count-1 Do
// Begin
// {Need to check if FieldName is in the Expression listing}
// If Pos(UpperCase(FieldName),UpperCase(Table.IndexDefs[i].Expression))>0 Then
// Begin
// Result := True;
// Break;
// End;
// {Need to check if FieldName is in the Fields listing}
// If Pos(UpperCase(FieldName),UpperCase(Table.IndexDefs[i].Fields))>0 Then
// Begin
// Result := True;
// Break;
// End;
// End;
// End
// Else
// Begin
// {Table is a Paradox Table}
// For i := 0 To Table.IndexDefs.Count-1 Do
// Begin
// If ixPrimary in Table.IndexDefs[i].Options Then
// Begin
// {Need to check if FieldName is in the Fields listing}
// If Pos(UpperCase(FieldName),UpperCase(Table.IndexDefs[i].Fields))>0 Then
// Begin
// Result := True;
// End
// Else
// Begin
// Result := False;
// End;
// Break;
// End;
// End;
// End;
// End
// Else
// Begin
// Result := False;
// End;
// End;
Except
End;
Finally
Table.Free;
End;
End;
{Returns True If The File Exists, False Otherwise}
//Unit Description UnitIndex Master Index
Function IsFile(DirName: String): Boolean;
Var
IsFileSearchRec: TSearchRec;
{ FindReturn: Integer;}{zzz}
JustPath: String;
Counter: Integer;
NameHolder: String;
Begin
{ Result := False;}{zzz}
{$IFDEF WIN32}
Result := FileExists(DirName);
Exit;
{$ENDIF}
Counter := 1;
Try
JustPath := ExtractFilePath(DirName);
JustPath := SubStr(JustPath,1,Length(JustPath)-1);
Except
On EInOutError Do JustPath := DirName;
Else JustPath := DirName;
End;
If Not IsDir(JustPath) Then
Begin
Result := False;
Exit;
End;
{zzz} {FindReturn := }FindFirst(DirName,faAnyFile, IsFileSearchRec);
If IsFileSearchRec.Name = '' Then
Begin
Result := False;
Exit;
End;
If (Not(IsFileSearchRec.Name = '.')) And
(Not (IsFileSearchRec.Name = '..')) And
(Length(IsFileSearchRec.Name) < 13) Then
Begin
Result := True;
Exit;
End;
NameHolder := 'skjjkhfhj';
While True Do
Begin
{FindReturn := }FindNext(IsFileSearchRec);
If IsFileSearchRec.Name = NameHolder Then
Exit;
If (Not (IsFileSearchRec.Name = '.')) And
(Not (IsFileSearchRec.Name = '..')) And
(Not (IsFileSearchRec.Name = '')) And
(Length(IsFileSearchRec.Name) < 13) Then
Begin
Result := True;
Exit;
End
Else
Begin
If IsFileSearchRec.Name = '' Then
Begin
Result := False;
End
Else
Begin
{Keep Going}
End;
End;
Counter := Counter + 1;
If Counter > 1000 Then
Exit;
End;
End;
{Returns True If The Tables Have Identical Structures, False Otherwise.
If 1 Local Table is involved then Indices are ignored!!!!!!}
//Unit Description UnitIndex Master Index
Function IsSchemaSame(const
DatabaseName1,
Table1,
DatabaseName2,
Table2: string): Boolean;
Begin
Result := IsStructureSame(DatabaseName1,Table1,DatabaseName2,Table2);
End;
{Returns True If The Tables Have Identical Structures, False Otherwise.
If 1 Local Table is involved then Indices are ignored!!!!!!}
//Unit Description UnitIndex Master Index
Function IsStructureSame(const
DatabaseName1,
Table1,
DatabaseName2,
Table2: string): Boolean;
Var
T1 : TTable;
T2 : TTable;
i : Integer;
OneLocal : Boolean;
Begin
Result := False;
If Not IsTable(DatabaseName1, Table1) Then Exit;
If Not IsTable(DatabaseName2, Table2) Then Exit;
If (Pos('.DB',UpperCase(Table1)) > 0) Or
(Pos('.DB',UpperCase(Table2)) > 0) Then
Begin
OneLocal := True;
End
Else
Begin
OneLocal := False;
End;
T1 := TTable.Create(nil);
T2 := TTable.Create(nil);
Try
Try
T1.Active := False;
T1.DatabaseName := DatabaseName1;
T1.TableName := Table1;
T1.Active := True;
T2.Active := False;
T2.DatabaseName := DatabaseName2;
T2.TableName := Table2;
T2.Active := True;
If T1.FieldDefs.Count <> T2.FieldDefs.Count Then
Begin
Result := False;
End
Else
Begin
Result := True;
For i := 0 To T1.FieldDefs.Count-1 Do
Begin
If (T1.FieldDefs[i].DataType <> T2.FieldDefs[i].DataType) Or
(T1.FieldDefs[i].FieldClass <> T2.FieldDefs[i].FieldClass) Or
(T1.FieldDefs[i].FieldNo <> T2.FieldDefs[i].FieldNo) Or
(UpperCase(T1.FieldDefs[i].Name)<>UpperCase(T2.FieldDefs[i].Name)) Or
(T1.FieldDefs[i].Size <> T2.FieldDefs[i].Size) Then
Begin
Result := False;
Break;
End;
If (T1.FieldDefs[i].Required <> T2.FieldDefs[i].Required) And
(Not OneLocal) Then
Begin
Result := False;
Break;
End;
End;
End;
Except
End;
Finally
T1.Free;
T2.Free;
End;
End;
{Returns True If The Table Exists, False Otherwise}
//Unit Description UnitIndex Master Index
Function IsTable(DatabaseName, TableName: String): Boolean;
Var
T: TTable;
Begin
Result := False;
T := TTable.Create(nil);
Try
Try
T.DatabaseName := DatabaseName;
T.TableName := TableName;
// Query.Sql.Clear;
// Query.Sql.Add('Select *');
// Query.Sql.Add('From');
// If (Pos('.DB', UpperCase(TableName)) > 0) Or
// (Pos('.DBF',UpperCase(TableName)) > 0) Then
// Begin
// Query.Sql.Add('"'+TableName+'"');
// End
// Else
// Begin
// Query.Sql.Add(TableName);
// End;
// Query.Active := True;
T.Active := True;
Result := True;
Except
End;
Finally
T.Free;
End;
End;
{Returns True If DatabaseName:TableName
Exists and has a primary key, False Otherwise}
//Unit Description UnitIndex Master Index
Function IsTableKeyed(DatabaseName, TableName: String): Boolean;
Var
Table : TTable;
{FieldIndex : Integer;}{zzz}
i : Integer;
IsKeyed : Boolean;
Begin
Result := False;
IsKeyed := False;
If Not IsTable(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
For i := 0 To Table.FieldDefs.Count-1 Do
Begin
If Table.FieldDefs[i].Required Then
Begin
IsKeyed := True;
Break;
End;
End;
If IsKeyed Then
Begin
Result := True;
End
Else
Begin
Result := False;
{Need to examine indexdefs}
If (Pos('.DB', UpperCase(TableName)) > 0) Then
Begin
{Table is either Paradox or DBase}
Table.IndexDefs.UpDate;
If (Pos('.DBF', UpperCase(TableName)) > 0) Then
Begin
{Table is a DBase Table}
If Table.IndexDefs.Count > 0 Then
Begin
Result := True;
End;
End
Else
Begin
{Table is a Paradox Table}
For i := 0 To Table.IndexDefs.Count-1 Do
Begin
If ixPrimary in Table.IndexDefs[i].Options Then
Begin
Result := True;
Break;
End;
End;
End;
End
Else
Begin
Result := False;
End;
End;
Except
End;
Finally
Table.Free;
End;
End;
{!~ Throws away all keys except a-z and A-Z}
//Unit Description UnitIndex Master Index
Procedure KeyPressOnlyAToZ(Var Key: Char);
Begin
Case Key Of
'a': Exit;
'b': Exit;
'c': Exit;
'd': Exit;
'e': Exit;
'f': Exit;
'g': Exit;
'h': Exit;
'i': Exit;
'j': Exit;
'k': Exit;
'l': Exit;
'm': Exit;
'n': Exit;
'o': Exit;
'p': Exit;
'q': Exit;
'r': Exit;
's': Exit;
't': Exit;
'u': Exit;
'v': Exit;
'w': Exit;
'x': Exit;
'y': Exit;
'z': Exit;
'A': Exit;
'B': Exit;
'C': Exit;
'D': Exit;
'E': Exit;
'F': Exit;
'G': Exit;
'H': Exit;
'I': Exit;
'J': Exit;
'K': Exit;
'L': Exit;
'M': Exit;
'N': Exit;
'O': Exit;
'P': Exit;
'Q': Exit;
'R': Exit;
'S': Exit;
'T': Exit;
'U': Exit;
'V': Exit;
'W': Exit;
'X': Exit;
'Y': Exit;
'Z': Exit;
#8 : Exit; {Backspace}
End;
Key := #0; {Throw the key away}
End;
{!~ Throws away all keys except 0-9}
//Unit Description UnitIndex Master Index
Procedure KeyPressOnlyNumbersAbsolute(Var Key: Char);
Begin
Case Key Of
'0': Exit;
'1': Exit;
'2': Exit;
'3': Exit;
'4': Exit;
'5': Exit;
'6': Exit;
'7': Exit;
'8': Exit;
'9': Exit;
#8 : Exit; {Backspace}
End;
Key := #0; {Throw the key away}
End;
{!~ Throws away all keys except letters}
//Unit Description UnitIndex Master Index
Procedure KeyPressOnlyLettersAbsolute(Var Key: Char);
Begin
Case Key Of
'a': Exit;
'b': Exit;
'c': Exit;
'd': Exit;
'e': Exit;
'f': Exit;
'g': Exit;
'h': Exit;
'i': Exit;
'j': Exit;
'k': Exit;
'l': Exit;
'm': Exit;
'n': Exit;
'o': Exit;
'p': Exit;
'q': Exit;
'r': Exit;
's': Exit;
't': Exit;
'u': Exit;
'v': Exit;
'w': Exit;
'x': Exit;
'y': Exit;
'z': Exit;
'A': Exit;
'B': Exit;
'C': Exit;
'D': Exit;
'E': Exit;
'F': Exit;
'G': Exit;
'H': Exit;
'I': Exit;
'J': Exit;
'K': Exit;
'L': Exit;
'M': Exit;
'N': Exit;
'O': Exit;
'P': Exit;
'Q': Exit;
'R': Exit;
'S': Exit;
'T': Exit;
'U': Exit;
'V': Exit;
'W': Exit;
'X': Exit;
'Y': Exit;
'Z': Exit;
#8 : Exit; {Backspace}
End;
Key := #0; {Throw the key away}
End;
{Throws away all keys except 0-9,-,+,.}
//Unit Description UnitIndex Master Index
Procedure KeyPressOnlyNumbers(Var Key: Char);
Begin
Case Key Of
'0': Exit;
'1': Exit;
'2': Exit;
'3': Exit;
'4': Exit;
'5': Exit;
'6': Exit;
'7': Exit;
'8': Exit;
'9': Exit;
'-': Exit;
'+': Exit;
'.': Exit;
#8 : Exit; {Backspace}
End;
Key := #0; {Throw the key away}
End;
{Allows the programmer to simulate
a keyboard press of a virtual key.
Only one key at a time.}
//Unit Description UnitIndex Master Index
Function KeySend(VirtualKey: Word): Boolean;
Begin
Result := SendKey(VirtualKey);
End;
{Returns The Length Of The String}
//Unit Description UnitIndex Master Index
Function Len(InputString: String): Integer;
Begin
Result := Length(InputString);
End;
{Returns a string converted to lower case}
//Unit Description UnitIndex Master Index
Function Lower(InputString: String): String;
Begin
Result := LowerCase(InputString);
End;
{Makes A Directory}
//Unit Description UnitIndex Master Index
Function MD(DirName: String): Boolean;
Begin
If IsDir(DirName) Then
Begin
Result := True;
End
Else
Begin
If FileExists(DirName) And Not IsDir(DirName) Then
Begin
Result := False;
End
Else
Begin
{$IFDEF WIN32}
ForceDirectories(DirName);
Result := True;
{$ELSE}
MkDir(DirName);
If IOResult <> 0 Then
Begin
Result := False;
End
Else
Begin
Result := True;
End;
{$ENDIF}
End;
End;
End;
{Returns the larger of two numbers}
//Unit Description UnitIndex Master Index
Function Max(Number1, Number2: Single): Single;
Begin
If Number1 > Number2 Then
Begin
Result := Number1;
End
Else
Begin
Result := Number2;
End;
End;
{Returns the smaller of two numbers}
//Unit Description UnitIndex Master Index
Function Min(Number1, Number2: Single): Single;
Begin
If Number1 < Number2 Then
Begin
Result := Number1;
End
Else
Begin
Result := Number2;
End;
End;
{Moves SourceTable From SourceDatabaseName
To DestDatabasename. If a table exists
with the same name at DestDatabaseName it
is overwritten.}
//Unit Description UnitIndex Master Index
Function MoveTable(
SourceTable,
SourceDatabaseName,
DestDatabaseName: String): Boolean;
Begin
Result := DBMoveTable(SourceTable,SourceDatabaseName,DestDatabaseName);
End;
{Presents a Message Dialog}
//Unit Description UnitIndex Master Index
procedure Msg(Msg: String);
Begin
MessageDlg(
Msg,
mtInformation,
[mbOk], 0);
End;
{Returns the number of fields in a table}
//Unit Description UnitIndex Master Index
Function NFields(DatabaseName, TableName: String): Integer;
Var
Table : TTable;
FieldCount : Integer;
Begin
Result := 0;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
FieldCount := Table.FieldDefs.Count;
Result := FieldCount;
Except
End;
Finally
Table.Free;
End;
End;
{Converts a string to an Extended floating point number}
//Unit Description UnitIndex Master Index
Function NumVal(InputString: String): Extended;
Begin
Result := 0;
InputString := NumbersOnly(InputString);
Try
Result := StrToFloat(InputString);
Except
End;
End;
{Throws away all characters except 0-9,-,+,.}
//Unit Description UnitIndex Master Index
Function NumbersOnly(InputString: String): String;
Var
NewString: String;
L : Integer;
i : Integer;
C : Char;
Begin
Result := InputString;
NewString := '';
L := Length(InputString);
For i:= 1 To L Do
Begin
C := InputString[i];
KeyPressOnlyNumbers(C);
If Not (C = #0) Then
Begin
NewString := NewString + C;
End;
End;
Result := NewString;
End;
{!~ Throws away all characters except 0-9}
//Unit Description UnitIndex Master Index
Function NumbersOnlyAbsolute(InputString: String): String;
Var
NewString: String;
L : Integer;
i : Integer;
C : Char;
Begin
Result := InputString;
NewString := '';
L := Length(InputString);
For i:= 1 To L Do
Begin
C := InputString[i];
If Not(
(C='+') Or
(C='-') Or
(C='.') Or
(C=',')) Then
Begin
KeyPressOnlyNumbers(C);
If Not (C = #0) Then
Begin
If NewString = '0' Then NewString := '';
NewString := NewString + C;
End;
End;
End;
Result := NewString;
End;
{!~ Throws away all characters except letters}
//Unit Description UnitIndex Master Index
Function LettersOnlyAbsolute(InputString: String): String;
Var
NewString: String;
L : Integer;
i : Integer;
C : Char;
Begin
Result := InputString;
NewString := '';
L := Length(InputString);
For i:= 1 To L Do
Begin
C := InputString[i];
KeyPressOnlyLettersAbsolute(C);
If Not (C = #0) Then
Begin
NewString := NewString + C;
End;
End;
Result := NewString;
End;
{Sets or unsets beveling in a panel}
//Unit Description UnitIndex Master Index
Procedure PanelBevel(Beveled : Boolean; Panel: TPanel);
Begin
If Not Beveled Then
Begin
Panel.BevelOuter := bvNone;
Panel.BevelInner := bvNone;
Panel.BorderStyle:= bsNone;
End
Else
Begin
Panel.BevelOuter := bvRaised;
Panel.BevelInner := bvLowered;
Panel.BorderStyle:= bsSingle;
End;
End;
{Returns the constant pi as a real number}
//Unit Description UnitIndex Master Index
Function Pi_Real: Real;
Begin
Result := Pi;
End;
{Increments the screen cursor to show progress}
//Unit Description UnitIndex Master Index
procedure ProgressScreenCursor;
Begin
If Screen.Cursor = crUpArrow Then
Begin
Screen.Cursor := crSizeNESW;
Exit;
End;
If Screen.Cursor = crSizeNESW Then
Begin
Screen.Cursor := crSizeWE;
Exit;
End;
If Screen.Cursor = crSizeWE Then
Begin
Screen.Cursor := crSizeNWSE;
Exit;
End;
If Screen.Cursor = crSizeNWSE Then
Begin
Screen.Cursor := crSizeNS;
Exit;
End;
If Screen.Cursor = crSizeNS Then
Begin
Screen.Cursor := crHSplit;
Exit;
End;
If Screen.Cursor = crHSplit Then
Begin
Screen.Cursor := crSize;
Exit;
End;
If Screen.Cursor = crSize Then
Begin
Screen.Cursor := crArrow;
Exit;
End;
If Screen.Cursor = crArrow Then
Begin
Screen.Cursor := crUpArrow;
Exit;
End;
Screen.Cursor := crUpArrow;
End;
{Returns the Proper form of a string, i.e., each word
starts with a capitalized letter and all subsequent
letters are lowercase}
//Unit Description UnitIndex Master Index
Function Proper(S : String): String;
Var
Capitalize : Boolean;
NewString : String;
i : Integer;
L : Integer;
C : String;
Begin
Result := '';
Capitalize := True;
NewString := '';
L := Length(S);
If L = 0 Then Exit;
For i := 1 To L Do
Begin
C := SubStr(S,i,1);
If Capitalize Then
Begin
NewString := NewString + UpperCase(C);
End
Else
Begin
NewString := NewString + LowerCase(C);
End;
If (C = ' ') Or (C = '_') Then
Begin
Capitalize := True;
End
Else
Begin
Capitalize := False;
End;
End;
Result := NewString;
End;
{Returns A PseudoRandom Number Between 0 And 1}
//Unit Description UnitIndex Master Index
Function Rand: Integer;
Begin
Result := RandomInteger(0,1);
End;
{Loads A Random Image}
//Unit Description UnitIndex Master Index
Procedure RandImage(ImageControl: TImage;
DirPath,
FileStub,
FileExt: String;
ImageMin,
ImageMax: Integer);
Var
RandomValue: Integer;
RandValString: String;
{SearchRec: TSearchRec;}{zzz}
{ZipString: String;}{zzz}
Begin
RandomValue := RandomInteger(ImageMin,ImageMax);
If RandomValue < 10 Then
Begin
RandValString := '0'+ IntToStr(RandomValue);
End
Else
Begin
RandValString := IntToStr(RandomValue);
End;
ImageControl.Picture.LoadFromFile(DirPath+'\'+
FileStub+
RandValString+'.'+FileExt);
End;
{Returns A Random Number}
//Unit Description UnitIndex Master Index
Function RandomInteger(RandMin, RandMax: Integer): Integer;
Var
RandRange: Integer;
RandValue: Integer;
Begin
If RandMax <= RandMin Then
Begin
Result := RandMin;
Exit;
End;
Randomize;
RandRange := RandMax-RandMin;
RandValue := Random(RandRange);
Result := RandValue + RandMin;
End;
{Replaces all occurances of a character in a string
with a new character}
//Unit Description UnitIndex Master Index
Function ReplaceCharInString(S,OldChar,NewChar :String): String;
Var
NewString : String;
i : Integer;
L : Integer;
C : String;
Begin
Result := '';
NewString := '';
L := Length(S);
{If the string is empty then get out of here}
If L = 0 Then Exit;
{If the string doesn't have any occurances of the
OldChar then get out of here}
If Pos(UpperCase(OldChar),UpperCase(S)) = 0 Then
Begin
Result := S;
Exit;
End;
For i := 1 To L Do
Begin
C := SubStr(S,i,1);
If UpperCase(C) = UpperCase(OldChar) Then
Begin
NewString := NewString + NewChar;
End
Else
Begin
NewString := NewString + C;
End;
End;
Result := NewString;
End;
{Replaces all occurances of a Character in a String}
//Unit Description UnitIndex Master Index
Function ReplaceCharacterInString(
OldChar,
NewChar,
InputString: String): String;
Var
CharPos,L : Integer;
Begin
Result := InputString;
If OldChar = NewChar Then Exit;
L := Length(InputString);
While True Do
Begin
CharPos := Pos(OldChar,InputString);
If Not (CharPos = 0) Then
Begin
If CharPos = 1 Then
Begin
{First Character}
InputString := NewChar + SubStr(InputString,2,255);
End
Else
Begin
If CharPos = L Then
Begin
{Last Character}
InputString := SubStr(InputString,1,L-1)+NewChar;
End
Else
Begin
{Middle Character}
InputString :=
SubStr(InputString,1,CharPos-1)+
NewChar +
SubStr(InputString,CharPos+1,255);
End;
End;
Result := InputString;
End
Else
Begin
Break;
End;
End;
Result := InputString;
End;
{Scales a Form To A Particular Resolution}
//Unit Description UnitIndex Master Index
Procedure ScaleForm(F: TForm;ScreenWidth, ScreenHeight: LongInt);
{Var}
{I: Integer;}{zzz}
{ OldFormWidth: LongInt;}{zzz}
{ NewFormWidth: LongInt;}{zzz}
Begin
{ OldFormWidth := F.Width;}{zzz}
F.Scaled := True;
F.AutoScroll := False;
F.Position := poScreenCenter;
F.Font.Name := 'Arial';
If (Screen.Width <> ScreenWidth) Then
Begin
F.Height := LongInt(F.Height)* LongInt(Screen.Height) div ScreenHeight;
F.Width := LongInt(F.Width) * LongInt(Screen.Width) div ScreenWidth;
F.ScaleBy(Screen.Width,ScreenWidth);
End;
{ NewFormWidth := F.Width;}{zzz}
{
For I := F.ComponentCount -1 DownTo 0 do
Begin
If F.Components[I] is TLabel then
Begin
TFontControl(F.Components[I]).Font.Name := 'Arial';
TLabel(F.Components[I]).AutoSize := true;
TFontControl(F.Components[I]).Font.Size :=
(NewFormWidth div OldFormWidth)*TFontControl(F.Components[I]).Font.Size;
End;
End;
}
End;
{Allows the programmer to simulate
a keyboard press of a virtual key.
Only one key at a time.}
//Unit Description UnitIndex Master Index
Function SendKey(VirtualKey: Word): Boolean;
Begin
{ Result := False;}{zzz}
Try
PostVirtualKeyEvent(VirtualKey,False);
PostVirtualKeyEvent(VirtualKey,True);
Result := True;
Except
Result := False;
End;
End;
{Sets all Children of a TPanel to the same width}
//Unit Description UnitIndex Master Index
procedure SetChildWidths(Panel : TPanel);
Var
i : Integer;
Width : Integer;
Begin
Width :=
(Panel.Width -
(Panel.BorderWidth * 2) -
(Panel.BevelWidth * 4)) div Panel.ControlCount;
For i := 0 To Panel.ControlCount - 1 Do
Begin
Panel.Controls[i].Width := Width;
End;
End;
{Pads or truncates a String and Justifies Left if StrJustify=True}
//Unit Description UnitIndex Master Index
Function StringPad(
InputStr,
FillChar: String;
StrLen: Integer;
StrJustify: Boolean): String;
Var
TempFill: String;
Counter : Integer;
Begin
If Not (Length(InputStr) = StrLen) Then
Begin
If Length(InputStr) > StrLen Then
Begin
InputStr := Copy(InputStr,1,StrLen);
End
Else
Begin
TempFill := '';
For Counter := 1 To StrLen-Length(InputStr) Do
Begin
TempFill := TempFill + FillChar;
End;
If StrJustify Then
Begin
{Left Justified}
InputStr := InputStr + TempFill;
End
Else
Begin
{Right Justified}
InputStr := TempFill + InputStr ;
End;
End;
End;
Result := InputStr;
End;
{Returns a SubString of a String.
Can only handle strings up to 255 characters.}
//Unit Description UnitIndex Master Index
Function SubStr(InputString: String; StartPos, StringLength: Byte): String;
Var
{$IFDEF WIN32}
InString: ShortString;
OutPutString: ShortString;
LenInputString: Byte;
Counter: Byte;
OutputStringWas : ShortString;
{$ELSE}
InString: String;
OutPutString: String;
LenInputString: Byte;
Counter: Byte;
OutputStringWas : String;
{$ENDIF}
BreakOut : Boolean;
Begin
Result := '';
If InputString = '' Then Exit;
BreakOut := False;
If (StartPos < 0) Then StartPos := 1;
{$IFDEF WIN32}
InString := ShortString(InputString);
{$ELSE}
InString := InputString;
{$ENDIF}
LenInputString := Length(InString);
If StartPos > LenInputString Then
Begin
Result := '';
Exit;
End;
If StringLength <= 0 Then
Begin
Result := '';
Exit;
End;
If (StartPos+StringLength) > LenInputString Then
StringLength := LenInputString-StartPos+1;
OutPutString[0] := Chr(StringLength);
For Counter := StartPos To (StartPos+StringLength-1) Do
Begin
OutputStringWas := OutputString;
Try
OutputString[Counter-StartPos+1]:=InputString[Counter];
Except
OutputString := OutputStringWas + 'zzz';
Result := String(OutPutString);
BreakOut := True;
End;
If BreakOut Then Exit;
End;
{$IFDEF WIN32}
Result := String(OutPutString);
{$ELSE}
Result := OutPutString;
{$ENDIF}
End;
{Subtracts the records in the source
table from the destination table}
//Unit Description UnitIndex Master Index
Function SubtractTable(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
{Var
BMode : TBatchMode;}{zzz}
Begin
Result := False;
If (Not IsTableKeyed(DestDatabaseName,DestinationTable)) Or
(Not IsTableKeyed(SourceDatabaseName,SourceTable)) Then
Begin
Exit;
End;
Result := DBRecordMove(SourceDatabaseName,SourceTable,
DestDatabaseName,DestinationTable,batDelete);
End;
{Add source table to destination table}
//Unit Description UnitIndex Master Index
Function TableAdd(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
Begin
Result := AddTables(SourceDatabaseName,SourceTable,
DestDatabaseName,DestinationTable);
End;
{Creates a new table from a Query.
Complex joins can be output to a new table.}
//Unit Description UnitIndex Master Index
Function TableCreateFromQuery(
Query: TQuery;
NewTableName,
TableDatabaseName: String): Boolean;
Begin
Result := DBCreateTableFromQuery(Query,NewTableName,TableDatabaseName);
End;
{Moves SourceTable From SourceDatabaseName
To DestDatabasename. If a table exists
with the same name at DestDatabaseName it
is overwritten.}
//Unit Description UnitIndex Master Index
Function TableMove(
SourceTable,
SourceDatabaseName,
DestDatabaseName: String): Boolean;
Begin
Result := DBMoveTable(SourceTable,SourceDatabaseName,DestDatabaseName);
End;
{Subtracts the records in the source
table from the destination table}
//Unit Description UnitIndex Master Index
Function TableSubtract(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
Begin
Result := SubtractTable(SourceDatabaseName,SourceTable,
DestDatabaseName,DestinationTable);
End;
{Returns Today's Date As A String}
//Unit Description UnitIndex Master Index
Function Today: String;
Begin
Result := FormatDateTime('m/d/yy',now);
End;
{Turns the panel upon which a TSpeedButton is placed
invisible if the SpeedButton's glyph is empty}
//Unit Description UnitIndex Master Index
Procedure ToolBarButtonVisibleOne(P:TPanel;B : TSpeedButton);
Begin
If B.Glyph.Empty = True Then P.Visible := False;
End;
{Trims blank spaces from both sides of the string}
//Unit Description UnitIndex Master Index
Function TrimBlanksFromEnds(InputString: String): String;
Begin
If InputString = '' Then
Begin
Result := '';
Exit;
End;
InputString := TrimBlanksLeft(InputString);
If InputString = '' Then
Begin
Result := '';
Exit;
End;
InputString := TrimBlanksRight(InputString);
Result := InputString;
End;
{Trims blank spaces from the left of the string}
//Unit Description UnitIndex Master Index
Function TrimBlanksLeft(InputString: String): String;
Var
i : Integer;
Begin
For i := 1 To Length(InputString) Do
Begin
If InputString[i] = ' ' Then
Begin
Delete(InputString,1,1);
End
Else
Begin
Break;
End;
End;
Result := InputString;
End;
{Trims blank spaces from the right of the string}
//Unit Description UnitIndex Master Index
Function TrimBlanksRight(InputString: String): String;
Var
{i : Integer;}
Counter : Integer;
Begin
Counter := 1;
Result := InputString;
While True Do
Begin
If SubStr(InputString,Length(InputString),1) = ' ' Then
Begin
InputString := SubStr(InputString,1,Length(InputString)-1);
End
Else
Begin
Break;
End;
Counter := Counter + 1;
If Counter > 253 Then Break;
End;
Result := InputString;
{
For i := Length(InputString) DownTo 1 Do
Begin
If InputString[i] = ' ' Then
Begin
Delete(InputString,i,1);
End
Else
Begin
Break;
End;
End;
Result := InputString;
}
End;
{Returns the database field type as a string. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason a null string is returned.}
//Unit Description UnitIndex Master Index
Function TypeField(DatabaseName, TableName, FieldName: String): String;
Var
Table : TTable;
FieldIndex : Integer;
FieldType : TFieldType;
Begin
Result := '';
If Not IsTable(DatabaseName, TableName) Then Exit;
If Not IsField(DatabaseName, TableName, FieldName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
FieldIndex :=
Table.FieldDefs.IndexOf(FieldName);
FieldType :=
Table.FieldDefs[FieldIndex].DataType;
{TFieldType
Possible Delphi 1.0 values are
ftUnknown, ftString, ftSmallint,
ftInteger, ftWord, ftBoolean,
ftFloat, ftCurrency, ftBCD, ftDate,
ftTime, ftDateTime, ftBytes, ftVarBytes,
ftBlob, ftMemo or ftGraphic
Additional Delphi 2.0 values are:
ftAutoInc
ftFmtMemo
ftParadoxOle
ftDBaseOle
ftTypedBinary
}
If FieldType=ftUnknown Then Result := 'Unknown';
If FieldType=ftString Then Result := 'String';
If FieldType=ftSmallInt Then Result := 'SmallInt';
If FieldType=ftInteger Then Result := 'Integer';
If FieldType=ftWord Then Result := 'Word';
If FieldType=ftBoolean Then Result := 'Boolean';
If FieldType=ftFloat Then Result := 'Float';
If FieldType=ftCurrency Then Result := 'Currency';
If FieldType=ftBCD Then Result := 'BCD';
If FieldType=ftDate Then Result := 'Date';
If FieldType=ftTime Then Result := 'Time';
If FieldType=ftDateTime Then Result := 'DateTime';
If FieldType=ftBytes Then Result := 'Bytes';
If FieldType=ftVarBytes Then Result := 'VarBytes';
If FieldType=ftBlob Then Result := 'Blob';
If FieldType=ftMemo Then Result := 'Memo';
If FieldType=ftGraphic Then Result := 'Graphic';
{$IFDEF WIN32}
If FieldType=ftAutoInc Then Result := 'AutoInc';
If FieldType=ftFmtMemo Then Result := 'FmtMemo';
If FieldType=ftParadoxOle Then Result := 'ParadoxOle';
If FieldType=ftDBaseOle Then Result := 'DBaseOle';
If FieldType=ftTypedBinary Then Result := 'TypedBinary';
{$ENDIF}
Except
End;
Finally
Table.Free;
End;
End;
{Returns the database field type as a string. If there
is an error a null string is returned.}
//Unit Description UnitIndex Master Index
Function TypeFieldFromDataSet(DataSet: TDataSet; FieldName: String): String;
Var
FieldIndex : Integer;
FieldType : TFieldType;
Begin
Try
DataSet.Active := True;
FieldIndex :=
DataSet.FieldDefs.IndexOf(FieldName);
FieldType :=
DataSet.FieldDefs[FieldIndex].DataType;
{TFieldType Possible values are
ftUnknown, ftString, ftSmallint,
ftInteger, ftWord, ftBoolean,
ftFloat, ftCurrency, ftBCD, ftDate,
ftTime, ftDateTime, ftBytes, ftVarBytes,
ftBlob, ftMemo or ftGraphic}
If FieldType=ftUnknown Then Result := 'Unknown';
If FieldType=ftString Then Result := 'String';
If FieldType=ftSmallInt Then Result := 'SmallInt';
If FieldType=ftInteger Then Result := 'Integer';
If FieldType=ftWord Then Result := 'Word';
If FieldType=ftBoolean Then Result := 'Boolean';
If FieldType=ftFloat Then Result := 'Float';
If FieldType=ftCurrency Then Result := 'Currency';
If FieldType=ftBCD Then Result := 'BCD';
If FieldType=ftDate Then Result := 'Date';
If FieldType=ftTime Then Result := 'Time';
If FieldType=ftDateTime Then Result := 'DateTime';
If FieldType=ftBytes Then Result := 'Bytes';
If FieldType=ftVarBytes Then Result := 'VarBytes';
If FieldType=ftBlob Then Result := 'Blob';
If FieldType=ftMemo Then Result := 'Memo';
If FieldType=ftGraphic Then Result := 'Graphic';
Except
End;
End;
{Converts String To UpperCase}
//Unit Description UnitIndex Master Index
Function Upper(InputString: String): String;
Begin
Result := UpperCase(InputString);
End;
{Executes An External Executable}
//Unit Description UnitIndex Master Index
Function WinExecute(ApToExec: String): THandle;
Begin
Result := WinExec(ConvertStringToPChar(ApToExec),SW_SHOWNORMAL);
End;
{!~ Implements final resize tuning}
//Unit Description UnitIndex Master Index
Procedure ReSizeTuner(ComponentName : String);
Begin
DelphiChecker(
RunOutsideIDE_ads,
ComponentName,
RunOutsideIDECompany_ads,
RunOutsideIDEPhone_ads,
RunOutsideIDEDate_ads);
End;
{Returns A Date N Days Different Than
The Input Date}
//Unit Description UnitIndex Master Index
Function Date_MoveNDays(
DateValue : TDateTime;
DateMovement : Integer): TDateTime;
Begin
Result := DateValue + DateMovement;
End;
{Returns The Next Day As A TDateTime}
//Unit Description UnitIndex Master Index
Function Date_NextDay(DateValue: TDateTime): TDateTime;
Begin
Result := Date_MoveNDays(DateValue,1);
End;
{Returns The Next Week As A TDateTime}
//Unit Description UnitIndex Master Index
Function Date_NextWeek(DateValue: TDateTime): TDateTime;
Begin
Result := Date_MoveNDays(DateValue,7);
End;
{Returns The Prior Day As A TDateTime}
//Unit Description UnitIndex Master Index
Function Date_PriorDay(DateValue: TDateTime): TDateTime;
Begin
Result := Date_MoveNDays(DateValue,-1);
End;
{Returns The Prior Week As A TDateTime}
//Unit Description UnitIndex Master Index
Function Date_PriorWeek(DateValue: TDateTime): TDateTime;
Begin
Result := Date_MoveNDays(DateValue,-7);
End;
{!~ Trims blank spaces from the right of the string}
//Unit Description UnitIndex Master Index
Function DBTrimBlanksRight(
DatabaseName : String;
TableName : String;
FieldName : String): Boolean;
Var
Q : TQuery;
S : String;
Begin
{ Result := False;}{zzz}
Q := TQuery.Create(nil);
Try
Q.Active := False;
Q.DatabaseName := DatabaseName;
Q.RequestLive := True;
Q.Sql.Clear;
Q.Sql.Add('Select');
Q.Sql.Add('*');
Q.Sql.Add('From');
Q.Sql.Add('"'+TableName+'"');
Q.Active := True;
Q.First;
While Not Q.EOF Do
Begin
S := Q.FieldByName(FieldName).AsString;
S := TrimBlanksRight(S);
S := TrimBlanksRight(S);
Q.Edit;
Q.FieldByName(FieldName).AsString := S;
Q.Post;
Q.Next;
End;
Result := True;
Finally
Q.Free;
End;
End;
{!~ Trims blank spaces from the Left of the string}
//Unit Description UnitIndex Master Index
Function DBTrimBlanksLeft(
DatabaseName : String;
TableName : String;
FieldName : String): Boolean;
Var
Q : TQuery;
S : String;
Begin
{ Result := False;}{zzz}
Q := TQuery.Create(nil);
Try
Q.Active := False;
Q.DatabaseName := DatabaseName;
Q.RequestLive := True;
Q.Sql.Clear;
Q.Sql.Add('Select');
Q.Sql.Add('*');
Q.Sql.Add('From');
Q.Sql.Add('"'+TableName+'"');
Q.Active := True;
Q.First;
While Not Q.EOF Do
Begin
S := Q.FieldByName(FieldName).AsString;
S := TrimBlanksLeft(S);
S := TrimBlanksLeft(S);
Q.Edit;
Q.FieldByName(FieldName).AsString := S;
Q.Post;
Q.Next;
End;
Result := True;
Finally
Q.Free;
End;
End;
{!~ Returns the field Name as a String. If there
is an error, the table doesn't exist, the field doesn't
exist or some other reason '' is returned.}
//Unit Description UnitIndex Master Index
Function DBFieldNameByNo(
DatabaseName : String;
TableName : String;
FieldNo : Integer): String;
Var
Table : TTable;
Begin
Result := '';
If Not IsTable(DatabaseName, TableName) Then Exit;
If FieldNo < 0 Then Exit;
If FieldNo >= DBNFields(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
Result := Table.FieldDefs[FieldNo].Name;
Except
End;
Finally
Table.Free;
End;
End;
{!~ Copies Table Field Names to a TStrings object, e.g.,
ListBox1.Items, Memo1.Lines.
Returns the true if successful. If there
is an error, the DatabaseName doesn't exist, the table doesn't
exist or some other reason False is returned. }
//Unit Description UnitIndex Master Index
Function DBFieldNamesToTStrings(
DatabaseName : String;
TableName : String;
Strings : TStrings): Boolean;
Var
Table : TTable;
FieldNo : Integer;
Begin
Result := False;
If Not IsTable(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
Strings.Clear;
For FieldNo := 0 To Table.FieldDefs.Count -1 Do
Begin
Strings.Add(Table.FieldDefs[FieldNo].Name);
End;
Result := True;
Except
End;
Finally
Table.Free;
End;
End;
{!~ Copies Table Key Field Names to a TStrings object.
Returns the true if successful. If there
is an error, the DatabaseName doesn't exist, the table doesn't
exist or some other reason False is returned. }
//Unit Description UnitIndex Master Index
Function DBKeyFieldNamesToTStrings(
DatabaseName : String;
TableName : String;
Strings : TStrings): Boolean;
Var
Table : TTable;
FieldNo : Integer;
Begin
Result := False;
If Not IsTable(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
Strings.Clear;
For FieldNo := 0 To Table.FieldDefs.Count -1 Do
Begin
If IsFieldKeyed(
DatabaseName,
TableName,
Table.FieldDefs[FieldNo].Name) Then
Begin
Strings.Add(Table.FieldDefs[FieldNo].Name);
End;
End;
Result := True;
Except
End;
Finally
Table.Free;
End;
End;
{!~ Inserts matching fields in a destination table.
Source Table records are deleted if the record was inserted properly.
Records unsuccessfully inserted are retained and the problems recorded
in the ErrorField.}
//Unit Description UnitIndex Master Index
Function DBInsertMatchingFields(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable,
ErrorField: string): Boolean;
Var
S : TTable;
T : TTable;
D : TQuery;
i,j,K : Integer;
Keys : TStringList;
KeyValues : TStringList;
CommonFields : TStringList;
{WhereAnd : String;}{zzz}
{CurField : String;}{zzz}
{CurValue_S : String;}{zzz}
{DFieldType : String;}{zzz}
EMessage : String;
ESuccess : String;
Begin
Result := False;
ESuccess := 'Successful';
S := TTable.Create(nil);
D := TQuery.Create(nil);
T := TTable.Create(nil);
Keys := TStringList.Create();
CommonFields := TStringList.Create();
KeyValues := TStringList.Create();
Try
Try
D.Active := False;
D.DatabaseName := DestDatabaseName;
DBKeyFieldNamesToTStrings(
SourceDatabaseName,
SourceTable,
Keys);
DBFieldNamesCommonToTStrings(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable,
CommonFields);
S.Active := False;
S.DatabaseName := SourceDatabaseName;
S.TableName := SourceTable;
S.Active := True;
S.First;
While Not S.EOF Do
Begin
Try
{Capture the key field values}
KeyValues.Clear;
For j := 0 To Keys.Count - 1 Do
Begin
KeyValues.Add(S.FieldByName(Keys[j]).AsString);
End;
If IsRecord(
DestDatabaseName,
DestinationTable,
Keys,
KeyValues)
Then
Begin
{The record already exists in the destination table}
Try
S.Edit;
S.FieldByName(ErrorField).AsString :=
'Error-Insert-Record already exists in destination table';
S.Post;
Except
End;
S.Next;
Continue;
End
Else
Begin
{The record does not exist in the destination table}
Try
EMessage := ESuccess;
S.Edit;
S.FieldByName(ErrorField).AsString := EMessage;
S.Post;
Except
End;
End;
Try
T.Active := False;
T.DatabaseName := DestDatabaseName;
T.TableName := DestinationTable;
T.Active := True;
T.Insert;
For i := 0 To CommonFields.Count - 1 Do
Begin
T.FieldByName(CommonFields[i]).AsString :=
S.FieldByName(CommonFields[i]).AsString;
End;
T.Post;
Except
If EMessage = ESuccess Then
Begin
EMessage := 'Error-Insert- Keys:';
For K := 0 To Keys.Count -1 Do
Begin
EMessage := EMessage + Keys[K]+'='+S.FieldByName(Keys[K]).AsString+', ';
End;
End;
Try
S.Edit;
S.FieldByName(ErrorField).AsString := EMessage;
S.Post;
Except
End;
End;
Except
If EMessage = ESuccess Then
Begin
EMessage := 'Error-Insert- Keys:';
For K := 0 To Keys.Count -1 Do
Begin
EMessage := EMessage + Keys[K]+'='+S.FieldByName(Keys[K]).AsString+', ';
End;
End;
Try
S.Edit;
S.FieldByName(ErrorField).AsString := EMessage;
S.Post;
Except
End;
End;
S.Next;
End;
If Not IsField(SourceDatabaseName, SourceTable, ErrorField) Then
Begin
ShowMessage('Cannot delete records from '+
SourceTable+' table because '+ErrorField+
' Field does not exist');
End
Else
Begin
D.Active := False;
D.RequestLive := True;
D.DatabaseName := SourceDatabaseName;
D.Sql.Clear;
D.Sql.Add('Delete From '+SourceTable);
D.Sql.Add('Where');
D.Sql.Add(ErrorField+' = "'+ESuccess+'"');
D.ExecSql;
D.Active := False;
End;
Result := True;
Except
If EMessage = ESuccess Then
Begin
EMessage := 'Error-Process Level- Keys:';
For K := 0 To Keys.Count -1 Do
Begin
EMessage := EMessage + Keys[K]+'='+S.FieldByName(Keys[K]).AsString+', ';
End;
End
Else
Begin
EMessage := EMessage + 'Process Error Also';
End;
Try
S.Edit;
S.FieldByName(ErrorField).AsString := EMessage;
S.Post;
Except
End;
End;
Finally
S.Free;
D.Free;
T.Free;
Keys.Free;
CommonFields.Free;
KeyValues.Free;
End;
End;
{!~ Copies Field Names shared by 2 tables to a TStrings object.
Returns true if successful. If there
is an error, the DatabaseName doesn't exist, the table doesn't
exist or some other reason False is returned. }
//Unit Description UnitIndex Master Index
Function DBFieldNamesCommonToTStrings(
DatabaseName1 : String;
TableName1 : String;
DatabaseName2 : String;
TableName2 : String;
Strings : TStrings): Boolean;
Var
List1 : TStringList;
List2 : TStringList;
i : Integer;
Begin
{ Result := False;}{zzz}
List1 := TStringList.Create();
List2 := TStringList.Create();
Try
Strings.Clear;
DBFieldNamesToTStrings(
DatabaseName1,
TableName1,
List1);
For i := 0 To List1.Count - 1 Do
Begin
List1[i] := UpperCase(List1[i]);
End;
DBFieldNamesToTStrings(
DatabaseName2,
TableName2,
List2);
For i := 0 To List2.Count - 1 Do
Begin
List2[i] := UpperCase(List2[i]);
End;
For i := 0 To List1.Count - 1 Do
Begin
If List2.IndexOf(List1[i]) <> -1 Then
Begin
Strings.Add(List1[i]);
End;
End;
Result := True;
Finally
List1.Free;
List2.Free;
End;
End;
{!~ Returns Field Names shared by 2 tables as a string.
Fields are separated by commas with no trailing comma.}
//Unit Description UnitIndex Master Index
Function DBFieldNamesCommonToString(
DatabaseName1 : String;
TableName1 : String;
DatabaseName2 : String;
TableName2 : String): String;
Var
List1 : TStringList;
List2 : TStringList;
i : Integer;
Suffix: String;
Begin
Result := '';
List1 := TStringList.Create();
List2 := TStringList.Create();
Try
DBFieldNamesToTStrings(
DatabaseName1,
TableName1,
List1);
For i := 0 To List1.Count - 1 Do
Begin
List1[i] := UpperCase(List1[i]);
End;
DBFieldNamesToTStrings(
DatabaseName2,
TableName2,
List2);
For i := 0 To List2.Count - 1 Do
Begin
List2[i] := UpperCase(List2[i]);
End;
For i := 0 To List1.Count - 1 Do
Begin
If Result = '' Then
Begin
Suffix := '';
End
Else
Begin
Suffix := ', ';
End;
If List2.IndexOf(List1[i]) <> -1 Then
Begin
Result := Result + Suffix + List1[i];
End;
End;
Finally
List1.Free;
List2.Free;
End;
End;
{!~ Returns True If The Record Exists, False Otherwise}
//Unit Description UnitIndex Master Index
Function IsRecord(
DatabaseName : String;
TableName : String;
TableKeys : TStringList;
KeyValues : TStringList): Boolean;
Var
Q : TQuery;
i : Integer;
Begin
{ Result := False;}{zzz}
Q := TQuery.Create(nil);
Try
Q.Active := False;
Q.DatabaseName := DatabaseName;
Q.RequestLive := True;
Q.Sql.Clear;
Q.Sql.Add('Select');
For i := 0 To TableKeys.Count - 1 Do
Begin
If i = (TableKeys.Count - 1) Then
Begin
Q.Sql.Add(TableKeys[i]);
End
Else
Begin
Q.Sql.Add(TableKeys[i]+',');
End;
End;
Q.Sql.Add('From');
If Pos('.DB',UpperCase(TableName)) > 0 Then
Begin
Q.Sql.Add('"'+TableName+'" ');
End
Else
Begin
Q.Sql.Add(TableName);
End;
Q.Sql.Add('Where');
For i := 0 To TableKeys.Count - 1 Do
Begin
If i <> 0 Then Q.Sql.Add('And');
Q.Sql.Add(TableKeys[i]+' = '+
DBSqlValueQuoted(DatabaseName,TableName,
TableKeys[i],KeyValues[i]));
End;
Q.Active := True;
Result := Not IsEmptyTQuery(Q);
Finally
Q.Free;
End;
End;
{!~ Returns a value for use in a sql where clause with the
appropriate Quoting of the value based on its datatype. If
an error occurs the original string value is returned unchanged}
//Unit Description UnitIndex Master Index
Function DBSqlValueQuoted(
const
DatabaseName,
TableName,
FieldName,
FieldValue: string): String;
Var
DataType : String;
Begin
Result := FieldValue;
Try
DataType := DBFieldType(DatabaseName, TableName, FieldName);
If
(DataType = 'String')
Or
(DataType = 'DateTime')
Or
(DataType = 'Date')
Or
(DataType = 'Time')
Then
Begin
If DataType <> 'String' Then
Begin
If FieldValue = '' Then
Begin
Result := ' null ';
End
Else
Begin
Result := '"'+FieldValue+'"';
End;
End
Else
Begin
Result := '"'+FieldValue+'"';
End;
End
Else
Begin
Result := FieldValue;
End;
Except
End;
End;
{!~ Returns the Windows User ID.}
//Unit Description UnitIndex Master Index
Function UserIDFromWindows: string;
Var
UserName : string;
UserNameLen : Dword;
Begin
UserNameLen := 255;
SetLength(userName, UserNameLen);
If GetUserName(PChar(UserName), UserNameLen) Then
Result := Copy(UserName,1,UserNameLen - 1)
Else
Result := 'Unknown';
End;
{$IFDEF WIN32}
{!~ Creates a new TSession object.}
//Unit Description UnitIndex Master Index
Function DBSessionCreateNew: TSession;
Var
List : TStringList;
Seed : String;
i : Integer;
Ses : String;
Begin
{ Result := nil;}{zzz}
Seed := 'Session';
Ses := Seed+'0';
List := TStringList.Create;
Try
Sessions.GetSessionNames(List);
For i := 0 To 1000 Do
Begin
Ses := Seed + IntToStr(i);
If List.IndexOf(Ses) = -1 Then Break;
End;
Result := Sessions.OpenSession(Ses);
Finally
List.Free;
End;
End;
{$ENDIF}
{!~ Returns the meaning of the given result code. Error codes are for
Delphi 1.0.}
//Unit Description UnitIndex Master Index
function ErrorMeaning (ResultCode: Integer): string;
const
NumOfEntries = 108;
type
ErrorEntry = record
Code: Integer;
Meaning: String;
end;
ErrorMeaningsArray = array [1..NumOfEntries] of ErrorEntry;
const
MeaningsArray: ErrorMeaningsArray =
{DOS errors}
((Code: 1; Meaning: 'Invalid DOS function number'),
(Code: 2; Meaning: 'File not found'),
(Code: 3; Meaning: 'Path not found'),
(Code: 4; Meaning: 'Too many open files'),
(Code: 5; Meaning: 'File access denied'),
(Code: 6; Meaning: 'Invalid file handle'),
(Code: 7; Meaning: 'Memory control blocks destroyed'),
(Code: 8; Meaning: 'Insufficient DOS memory'),
(Code: 9; Meaning: 'Invalid memory block address'),
(Code: 10; Meaning: 'Invalid DOS environment'),
(Code: 11; Meaning: 'Invalid format (DOS)'),
(Code: 12; Meaning: 'Invalid file access code'),
(Code: 13; Meaning: 'Invalid data (DOS)'),
(Code: 15; Meaning: 'Invalid drive number'),
(Code: 16; Meaning: 'Cannot remove current directory'),
(Code: 17; Meaning: 'Cannot rename across drives'),
(Code: 18; Meaning: 'No more files'),
(Code: 19; Meaning: 'Disk write-protected'),
(Code: 20; Meaning: 'Unknown unit (DOS)'),
(Code: 21; Meaning: 'Drive not ready'),
(Code: 22; Meaning: 'Unknown DOS command'),
(Code: 23; Meaning: 'CRC error'),
(Code: 24; Meaning: 'Bad request structure length'),
(Code: 25; Meaning: 'Seek error'),
(Code: 26; Meaning: 'Unknown media type'),
(Code: 27; Meaning: 'Disk sector not found'),
(Code: 28; Meaning: 'Out of paper'),
(Code: 29; Meaning: 'Write fault'),
(Code: 30; Meaning: 'Read fault'),
(Code: 31; Meaning: 'General failure'),
(Code: 32; Meaning: 'File sharing violation'),
(Code: 33; Meaning: 'File lock violation'),
(Code: 34; Meaning: 'Invalid disk change'),
(Code: 35; Meaning: 'File control block unavailable'),
(Code: 36; Meaning: 'Sharing buffer overflow'),
(Code: 37; Meaning: 'Code page mismatch'),
(Code: 38; Meaning: 'Error handling EOF'),
(Code: 39; Meaning: 'Handle disk full'),
(Code: 50; Meaning: 'Network request not supported'),
(Code: 51; Meaning: 'Remote computer not listening'),
(Code: 52; Meaning: 'Duplicate name on network'),
(Code: 53; Meaning: 'Network name not found'),
(Code: 54; Meaning: 'Network busy'),
(Code: 55; Meaning: 'Network device no longer exists'),
(Code: 56; Meaning: 'NetBIOS command limit exceeded'),
(Code: 57; Meaning: 'Network adaptor error'),
(Code: 58; Meaning: 'Incorrect network response'),
(Code: 59; Meaning: 'Unexpected network error'),
(Code: 60; Meaning: 'Incompatible remote adaptor'),
(Code: 61; Meaning: 'Print queue full'),
(Code: 62; Meaning: 'Not enough space for print file'),
(Code: 63; Meaning: 'Print file deleted'),
(Code: 64; Meaning: 'Network name deleted'),
(Code: 65; Meaning: 'Access denied'),
(Code: 66; Meaning: 'Network device type incorrect'),
(Code: 67; Meaning: 'Network name not found'),
(Code: 68; Meaning: 'Network name limit exceeded'),
(Code: 69; Meaning: 'NetBIOS session limit exceeded'),
(Code: 70; Meaning: 'Temporarily paused'),
(Code: 71; Meaning: 'Network request not accepted'),
(Code: 72; Meaning: 'Print/disk redirection paused'),
(Code: 80; Meaning: 'File already exists'),
(Code: 82; Meaning: 'Cannot make directory entry'),
(Code: 83; Meaning: 'Fail on interrupt 24'),
(Code: 84; Meaning: 'Too many redirections'),
(Code: 85; Meaning: 'Duplicate redirection'),
(Code: 86; Meaning: 'Invalid password'),
(Code: 87; Meaning: 'Invalid parameter'),
(Code: 88; Meaning: 'Network data fault'),
{I/O errors}
(Code: 100; Meaning: 'Disk read error'),
(Code: 101; Meaning: 'Disk write error'),
(Code: 102; Meaning: 'File not assigned'),
(Code: 103; Meaning: 'File not open'),
(Code: 104; Meaning: 'File not open for input'),
(Code: 105; Meaning: 'File not open for output'),
(Code: 106; Meaning: 'Invalid numeric format'),
{Critical errors (Real or protected mode only)}
(Code: 150; Meaning: 'Disk is write protected'),
(Code: 151; Meaning: 'Unknown unit'),
(Code: 152; Meaning: 'Drive not ready'),
(Code: 153; Meaning: 'Unknown DOS command'),
(Code: 154; Meaning: 'CRC error in data'),
(Code: 155; Meaning: 'Bad drive request struct length'),
(Code: 156; Meaning: 'Disk seek error'),
(Code: 157; Meaning: 'Unknown media type'),
(Code: 158; Meaning: 'Sector not found'),
(Code: 159; Meaning: 'Printer out of paper'),
(Code: 160; Meaning: 'Device write fault'),
(Code: 161; Meaning: 'Device read fault'),
(Code: 162; Meaning: 'Hardware failure'),
{Fatal errors}
(Code: 200; Meaning: 'Division by zero'),
(Code: 201; Meaning: 'Range check error'),
(Code: 202; Meaning: 'Stack overflow error'),
(Code: 203; Meaning: 'Heap overflow error'),
(Code: 204; Meaning: 'Invalid pointer operation'),
(Code: 205; Meaning: 'Floating point overflow'),
(Code: 206; Meaning: 'Floating point underflow'),
(Code: 207; Meaning: 'Invalid floating pt. operation'),
(Code: 208; Meaning: 'Overlay manager not installed'),
(Code: 209; Meaning: 'Overlay file read error'),
(Code: 210; Meaning: 'Object not initialised'),
(Code: 211; Meaning: 'Call to abstract method'),
(Code: 212; Meaning: 'Stream registration error'),
(Code: 213; Meaning: 'TCollection index out of range'),
(Code: 214; Meaning: 'TCollection overflow error'),
(Code: 215; Meaning: 'Arithmetic overflow error'),
(Code: 216; Meaning: 'General Protection Fault'),
(Code: 217; Meaning: 'Unhandled exception'),
(Code: 219; Meaning: 'Invalid typecast'));
var
Low, High, Mid, Diff: Integer;
begin
Low := 1;
High := NumOfEntries;
while Low <= High do
begin
Mid := (Low + High) div 2;
Diff := MeaningsArray[Mid].Code - ResultCode;
if Diff < 0 then Low := Mid + 1 else
if Diff > 0 then High := Mid - 1 else
begin {found it}
Result := MeaningsArray[Mid].Meaning;
Exit;
end;
end; {while}
Result := 'Error ' + IntToStr(ResultCode) +
' (meaning unknown)';
end;
{!~ Returns The Number Of Days In The Month}
//Unit Description UnitIndex Master Index
Function Date_DaysInMonth(DateValue: TDateTime): Integer;
var
YearIn : Word;
MonthIn : Word;
DayIn : Word;
YearNew : Word;
MonthNew : Word;
DayNew : Word;
Counter : Integer;
NewDate : TDateTime;
Begin
Result := 30;
Try
DecodeDate(DateValue, YearIn, MonthIn, DayIn);
NewDate := EncodeDate(YearIn, MonthIn, 26);
For Counter := 26 To 32 Do
Begin
NewDate := NewDate+1;
DecodeDate(NewDate, YearNew, MonthNew, DayNew);
If MonthNew <> MonthIn Then
Begin
DecodeDate(NewDate-1, YearNew, MonthNew, DayNew);
Result := DayNew;
Break;
End;
End;
Except
End;
End;
{!~ Returns The Last Day Of The Month}
//Unit Description UnitIndex Master Index
Function Date_LastDayOfMonth(DateValue: TDateTime): TDateTime;
Var
LastDay : String;
Begin
{ Result := DateValue;}{zzz}
LastDay := IntToStr(Date_DaysInMonth(DateValue));
Result := StrToDate(
FormatDateTime('mm',DateValue)+
'/'+
LastDay+
'/'+
FormatDateTime('yyyy',DateValue));
End;
{!~ ReKeys a Paradox Table to the first N fields}
//Unit Description UnitIndex Master Index
Function DBParadoxCreateNKeys(
DatabaseName : String;
TableName : String;
NKeys : Integer): Boolean;
Var
T : TTable;
T2 : TTable;
i : Integer;
TempDBName : String;
TempTblNam : String;
TempTblStub: String;
KeysString : String;
Begin
Result := False;
{Select a temporary table name}
TempTblStub := 'qrz';
TempDBName := DatabaseName;
TempTblNam := '';
For i := 1 To 100 Do
Begin
TempTblNam := TempTblStub+StringPad(IntToStr(i),'0',3,False)+'.Db';
If Not IsTable(TempDBName,TempTblNam) Then
Begin
Break;
End
Else
Begin
If i = 100 Then
Begin
DBDeleteTable(
TempDBName,
TempTblNam);
End;
End;
End;
T := TTable.Create(nil);
T2 := TTable.Create(nil);
Try
Try
T.Active := False;
T.DatabaseName := DatabaseName;
T.TableName := TableName;
T.Active := True;
T2.Active := False;
T2.DatabaseName := TempDBName;
T2.TableName := TempTblNam;
T2.FieldDefs.Assign(T.FieldDefs);
T2.IndexDefs.Clear;
KeysString := '';
For i := 0 To NKeys - 1 Do
Begin
If i > 0 Then
Begin
KeysString := KeysString + ';';
End;
KeysString :=
KeysString +
DBFieldNameByNo(
DatabaseName,
TableName,
i);
End;
T2.IndexDefs.Add('',KeysString,[ixPrimary]);
T2.CreateTable;
T2.Active := False;
T.Active := False;
AddTables(
DatabaseName,
TableName,
TempDBName,
TempTblNam);
DBDeleteTable(DatabaseName,TableName);
T2.Active := True;
T.DatabaseName := DatabaseName;
T.TableName := TableName;
T.FieldDefs.Assign(T2.FieldDefs);
T.IndexDefs.Clear;
T.IndexDefs.Add('',KeysString,[ixPrimary]);
T.CreateTable;
T2.Active := False;
T.Active := False;
AddTables(
TempDBName,
TempTblNam,
DatabaseName,
TableName);
DBDeleteTable(
TempDBName,
TempTblNam);
Result := True;
Except
ShowMessage('Error in Function DBParadoxCreateNKeys');
End;
Finally
T.Free;
T2.Free;
End;
End;
//Unit Description UnitIndex Master Index
Function WinExecute32(
FileName : String;
Visibility : integer):integer;
var
zAppName:array[0..512] of char;
zCurDir:array[0..255] of char;
WorkDir:String;
StartupInfo:TStartupInfo;
ProcessInfo:TProcessInformation;
begin
StrPCopy(zAppName,FileName);
GetDir(0,WorkDir);
StrPCopy(zCurDir,WorkDir);
FillChar(StartupInfo,Sizeof(StartupInfo),#0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName, { pointer to command line string }
nil, { pointer to process security attributes}
nil, { pointer to thread security attributes }
false, { handle inheritance flag }
CREATE_NEW_CONSOLE or { creation flags }
NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo) then Result := -1 { pointer to PROCESS_INF }
else
begin
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Cardinal(Result));
end;
end;
{!~ Loads a known file type using the appropriate
executable, e.g., WinWord for *.Doc, Paradox for *.db.}
//Unit Description UnitIndex Master Index
Function ExecuteKnownFileType(
Handle : THandle;
FileName : String): Boolean;
Var
PFileName : array[0..128] of Char;
PFilePath : array[0..128] of Char;
FilePath : String;
Begin
{ Result := False;}{zzz}
FilePath := ExtractFilePath(FileName);
StrPCopy(PFileName,FileName);
StrPCopy(PFilePath,FilePath);
ShellExecute(
Handle,
nil,
PFileName,
nil,
PFilePath,
SW_SHOWNORMAL);
Result := True;
End;
{!~Executes an executable with no parameters}
//Unit Description UnitIndex Master Index
Function ExecuteExe(FileName : String): Boolean;
Begin
{ Result := False;}{zzz}
ShellExecute(
Application.Handle,
nil,
ConvertStringToPChar(FileName),
nil,
nil,
SW_SHOWNORMAL);
Result := True;
End;
{!~Executes an executable with parameters}
//Unit Description UnitIndex Master Index
Function ExecuteExeParams(
FileName : String;
ParamString : String;
DefaultDir : String): Boolean;
Begin
{ Result := False;}{zzz}
ShellExecute(
Application.Handle,
nil,
ConvertStringToPChar(FileName),
ConvertStringToPChar(ParamString),
ConvertStringToPChar(DefaultDir),
SW_SHOWNORMAL);
Result := True;
End;
//Unit Description UnitIndex Master Index
Procedure PurgeInternetCache(
MainForm : TForm;
WinDir : String;
IntTempDir : String);
Var
CacheNum : Integer;
c,i : Integer;
CurCache : String;
FileString : String;
FileList : TFileListBox;
StringList : TStringList;
CacheDir : String;
Begin
FileList := TFileListBox.Create(nil);
FileList.Height := 1;
FileList.Width := 1;
FileList.Parent := MainForm;
StringList := TStringList.Create();
Try
CacheNum := 4;
For c := 1 To CacheNum Do
Begin
CurCache := 'Cache'+ IntToStr(c);
CacheDir := WinDir+'\'+IntTempDir+'\'+CurCache;
FileList.Directory := CacheDir;
FileList.Mask := '*.*';
StringList.Clear;
StringList.Assign(FileList.Items);
For i := 0 To StringList.Count - 1 Do
Begin
FileString := CacheDir+'\'+StringList[i];
SetFileAttributes(
PChar(FileString),
FILE_ATTRIBUTE_NORMAL);
DeleteFile(PChar(FileString));
End;
End;
Finally
FileList.Free;
StringList.Free;
End;
End;
{!~ Returns the ini value for a variable (IntegerName)
in the ini section (IniSection) of the ini file (TheIniFile).}
//Unit Description UnitIndex Master Index
Function IniGetIntegerValue(
TheIniFile : String;
IniSection : String;
IntegerName : String;
DefaultInteger : Integer): Integer;
Var
TheIni : TIniFile;
Begin
TheIni := TIniFile.Create(TheIniFile);
Try
Result :=
TheIni.ReadInteger(
IniSection,
IntegerName,
DefaultInteger);
Finally
TheIni.Free;
End;
End;
{!~ Returns the ini value for a variable (StringName)
in the ini section (IniSection) of the ini file (TheIniFile).}
//Unit Description UnitIndex Master Index
Function IniGetStringValue(
TheIniFile : String;
IniSection : String;
StringName : String;
DefaultString : String): String;
Var
TheIni : TIniFile;
Begin
TheIni := TIniFile.Create(TheIniFile);
Try
Result :=
TheIni.ReadString(
IniSection,
StringName,
DefaultString);
If Result = '' Then
Begin
Result := DefaultString;
End;
Finally
TheIni.Free;
End;
End;
{!~ Sets a variable (IntegerName) in the ini section (IniSection)
of the ini file (TheIniFile) with the value (IntegerValue).
If an exception is thrown the function returns False,
True otherwise.}
//Unit Description UnitIndex Master Index
Function IniSetIntegerValue(
TheIniFile : String;
IniSection : String;
IntegerName : String;
IntegerValue : Integer): Boolean;
Var
TheIni : TIniFile;
Begin
{ Result := False;}{zzz}
TheIni := TIniFile.Create(TheIniFile);
Try
Try
TheIni.WriteInteger(
IniSection,
IntegerName,
IntegerValue);
Result := True;
Except
Result := False;
End;
Finally
TheIni.Free;
End;
End;
{!~ Sets a variable (StringName) in the ini section (IniSection)
of the ini file (TheIniFile) with the value (StringValue).
If an exception is thrown the function returns False,
True otherwise.}
//Unit Description UnitIndex Master Index
Function IniSetStringValue(
TheIniFile : String;
IniSection : String;
StringName : String;
StringValue : String): Boolean;
Var
TheIni : TIniFile;
Begin
{ Result := False;}{zzz}
TheIni := TIniFile.Create(TheIniFile);
Try
Try
TheIni.WriteString(
IniSection,
StringName,
StringValue);
Result := True;
Except
Result := False;
End;
Finally
TheIni.Free;
End;
End;
{!~ Returns The File size in bytes. Does not work on a text file.}
//Unit Description UnitIndex Master Index
Function FileNotTextSize(FileString: String): LongInt;
Var
f: file of Byte;
size : Longint;
Begin
Try
AssignFile(f, FileString);
Reset(f);
size := FileSize(f);
CloseFile(f);
Result := Size;
Except
Result := 0;
End;
End;
//Unit Description UnitIndex Master Index
Procedure IniUpdateFromTStringList(
TheIniFile : String;
IniSection : String;
StringListName : String;
CountField : String;
StringList : TStringList);
Var
TheIni : TIniFile;
i : Integer;
Begin
TheIni := TIniFile.Create(TheIniFile);
Try
TheIni.EraseSection(IniSection);
TheIni.WriteString(
IniSection,
CountField,
IntToStr(StringList.Count));
For i := 0 To StringList.Count - 1 Do
Begin
TheIni.WriteString(
IniSection,
StringListName+'['+intToStr(i)+']',
StringList[i]);
End;
Finally
TheIni.Free;
End;
End;
//Unit Description UnitIndex Master Index
Procedure IniUpdateTStringList(
TheIniFile : String;
IniSection : String;
StringListName : String;
CountField : String;
StringList : TStringList);
Var
TheIni : TIniFile;
i : Integer;
{CountString : String;}
Count : Integer;
Begin
TheIni := TIniFile.Create(TheIniFile);
Try
{ Count := 0;}{zzz}
Count :=
IniGetIntegerValue(
TheIniFile,
IniSection,
CountField,
0);
StringList.Clear;
For i := 0 To Count - 1 Do
Begin
StringList.Add(
TheIni.ReadString(
IniSection,
StringListName+'['+intToStr(i)+']',
''));
End;
Finally
TheIni.Free;
End;
End;
{!~ Replace values in a field (NewValueField) with NewValue
based on a where condition in CurrentValueField with a value
of CurrentValue}
//Unit Description UnitIndex Master Index
procedure DBGlobalStringFieldChangeWhere2(
const DatabaseName,
TableName,
NewValueField,
NewValue,
CurrentValueField,
CurrentValue: string);
var
Query : TQuery;
CValueQuoted : String;
begin
Query := TQuery.Create(nil);
Try
CValueQuoted := DBSqlValueQuoted(
DatabaseName,
TableName,
CurrentValueField,
CurrentValue);
Query.Active := False;
Query.DatabaseName := DatabaseName;
Query.RequestLive := True;
Query.RequestLive := True;
Query.Sql.Clear;
Query.Sql.Add('UpDate');
Query.Sql.Add('"'+TableName+'"');
Query.Sql.Add('Set');
Query.Sql.Add(
'"'+TableName+'"."'+NewValueField+'"'+
' = '+
'"'+NewValue+'"');
If Not (CurrentValue = '') Then
Begin
Query.Sql.Add('Where');
Query.Sql.Add(
'"'+TableName+'"."'+CurrentValueField+'"'+
' = '+
CValueQuoted);
End;
{Query.Sql.SaveToFile(ExtractFileNameNoExt(TableName)+'.sql');}
Query.ExecSql;
Query.Active := False;
Finally
Query.Free;
End;
End;
{!~ Returns The Last Day Of The Month}
//Unit Description UnitIndex Master Index
Function Date_FirstDayOfNextMonth(DateValue: TDateTime): TDateTime;
Begin
Try
Result := Date_LastDayOfMonth(DateValue)+1;
Except
Result := DateValue;
End;
End;
{!~ Returns True if DateString is a valid date,
False otherwise.}
//Unit Description UnitIndex Master Index
Function IsDate(DateString: String): Boolean;
{Var}
{D : TDateTime;}
Begin
{ Result := False;}{zzz}
Try
{D := }StrToDateTime(DateString);
Result := True;
Except
Result := False;
End;
End;
{Returns a time delta in minutes}
//Unit Description UnitIndex Master Index
Function TimeDeltaInMinutes(
StartDate : TDateTime;
EndDate : TDateTime): Double;
Var
Hour : Word;
Min : Word;
Sec : Word;
MSec : Word;
Delta : TDateTime;
Begin
{ Result := 0;}{zzz}
Try
Delta := EndDate - StartDate;
DecodeTime(Delta, Hour, Min, Sec, MSec);
Result := (Hour*60)+Min;
Except
Result := 0;
End;
End;
{Returns a time delta in seconds}
//Unit Description UnitIndex Master Index
Function TimeDeltaInSeconds(
StartDate : TDateTime;
EndDate : TDateTime): Double;
Var
Hour : Word;
Min : Word;
Sec : Word;
MSec : Word;
Delta : TDateTime;
Begin
{ Result := 0;}{zzz}
Try
Delta := EndDate - StartDate;
DecodeTime(Delta, Hour, Min, Sec, MSec);
Result := (((Hour*60)+Min)*60)+Sec;
Except
Result := 0;
End;
End;
{Returns a time delta in Milliseconds}
//Unit Description UnitIndex Master Index
Function TimeDeltaInMSeconds(
StartDate : TDateTime;
EndDate : TDateTime): Double;
Var
Hour : Word;
Min : Word;
Sec : Word;
MSec : Word;
Delta : TDateTime;
Begin
{ Result := 0;}{zzz}
Try
Delta := EndDate - StartDate;
DecodeTime(Delta, Hour, Min, Sec, MSec);
Result := (((((Hour*60)+Min)*60)+Sec)*1000)+MSec;
Except
Result := 0;
End;
End;
{!~ Returns The Files Date Time Stamp as TDateTime.
Returns 0 if there is an error}
//Unit Description UnitIndex Master Index
Function FileDate(FileString: String): TDateTime;
Begin
Result := 0;
Try
If Not FileExists(FileString) Then Exit;
Result := FileDateToDateTime(FileAge(FileString));
Except
Result := 0;
End;
End;
{!~ Returns True is the filoe dates are the same, False otherwise.}
//Unit Description UnitIndex Master Index
Function FileDatesSame(FileString1,FileString2: String): Boolean;
Begin
{The default return value has been set to true because
this routine will frequently be used for self installing executables.
This default would eliminate a run away process if errors occur.}
{ Result := True;}{zzz}
Try
If FileDate(FileString1)=FileDate(FileString2) Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
Except
Result := True;
End;
End;
{Triggers an Executable to update itself.
Don't worry about the handle parameter,
just pass HANDLE which is the applications
handle. This can be run in the Application's
Main Form Create method.}
//Unit Description UnitIndex Master Index
Function ExecutableUpdate(
ExecutablePath : String;
ExecutableName : String;
InstallPath : String;
Handle : THandle): Boolean;
Var
Bat : TStringList;
Begin
Result := False;
If IsFile(ExecutablePath+ExecutableName+'.bat') Then
DeleteFile(PChar(ExecutablePath+ExecutableName+'.bat'));
If Not IsFile(ExecutablePath+ExecutableName+'.exe') Then Exit;
If Not IsFile(InstallPath+ExecutableName+'.exe') Then Exit;
If UpperCase(ExecutablePath+ExecutableName+'.exe') =
UpperCase(InstallPath +ExecutableName+'.exe')
Then Exit;
If FileDatesSame(
ExecutablePath+ExecutableName+'.exe',
InstallPath +ExecutableName+'.exe') Then Exit;
If IsFile(ExecutablePath+ExecutableName+'.old') Then
DeleteFile(PChar(ExecutablePath+ExecutableName+'.old'));
Bat := TStringList.Create();
Try
Bat.Clear;
Bat.Add('@ECHO OFF');
Bat.Add('REN ' +
ExecutableName+
'.exe ' +
ExecutableName+
'.old');
Bat.Add('Copy ' +
InstallPath +
ExecutableName+
'.exe ' +
ExecutablePath+
ExecutableName+
'.exe');
Bat.Add('START ' +
ExecutablePath+
ExecutableName+
'.exe');
Bat.SaveToFile(
ExecutablePath+
ExecutableName+
'.bat');
Msg('The Software is going to be upgraded');
ExecuteKnownFileType(
Handle,
ExecutablePath+
ExecutableName+
'.bat');
Result := True;
Finally
Bat.Clear;
If Result Then Halt;
End;
End;
//Unit Description UnitIndex Master Index
Procedure ImageRotateDetail(
Image : TImage;
Timer : TTimer;
Frames : Integer;
Interval : Integer;
Transparent : Boolean;
RotateHoriz : Boolean;
RotateVert : Boolean;
QuarterCycles : Integer;
Const MinTop : Integer;
Const MinLeft : Integer;
MaxWidth : Integer;
MaxHeight : Integer;
MinWidth : Integer;
MinHeight : Integer;
StartMaxHoriz : Boolean;
StartMaxVert : Boolean);
Var
HSmaller : Boolean;
VSmaller : Boolean;
HSmaller_I : Integer;
VSmaller_I : Integer;
QuarterCycle : Integer;
HStepDistance : Double;
VStepDistance : Double;
RealFrames : Integer;
HDelta : Integer;
VDelta : Integer;
MinDelta : Integer;
HalfMinDelta : Integer;
NewLeft : Integer;
NewTop : Integer;
NewWidth : Integer;
NewHeight : Integer;
NewStep : Integer;
CurrentStep : Integer;
QCycles : Integer;
MaxHght : Integer;
MaxWdth : Integer;
Begin
If Image.Tag = 0 Then
Begin
{This is the start and the time to initialize the process}
Image.IncrementalDisplay := False;
Image.Transparent := Transparent;
Image.Stretch := True;
Image.Align := alNone;
Timer.Interval := Interval;
Timer.Enabled := True;
Timer.Tag := 0;
QuarterCycle := 0;
QCycles := QuarterCycles;
{Set Horizontal start size and direction}
HSmaller := StartMaxHoriz;
If HSmaller Then
Begin
Image.Left := MinLeft;
Image.Width := MaxWidth;
HSmaller_I := 1;
End
Else
Begin
Image.Left := MinLeft+((MaxWidth-MinWidth) div 2);
Image.Width := MinWidth;
HSmaller_I := 2;
End;
{Set Vertical start size and direction}
VSmaller := StartMaxVert;
If VSmaller Then
Begin
Image.Top := MinTop;
Image.Height := MaxHeight;
VSmaller_I := 1;
End
Else
Begin
Image.Top := MinTop+((MaxHeight-MinHeight) div 2);
Image.Height := MinHeight;
VSmaller_I := 2;
End;
Image.Tag :=
StrToInt(
'1'+
StringPad(IntToStr(QCycles),'0',3,False)+
StringPad(IntToStr(QuarterCycle),'0',3,False)+
'0'+
IntToStr(HSmaller_I)+
IntToStr(VSmaller_I));
NewStep := 1;
If MaxHeight > 999 Then MaxHeight := 999;
If MaxWidth > 999 Then MaxWidth := 999;
Timer.Tag :=
StrToInt(
'1'+
StringPad(IntToStr(MaxHeight),'0',3,False)+
StringPad(IntToStr(MaxWidth), '0',3,False)+
StringPad(IntToStr(NewStep), '0',3,False));
{ NewStep := 2;}{zzz}
Image.Visible := True;
End;
MaxHght :=
StrToInt(SubStr(
StringPad(IntToStr(Timer.Tag),'0',10,False), 2,3));
MaxWdth :=
StrToInt(SubStr(
StringPad(IntToStr(Timer.Tag),'0',10,False), 5,3));
CurrentStep :=
StrToInt(SubStr(
StringPad(IntToStr(Timer.Tag),'0',10,False), 8,3));
HDelta := MaxWdth - MinWidth;
VDelta := MaxHght - MinHeight;
If HDelta < VDelta Then MinDelta := HDelta Else MinDelta := VDelta;
HalfMinDelta := MinDelta div 2;
RealFrames := Frames;
{The minimum Frames is set at 3}
If RealFrames < 3 Then RealFrames := 3;
{The minimum stepdistance is 2}
If RealFrames > (HalfMinDelta div 2) Then
RealFrames := (HalfMinDelta div 2);
{The horizontal step distance}
HStepDistance := ((HDelta/2)/RealFrames);
{The Vertical step distance}
VStepDistance := ((VDelta/2)/RealFrames);
QCycles := StrToInt(SubStr(IntToStr(Image.Tag), 2,3));
QuarterCycle := StrToInt(SubStr(IntToStr(Image.Tag), 5,3));
HSmaller_I := StrToInt(SubStr(IntToStr(Image.Tag), 9,1));
VSmaller_I := StrToInt(SubStr(IntToStr(Image.Tag),10,1));
HSmaller := (HSmaller_I = 1);
VSmaller := (VSmaller_I = 1);
If RotateHoriz Then
Begin
If HSmaller Then
Begin
NewWidth :=
HDelta-
StrToInt(
FormatFloat(
'0',
Round(((CurrentStep * HStepDistance * 2)+MinWidth))));
End
Else
Begin
NewWidth :=
StrToInt(
FormatFloat(
'0',
Round(((CurrentStep * HStepDistance * 2)+MinWidth))));
End;
NewWidth := Abs(NewWidth);
NewLeft := (MaxWdth - NewWidth) div 2;
End
Else
Begin
NewWidth := Image.Width;
NewLeft := Image.Left;
NewWidth := Abs(NewWidth);
End;
If RotateVert Then
Begin
If VSmaller Then
Begin
NewHeight :=
VDelta -
StrToInt(
FormatFloat(
'0',
Round(((CurrentStep * VStepDistance * 2)+MinHeight))));
End
Else
Begin
NewHeight :=
StrToInt(
FormatFloat(
'0',
Round(((CurrentStep * VStepDistance * 2)+MinHeight))));
End;
NewHeight := Abs(NewHeight);
NewTop := (MaxHght - NewHeight) div 2;
End
Else
Begin
NewHeight := Image.Height;
NewTop := Image.Top;
NewHeight := Abs(NewHeight);
End;
Image.Left := Abs(NewLeft);
Image.Top := Abs(NewTop);
Image.Width := Abs(NewWidth);
Image.Height := Abs(NewHeight);
Image.Refresh;
If CurrentStep <= 1 Then
Begin
NewStep := 2;
End
Else
Begin
If CurrentStep >= RealFrames Then
Begin
NewStep := 1;
HSmaller := Not HSmaller;
If HSmaller Then
Begin
HSmaller_I := 1;
End
Else
Begin
HSmaller_I := 2;
End;
VSmaller := Not VSmaller;
If VSmaller Then
Begin
VSmaller_I := 1;
End
Else
Begin
VSmaller_I := 2;
End;
QuarterCycle := QuarterCycle + 1;
End
Else
Begin
NewStep := CurrentStep + 1;
End;
End;
Timer.Tag :=
StrToInt(
'1'+
StringPad(IntToStr(MaxHght),'0',3,False)+
StringPad(IntToStr(MaxWdth),'0',3,False)+
StringPad(IntToStr(NewStep),'0',3,False));
If QCycles = 0 Then QuarterCycle := 1;
If (QuarterCycle >= QCycles) and
(Not (QCycles = 0)) Then
Begin
Image.Tag := 0;
Timer.Enabled := False;
End
Else
Begin
Image.Tag :=
StrToInt(
'1'+
StringPad(IntToStr(QCycles),'0',3,False)+
StringPad(IntToStr(QuarterCycle),'0',3,False)+
'0'+
IntToStr(HSmaller_I)+
IntToStr(VSmaller_I));
End;
End;
//Unit Description UnitIndex Master Index
Procedure ImageFlipHoriz(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Const MinLeft : Integer;
Cycles : Integer);
Begin
ImageRotateDetail(
Image, {Image : TImage;}
Timer, {Timer : TTimer;}
15, {Frames : Integer;}
60, {Interval : Integer;}
Transparent, {Transparent : Boolean;}
True, {RotateHoriz : Boolean;}
False, {RotateVert : Boolean;}
2*Cycles, {QuarterCycles : Integer;}
Image.Top, {Const MinTop : Integer;}
MinLeft, {Const MinLeft : Integer;}
Image.Width, {Const MaxWidth : Integer;}
Image.Height, {Const MaxHeight: Integer;}
0, {MinWidth : Integer;}
0, {MinHeight : Integer;}
True, {StartMaxHoriz : Boolean;}
True); {StartMaxVert : Boolean);}
End;
//Unit Description UnitIndex Master Index
Procedure ImageFlipVert(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Const MinTop : Integer;
Cycles : Integer);
Begin
ImageRotateDetail(
Image, {Image : TImage;}
Timer, {Timer : TTimer;}
15, {Frames : Integer;}
60, {Interval : Integer;}
Transparent, {Transparent : Boolean;}
False, {RotateHoriz : Boolean;}
True, {RotateVert : Boolean;}
2*Cycles, {QuarterCycles : Integer;}
MinTop, {Const MinTop : Integer;}
Image.Left, {Const MinLeft : Integer;}
Image.Width, {Const MaxWidth : Integer;}
Image.Height, {Const MaxHeight: Integer;}
0, {MinWidth : Integer;}
0, {MinHeight : Integer;}
True, {StartMaxHoriz : Boolean;}
True); {StartMaxVert : Boolean);}
End;
//Unit Description UnitIndex Master Index
Procedure ImageFadeAway(
Image : TImage;
Timer : TTimer;
Transparent : Boolean);
Begin
ImageRotateDetail(
Image, {Image : TImage;}
Timer, {Timer : TTimer;}
15, {Frames : Integer;}
60, {Interval : Integer;}
Transparent, {Transparent : Boolean;}
True, {RotateHoriz : Boolean;}
True, {RotateVert : Boolean;}
1, {QuarterCycles : Integer;}
Image.Top, {Const MinTop : Integer;}
Image.Left, {Const MinLeft : Integer;}
Image.Width, {Const MaxWidth : Integer;}
Image.Height, {Const MaxHeight: Integer;}
0, {MinWidth : Integer;}
0, {MinHeight : Integer;}
True, {StartMaxHoriz : Boolean;}
True); {StartMaxVert : Boolean);}
End;
//Unit Description UnitIndex Master Index
Procedure ImageFadeIn(
Image : TImage;
Timer : TTimer;
Transparent : Boolean);
Begin
ImageRotateDetail(
Image, {Image : TImage;}
Timer, {Timer : TTimer;}
15, {Frames : Integer;}
60, {Interval : Integer;}
Transparent, {Transparent : Boolean;}
True, {RotateHoriz : Boolean;}
True, {RotateVert : Boolean;}
1, {QuarterCycles : Integer;}
Image.Parent.ClientRect.Top, {Const MinTop : Integer;}
Image.Parent.ClientRect.Left, {Const MinLeft : Integer;}
Image.Parent.ClientRect.Right-Image.Parent.ClientRect.Left,
Image.Parent.ClientRect.Bottom-Image.Parent.ClientRect.Top,
0, {MinWidth : Integer;}
0, {MinHeight : Integer;}
False, {StartMaxHoriz : Boolean;}
False); {StartMaxVert : Boolean);}
End;
//Unit Description UnitIndex Master Index
Procedure ImageFlutterHorizDetail(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Const MinTop : Integer;
Const MinLeft : Integer;
MaxWidth : Integer;
MaxHeight : Integer;
MinWidth : Integer;
MinHeight : Integer;
Cycles : Integer);
Begin
ImageRotateDetail(
Image, {Image : TImage;}
Timer, {Timer : TTimer;}
15, {Frames : Integer;}
60, {Interval : Integer;}
Transparent, {Transparent : Boolean;}
True, {RotateHoriz : Boolean;}
False, {RotateVert : Boolean;}
2*Cycles, {QuarterCycles : Integer;}
MinTop, {Const MinTop : Integer;}
MinLeft, {Const MinLeft : Integer;}
MaxWidth, {Const MaxWidth : Integer;}
MaxHeight, {Const MaxHeight: Integer;}
MinWidth, {MinWidth : Integer;}
MinHeight, {MinHeight : Integer;}
True, {StartMaxHoriz : Boolean;}
True); {StartMaxVert : Boolean);}
End;
//Unit Description UnitIndex Master Index
Procedure ImageFlutterHoriz(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Cycles : Integer);
Begin
ImageFlutterHorizDetail(
Image,
Timer,
Transparent,
Image.Parent.ClientRect.Top+1,
Image.Parent.ClientRect.Left+1,
(Image.Parent.ClientRect.Right-Image.Parent.ClientRect.Left)-2,
(Image.Parent.ClientRect.Bottom-Image.Parent.ClientRect.Top)-2,
(((Image.Parent.ClientRect.Right-Image.Parent.ClientRect.Left-2)*5) div 6),
0,
Cycles);
End;
//Unit Description UnitIndex Master Index
Procedure ImageFlutterVertDetail(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Const MinTop : Integer;
Const MinLeft : Integer;
MaxWidth : Integer;
MaxHeight : Integer;
MinWidth : Integer;
MinHeight : Integer;
Cycles : Integer);
Begin
ImageRotateDetail(
Image, {Image : TImage;}
Timer, {Timer : TTimer;}
15, {Frames : Integer;}
60, {Interval : Integer;}
Transparent, {Transparent : Boolean;}
False, {RotateHoriz : Boolean;}
True, {RotateVert : Boolean;}
2*Cycles, {QuarterCycles : Integer;}
MinTop, {Const MinTop : Integer;}
MinLeft, {Const MinLeft : Integer;}
MaxWidth, {Const MaxWidth : Integer;}
MaxHeight, {Const MaxHeight: Integer;}
MinWidth, {MinWidth : Integer;}
MinHeight, {MinHeight : Integer;}
True, {StartMaxHoriz : Boolean;}
True); {StartMaxVert : Boolean);}
End;
//Unit Description UnitIndex Master Index
Procedure ImageFlutterVert(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Cycles : Integer);
Begin
ImageFlutterVertDetail(
Image,
Timer,
Transparent,
Image.Parent.ClientRect.Top+1,
Image.Parent.ClientRect.Left+1,
(Image.Parent.ClientRect.Right-Image.Parent.ClientRect.Left)-2,
(Image.Parent.ClientRect.Bottom-Image.Parent.ClientRect.Top)-2,
0,
(((Image.Parent.ClientRect.Bottom-Image.Parent.ClientRect.Top-2)*5) div 6),
Cycles);
End;
//Unit Description UnitIndex Master Index
Procedure ImageFadeInAndOutDetail(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Const MinTop : Integer;
Const MinLeft : Integer;
MaxWidth : Integer;
MaxHeight : Integer;
MinWidth : Integer;
MinHeight : Integer;
Cycles : Integer);
Begin
ImageRotateDetail(
Image, {Image : TImage;}
Timer, {Timer : TTimer;}
15, {Frames : Integer;}
60, {Interval : Integer;}
Transparent, {Transparent : Boolean;}
True, {RotateHoriz : Boolean;}
True, {RotateVert : Boolean;}
2*Cycles, {QuarterCycles : Integer;}
MinTop, {Const MinTop : Integer;}
MinLeft, {Const MinLeft : Integer;}
MaxWidth, {Const MaxWidth : Integer;}
MaxHeight, {Const MaxHeight: Integer;}
MinWidth, {MinWidth : Integer;}
MinHeight, {MinHeight : Integer;}
True, {StartMaxHoriz : Boolean;}
True); {StartMaxVert : Boolean);}
End;
//Unit Description UnitIndex Master Index
Procedure ImageFadeInAndOut(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Cycles : Integer);
Begin
ImageFadeInAndOutDetail(
Image,
Timer,
Transparent,
Image.Parent.ClientRect.Top+1,
Image.Parent.ClientRect.Left+1,
(Image.Parent.ClientRect.Right-Image.Parent.ClientRect.Left)-2,
(Image.Parent.ClientRect.Bottom-Image.Parent.ClientRect.Top)-2,
0,
0,
Cycles);
End;
//Unit Description UnitIndex Master Index
Procedure ImagePulsate(
Image : TImage;
Timer : TTimer;
Transparent : Boolean;
Cycles : Integer);
Begin
ImageFadeInAndOutDetail(
Image,
Timer,
Transparent,
Image.Parent.ClientRect.Top+1,
Image.Parent.ClientRect.Left+1,
(Image.Parent.ClientRect.Right-Image.Parent.ClientRect.Left)-2,
(Image.Parent.ClientRect.Bottom-Image.Parent.ClientRect.Top)-2,
(((Image.Parent.ClientRect.Right-Image.Parent.ClientRect.Left-2)*19) div 20),
(((Image.Parent.ClientRect.Bottom-Image.Parent.ClientRect.Top-2)*19) div 20),
Cycles);
End;
{!~ Updates matching fields in a destination table.
Source Table records are deleted if the record was updated properly.
Records unsuccessfully updated are retained and the problems recorded
in the ErrorField.}
//Unit Description UnitIndex Master Index
Function DBUpdateMatchingFields(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable,
ErrorField: string;
MsgPanel: TPanel;
FilePath: String): Boolean;
Var
S : TTable;
D : TQuery;
U : TQuery;
i,j,K,m : Integer;
Keys : TStringList;
KeysType : TStringList;
KeysQuotes : TStringList;
KeysSpaces : TStringList;
KeysWhere1 : TStringList;
KeysUpdate1 : TStringList;
KeysWhere2 : TStringList;
KeyWhere1 : String;
KeyWhere2 : String;
KeyUpdate1 : String;
NonKeys : TStringList;
NonKeysType : TStringList;
NonKeysQuotes : TStringList;
NonKeysSpaces : TStringList;
NonKeysStr : TStringList;
NonKeysString : String;
CommonFields : TStringList;
UpdateString : String;
WhereAnd : String;
CurField : String;
CurValue_S : String;
CurString : String;
CurStrings : String;
DFieldType : String;
EMessage : String;
ESuccess : String;
DFromString : String;
TimeLog : TStringList;
SetString : String;
Begin
ESuccess := 'Successful';
S := TTable.Create(nil);
D := TQuery.Create(nil);
U := TQuery.Create(nil);
Keys := TStringList.Create();
KeysSpaces := TStringList.Create();
KeysType := TStringList.Create();
KeysQuotes := TStringList.Create();
TimeLog := TStringList.Create();
CommonFields := TStringList.Create();
NonKeys := TStringList.Create();
NonKeysQuotes:= TStringList.Create();
NonKeysType := TStringList.Create();
NonKeysSpaces:= TStringList.Create();
NonKeysStr := TStringList.Create();
KeysWhere1 := TStringList.Create();
KeysUpdate1 := TStringList.Create();
KeysWhere2 := TStringList.Create();
NonKeysString:= '';
SetString := 'Set ';
TimeLog.Clear;
Try
Try
DBFieldNamesCommonToTStrings(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable,
CommonFields);
For i := 0 To CommonFields.Count - 1 Do
Begin
CommonFields[i] := UpperCase(CommonFields[i]);
End;
D.Active := False;
D.DatabaseName := DestDatabaseName;
U.Active := False;
U.DatabaseName := DestDatabaseName;
UpdateString := 'Update ';
If Pos('.DB',UpperCase(DestinationTable)) > 0 Then
Begin
UpdateString := UpDateString + '"'+DestinationTable+'"';
End
Else
Begin
UpdateString := UpDateString + DestinationTable + '';
End;
DBKeyFieldNamesToTStrings(SourceDatabaseName,SourceTable,Keys);
KeysSpaces.Clear;
KeysType.Clear;
KeysQuotes.Clear;
For i := 0 To Keys.Count - 1 Do
Begin
Keys[i] := UpperCase(Keys[i]);
If Pos(' ',Keys[i]) > 0 Then
Begin
KeysSpaces.Add('YES');
End
Else
Begin
KeysSpaces.Add('NO');
End;
DFieldType :=
DBFieldType(
SourceDatabaseName,
SourceTable,
Keys[i]);
KeysType.Add(DFieldType);
If
(DFieldType = 'String')
Or
(DFieldType = 'DateTime')
Or
(DFieldType = 'Date')
Or
(DFieldType = 'Time')
Then
Begin
KeysQuotes.Add('YES');
End
Else
Begin
KeysQuotes.Add('NO');
End;
End;
NonKeys.Clear;
NonKeysQuotes.Clear;
NonKeysType.Clear;
NonKeysSpaces.Clear;
For i := 0 To CommonFields.Count - 1 Do
Begin
If Keys.IndexOf(CommonFields[i]) = -1 Then
Begin
NonKeys.Add(CommonFields[i]);
DFieldType :=
DBFieldType(
SourceDatabaseName,
SourceTable,
CommonFields[i]);
NonKeysType.Add(DFieldType);
If
(DFieldType = 'String')
Or
(DFieldType = 'DateTime')
Or
(DFieldType = 'Date')
Or
(DFieldType = 'Time')
Then
Begin
NonKeysQuotes.Add('YES');
End
Else
Begin
NonKeysQuotes.Add('NO');
End;
If Pos(' ',CommonFields[i]) > 0 Then
Begin
NonKeysSpaces.Add('YES');
NonKeysStr.Add('"'+CommonFields[i]+'"');
End
Else
Begin
NonKeysSpaces.Add('NO');
NonKeysStr.Add(CommonFields[i]);
End;
End;
End;
S.Active := False;
S.DatabaseName := SourceDatabaseName;
S.TableName := SourceTable;
S.Active := True;
S.First;
m := 0;
NonKeysString := '';
For i := 0 To NonKeysStr.Count - 1 Do
Begin
If i = (NonKeysStr.Count - 1) Then
Begin
NonKeysString := NonKeysString + 'a.'+NonKeysStr[i]+'' + ' ';
End
Else
Begin
NonKeysString := NonKeysString + 'a.'+NonKeysStr[i]+',' + ' ';
End;
End;
DFromString := 'From ';
If Pos('.DB',UpperCase(DestinationTable)) > 0 Then
Begin
DFromString := DFromString + '"'+DestinationTable+'" a';
End
Else
Begin
DFromString := DFromString + DestinationTable + ' a';
End;
WhereAnd := '';
KeysWhere1.Clear;
KeysWhere2.Clear;
KeysUpdate1.Clear;
For j := 0 To Keys.Count -1 Do
Begin
KeyWhere1 := '';
KeyWhere2 := '';
KeyUpdate1:= '';
If WhereAnd <> '' Then KeyWhere1 := KeyWhere1 + WhereAnd;
KeyWhere1 := KeyWhere1 + '(';
KeyUpdate1:= KeyUpdate1 + '(';
If KeysSpaces[j] = 'YES' Then
Begin
KeyWhere1 := KeyWhere1 + 'a."'+Keys[j]+'" = ';
KeyUpdate1 := KeyUpdate1 + '"'+Keys[j]+'" = ';
End
Else
Begin
KeyWhere1 := KeyWhere1 + 'a.'+Keys[j]+' = ';
KeyUpdate1 := KeyUpdate1 + Keys[j]+' = ';
End;
If KeysQuotes[j] = 'YES' Then
Begin
If KeysType[j] <> 'String' Then
Begin
{Do not add quotes here, wait till later}
End
Else
Begin
KeyWhere1 := KeyWhere1 +'"';
KeyWhere2 := KeyWhere2 +'"';
KeyUpdate1:= KeyUpdate1+'"';
End;
End
Else
Begin
KeyWhere1 := KeyWhere1 +'';
KeyWhere2 := KeyWhere2 +'';
KeyUpdate1:= KeyUpdate1+'';
End;
KeyWhere2 := KeyWhere2 +')';
KeysWhere1.Add(KeyWhere1);
KeysWhere2.Add(KeyWhere2);
KeysUpdate1.Add(KeyUpdate1);
WhereAnd := 'And ';
End;
U.Sql.Clear;
U.Sql.Add(UpdateString);
U.Sql.Add('Temporary SetString');
U.Sql.Add(DFromString);
U.Sql.Add('Where');
U.Sql.Add('Temporary Where String');
While Not S.EOF Do
Begin
Try
Inc(m);
MsgPanel.Caption :=
'Record '+
StringPad(
IntToStr(m),
' ',
6,
False);
MsgPanel.Refresh;
Try
D.Active := False;
D.DatabaseName := DestDatabaseName;
D.RequestLive := False;
D.Sql.Clear;
D.Sql.Add('Select');
D.Sql.Add(NonKeysString);
D.Sql.Add(DFromString);
D.Sql.Add('Where');
For j := 0 To Keys.Count -1 Do
Begin
CurValue_S := S.FieldByName(Keys[j]).AsString;
If (KeysQuotes[j] = 'YES') And (KeysType[j] <> 'String') Then
Begin
If CurValue_S = '' Then
Begin
D.Sql.Add(
KeysWhere1[j] +
' null ' +
KeysWhere2[j]);
End
Else
Begin
D.Sql.Add(
KeysWhere1[j] +
'"' +
CurValue_S +
'"' +
KeysWhere2[j]);
End;
End
Else
Begin
D.Sql.Add(
KeysWhere1[j] +
CurValue_S +
KeysWhere2[j]);
End;
End;
D.Active := True;
If Not (D.EOF And D.BOF) Then
Begin
EMessage := ESuccess;
S.Edit;
S.FieldByName(ErrorField).AsString := EMessage;
S.Post;
End
Else
Begin
S.Edit;
S.FieldByName(ErrorField).AsString := 'No Matching Record';
S.Post;
S.Next;
Continue;
End;
Except
End;
U.Sql.Clear;
U.Sql.Add(UpdateString);
U.Sql.Add('Set');
For i := 0 To NonKeys.Count - 1 Do
Begin
CurField := NonKeys[i];
Try
With U Do
Begin
Active := False;
SetString := CurField+' = ';
CurValue_S := '';
If NonKeysType[i] = 'Float' Then
Begin
CurValue_S :=
FormatFloat(
'#0.0000000000',
S.FieldByName(CurField).AsFloat);
End
Else
Begin
CurValue_S := S.FieldByName(CurField).AsString;
End;
If NonKeysQuotes[i] = 'YES' Then
Begin
If NonKeysType[i] <> 'String' Then Begin
If CurValue_S = '' Then Begin
SetString := SetString + ' null ';
End Else Begin
SetString := SetString + '"'+CurValue_S+'"';
End;
End Else Begin
SetString := SetString + '"'+CurValue_S+'"';
End;
End Else Begin
SetString := SetString + CurValue_S;
End;
SetString := SetString;
If i <> (NonKeys.Count - 1) Then
SetString := SetString+',';
Sql.Add(SetString);
End;
Except
On E : Exception Do
Begin
If EMessage = ESuccess Then
Begin
EMessage := 'Error-Field Level- Keys:';
For K := 0 To Keys.Count -1 Do
Begin
EMessage := EMessage + Keys[K]+'='+S.FieldByName(Keys[K]).AsString+', ';
End;
EMessage := EMessage + 'FIELDS: ';
End;
EMessage := {EMessage +} CurField+', ';
EMessage := EMessage + E.Message;
Try
S.Edit;
S.FieldByName(ErrorField).AsString := EMessage;
S.Post;
Except
End;
End;
End;
End;
CurStrings := '';
WhereAnd := '';
For j := 0 To Keys.Count -1 Do
Begin
CurStrings := CurStrings + WhereAnd;
CurValue_S := S.FieldByName(Keys[j]).AsString;
If (KeysQuotes[j] = 'YES') And (KeysType[j] <> 'String') Then
Begin
If CurValue_S = '' Then Begin
CurString := KeysUpdate1[j]+' null '+KeysWhere2[j];
End Else Begin
CurString :=KeysUpdate1[j]+'"'+CurValue_S+'"'+KeysWhere2[j];
End;
End Else Begin
CurString := KeysUpdate1[j]+CurValue_S+KeysWhere2[j];
End;
CurStrings := CurStrings + CurString + ' ';
WhereAnd := ' And ';
End;
U.Sql.Add('Where');
U.Sql.Add(CurStrings);
U.ExecSql;
U.Active := False;
Except
On E : Exception Do
Begin
Try
S.Edit;
S.FieldByName(ErrorField).AsString := E.Message;
S.Post;
Except
End;
End;
End;
S.Next;
End;
Try
D.Active := False;
D.RequestLive := True;
D.DatabaseName := SourceDatabaseName;
D.Sql.Clear;
D.Sql.Add('Delete From '+SourceTable);
D.Sql.Add('Where');
D.Sql.Add(ErrorField+' = "'+ESuccess+'"');
D.SQL.SaveToFile(FilePath+'Delete.Sql');
D.ExecSql;
D.Active := False;
Except
If Not IsField(SourceDatabaseName, SourceTable, ErrorField) Then
Begin
ShowMessage('Cannot delete records from '+
SourceTable+' table because '+ErrorField+
' Field does not exist');
End
Else
Begin
ShowMessage('Error deleting source table records!');
End;
End;
Except
If EMessage = ESuccess Then
Begin
EMessage := 'Error-Process Level- Keys:';
For K := 0 To Keys.Count -1 Do
Begin
EMessage := EMessage + Keys[K]+'='+S.FieldByName(Keys[K]).AsString+', ';
End;
End
Else
Begin
EMessage := EMessage + 'Process Error Also';
End;
Try
S.Edit;
S.FieldByName(ErrorField).AsString := EMessage;
S.Post;
Except
End;
End;
Finally
S.Free;
D.SQL.SaveToFile(FilePath+'Select.Sql');
D.Free;
U.SQL.SaveToFile(FilePath+'Update.Sql');
U.Free;
Keys.SaveToFile(FilePath+'Keys.Txt');
Keys.Free;
TimeLog.Free;
CommonFields.SaveToFile(FilePath+'CommonFields.Txt');
CommonFields.Free;
NonKeys.SaveToFile(FilePath+'NonKeys.Txt');
NonKeys.Free;
NonKeysQuotes.SaveToFile(FilePath+'NonKeysQuotes.Txt');
NonKeysQuotes.Free;
NonKeysType.SaveToFile(FilePath+'NonKeysType.Txt');
NonKeysType.Free;
KeysSpaces.SaveToFile(FilePath+'KeysSpaces.Txt');
KeysSpaces.Free;
KeysType.SaveToFile(FilePath+'KeysType.Txt');
KeysType.Free;
KeysQuotes.SaveToFile(FilePath+'KeysQuotes.Txt');
KeysQuotes.Free;
NonKeysSpaces.SaveToFile(FilePath+'NonKeysSpaces.Txt');
NonKeysSpaces.Free;
NonKeysStr.SaveToFile(FilePath+'NonKeysStr.Txt');
NonKeysStr.Free;
KeysWhere1.SaveToFile(FilePath+'KeysWhere1.Txt');
KeysWhere1.Free;
KeysWhere2.SaveToFile(FilePath+'KeysWhere2.Txt');
KeysWhere2.Free;
KeysUpdate1.SaveToFile(FilePath+'KeysUpdate1.Txt');
KeysUpdate1.Free;
End;
End;
{!~ Copies a table from the source to the destination.
If the destination table exists the function will not
throw an error, the existing table will be replaced with the new
table.}
//Unit Description UnitIndex Master Index
Function DBCopyTableToServer(
SourceDatabaseName : String;
SourceTableName : String;
DestDatabaseName : String;
DestTableName : String): Boolean;
Begin
Result := False;
Try
If DBCreateTableBorrowStr(
SourceDatabaseName,
SourceTableName,
DestDatabaseName,
DestTableName)
Then
Begin
If AddTables(
SourceDatabaseName,
SourceTableName,
DestDatabaseName,
DestTableName)
Then
Begin
Result := True;
End;
End;
Except
On E : Exception Do
Begin
Msg('DBCopyTableToServer Error: '+E.Message);
Result := False;
End;
End;
End;
{!~ Creates an empty table with indices by borrowing the structure
of a source table. Source and destination can be remote or local
tables. If the destination table exists the function will not
throw an error, the existing table will be replaced with the new
table.}
//Unit Description UnitIndex Master Index
Function DBCreateTableBorrowStr(
SourceDatabaseName : String;
SourceTableName : String;
DestDatabaseName : String;
DestTableName : String): Boolean;
Var
S : TTable;
D : TTable;
i,j : Integer;
IMax : Integer;
IndexName : String;
IndexFields : String;
IndexFields2 : String;
Q : TQuery;
IDXO : TIndexOptions;
Begin
S := TTable.Create(nil);
D := TTable.Create(nil);
Try
Try
S.Active := False;
S.DatabaseName := SourceDatabaseName;
S.TableName := SourceTableName;
S.TableType := ttDefault;
S.Active := True;
D.DatabaseName := DestDatabaseName;
D.TableName := DestTableName;
D.TableType := ttDefault;
D.FieldDefs.Assign(S.FieldDefs);
D.CreateTable;
{Similar method could be used to create the indices}
{D.IndexDefs.Assign(S.IndexDefs);}
S.IndexDefs.Update;
D.IndexDefs.Update;
D.IndexDefs.Clear;
D.IndexDefs.Update;
For i := 0 To S.IndexDefs.Count - 1 Do
Begin
If Pos('.DB',UpperCase(DestTableName)) > 0 Then
Begin
{Paradox or DBase Tables}
If S.IndexDefs.Items[i].Name = '' Then
Begin
If Pos('.DB',UpperCase(DestTableName)) = 0 Then
Begin
IndexName := DestTableName+IntToStr(i);
End
Else
Begin
IndexName := '';
End;
End
Else
Begin
IndexName := DestTableName+IntToStr(i);
End;
IndexFields := S.IndexDefs.Items[i].Fields;
D.AddIndex(IndexName,IndexFields,S.IndexDefs.Items[i].Options);
D.IndexDefs.Update;
End
Else
Begin
{Non Local Tables}
Q := TQuery.Create(nil);
Try
S.IndexDefs.Update;
D.IndexDefs.Update;
D.IndexDefs.Clear;
D.IndexDefs.Update;
IMax := S.IndexDefs.Count - 1;
For j := 0 To IMax Do
Begin
Q. Active := False;
Q.DatabaseName := DestDatabaseName;
IndexName := DestTableName+IntToStr(i);
IndexFields := S.IndexDefs.Items[i].Fields;
IndexFields2 :=
ReplaceCharInString(IndexFields,';',',');
Q.SQL.Clear;
Q.SQL.Add('Create');
If ixUnique in S.IndexDefs.Items[j].Options Then
Begin
Q.SQL.Add('Unique');
End;
If ixDescending in S.IndexDefs.Items[j].Options Then
Begin
Q.SQL.Add('Desc');
End
Else
Begin
Q.SQL.Add('Asc');
End;
Q.SQL.Add('Index');
Q.SQL.Add(IndexName);
Q.SQL.Add('On');
Q.SQL.Add(DestTableName);
Q.SQL.Add('(');
Q.SQL.Add(IndexFields2);
Q.SQL.Add(')');
Try
Q.ExecSql;
D.IndexDefs.Update;
D.AddIndex(IndexName,IndexFields,S.IndexDefs.Items[j].Options);
D.IndexDefs.Update;
Except
On E : EDBEngineError Do
Begin
If E.Message = 'Invalid array of index descriptors.' Then
Begin
Try
D.IndexDefs.Update;
D.DeleteIndex(IndexName);
D.IndexDefs.Update;
Except
End;
End
Else
Begin
Try
D.IndexDefs.Update;
IDXO := D.IndexDefs.Items[j].Options;
Except
End;
{Msg('DBCreateTableBorrowStr Error: '+E.Message);}
End;
End;
End;
End;
//i:= IMax;
Finally
Q.Free;
End;
End;
End;
S.Active := False;
Result := True;
Finally
S.Free;
D.Free;
End;
Except
On E : Exception Do
Begin
Msg('DBCreateTableBorrowStr Error: '+E.Message);
Result := False;
End;
End;
End;
//Unit Description UnitIndex Master Index
Function DirectoryHide(Const FileString : String): Boolean;
Var
Attributes : Integer;
Begin
Result := False;
Try
If Not DirectoryExists(FileString) Then Exit;
Attributes := faDirectory + faHidden + faSysFile;
FileSetAttr(FileString,Attributes);
Result := True;
Except
End;
End;
//Unit Description UnitIndex Master Index
Function DirectoryUnHide(Const FileString : String): Boolean;
Var
Attributes : Integer;
Begin
Result := False;
Try
If Not DirectoryExists(FileString) Then Exit;
Attributes := faDirectory;
FileSetAttr(FileString,Attributes);
Result := True;
Except
End;
End;
{!~ Populates a TStrings FileList with the files meeting selected
file attribute criteria in a directory. The mask argument is a
standard DOS file argument like '*.*. The InclDotFiles argument
allows the user to exclude the system files "." and ".." by
setting the value to False. If the Intersection argument is set
to true then the result will reflect only those files that satisfy
all attribute criteria. If Intersection is set to false then the
result will be a union of files that meet any of the criteria.}
//Unit Description UnitIndex Master Index
Function FilesInDirDetail(
FileList : TStrings;
Directory : String;
Mask : String;
Intersection: Boolean;
IsReadOnly : Boolean;
IsHidden : Boolean;
IsSystem : Boolean;
IsVolumeID : Boolean;
IsDirectory : Boolean;
IsArchive : Boolean;
IsNormal : Boolean;
InclDotFiles: Boolean): Boolean;
var
j : Integer;
MaskPtr : PChar;
Ptr : PChar;
FileInfo : TSearchRec;
CurDir : String;
FileType : TFileType;
FileType_I : Integer;
FileType_B : ShortString;
TSList : TStringList;
BinaryAttr : ShortString;
ShouldAdd : Boolean;
begin
{ Result := False;}{zzz}
TSList := TStringList.Create();
Try
Try
FileType := [];
If IsReadOnly Then FileType := (FileType + [ftReadOnly]);
If IsHidden Then FileType := (FileType + [ftHidden]);
If IsSystem Then FileType := (FileType + [ftSystem]);
If IsVolumeID Then FileType := (FileType + [ftVolumeID]);
If IsDirectory Then FileType := (FileType + [ftDirectory]);
If IsArchive Then FileType := (FileType + [ftArchive]);
If IsNormal Then FileType := (FileType + [ftNormal]);
FileType_I := 0;
If IsReadOnly Then FileType_I := (FileType_I + 1);
If IsHidden Then FileType_I := (FileType_I + 2);
If IsSystem Then FileType_I := (FileType_I + 4);
If IsVolumeID Then FileType_I := (FileType_I + 8);
If IsDirectory Then FileType_I := (FileType_I + 16);
If IsArchive Then FileType_I := (FileType_I + 32);
If IsNormal Then FileType_I := (FileType_I + 128);
FileType_B := ConvertIntegerToBinaryString(FileType_I,8);
TSList.Clear;
GetDir(0,CurDir);
ChDir(Directory); { go to the directory we want }
FileList.Clear; { clear the list }
MaskPtr := PChar(Mask);
while MaskPtr <> nil do
begin
Ptr := StrScan (MaskPtr, ';');
If Ptr <> nil Then Ptr^ := #0;
If FindFirst(MaskPtr, 191, FileInfo) = 0 Then
Begin
Repeat { exclude normal files if ftNormal not set }
Begin
If ftNormal in FileType Then
Begin
TSList.Add(FileInfo.Name);
End
Else
Begin
BinaryAttr := ConvertIntegerToBinaryString(FileInfo.Attr,8);
If Intersection Then
Begin
ShouldAdd := True;
For j := 1 To 8 Do
Begin
If (FileType_B[j]='1') And (BinaryAttr[j]<>'1') Then
Begin
ShouldAdd := False;
Break;
End;
End;
If ShouldAdd Then
TSList.Add(FileInfo.Name);
End
Else
Begin
For j := 1 To 8 Do
Begin
If (FileType_B[j]='1') And (BinaryAttr[j]='1') Then
Begin
TSList.Add(FileInfo.Name);
Break;
End;
End;
End;
End;
End;
Until FindNext(FileInfo) <> 0;
FindClose(FileInfo.FindHandle);
End;
If Ptr <> nil then
begin
Ptr^ := ';';
Inc (Ptr);
end;
MaskPtr := Ptr;
end;
ChDir(CurDir);
TSList.Sorted := False;
If Not InclDotFiles Then
Begin
If TSList.IndexOf('.') > -1 Then
TSLIst.Delete(TSList.IndexOf('.'));
If TSList.IndexOf('..') > -1 Then
TSLIst.Delete(TSList.IndexOf('..'));
End;
TSList.Sorted := True;
TSList.Sorted := False;
FileList.Assign(TSList);
Result := True;
Except
Result := False;
End;
Finally
TSList.Free;
End;
end;
{!~ Converts a word value to its binary equivalent
as a ShortString }
//Unit Description UnitIndex Master Index
Function ConvertWordToBinaryString(InputWord : Word; Length : Integer) : ShortString;
var
Counter, Number : Cardinal;
D : Array[0..1] of Char;
Begin
D[0] := '0';
D[1] := '1';
Number := 1;
Result[0] := #16;
For Counter := 15 Downto 0 Do
Begin
Result[Number] :=
D[Ord(InputWord and (1 shl Counter) <> 0)];
Inc(Number);
End;
If Length > 16 Then Length := 16;
If Length < 1 Then Length := 1;
Result := SubStr(Result,16-Length,Length);
End;
{!~ Converts an integer value to its binary equivalent
as a ShortString }
//Unit Description UnitIndex Master Index
Function ConvertIntegerToBinaryString(Int, Length : Integer) : ShortString;
Begin
Result := ConvertWordToBinaryString(Word(Int),Length);
End;
{!~ Returns the next available file name number as a string
in the format 00000001}
//Unit Description UnitIndex Master Index
Function FileNextNumberName(
Directory : String;
Mask : String
): String;
Var
StringList : TStringList;
CurLast_I : Integer;
Begin
Result := '';
StringList := TStringList.Create();
Try
StringList.Clear;
FilesInDirDetail(
StringList,
Directory,
Mask,
True, {Intersection: Boolean;}
False, {IsReadOnly : Boolean;}
False, {IsHidden : Boolean;}
False, {IsSystem : Boolean;}
False, {IsVolumeID : Boolean;}
False, {IsDirectory : Boolean;}
False, {IsArchive : Boolean;}
True, {IsNormal : Boolean;}
False); {InclDotFiles: Boolean): Boolean;}
StringList.Sorted := True;
Try
If StringList.Count = 0 Then
Begin
CurLast_I := 0;
End
Else
Begin
CurLast_I :=
StrToInt(
NumbersOnlyAbsolute(
ExtractFileNameNoExt(
StringList[StringList.Count-1])));
End;
Except
CurLast_I := 0;
End;
Result := StringPad(IntToStr(CurLast_I+1),'0',8,False);
Finally
StringList.Free;
End;
End;
{!~ Copies an internet URL to a file. Returns True
if successful, False otherwise. The source URL can
be a remote http address or it can be a local file.}
//Unit Description UnitIndex Master Index
Function InternetCopyURLToFile(
SourceURL : String;
DestFile : String;
ShowMessages : Boolean;
StatusPanel : TPanel
): Boolean;
const MAX_PATH = 600;
var
hStdOut : THandle;
OutDir : String;
OutFile : String;
{ Msg : String;}{zzz}
// Start Embedded Functions in CopyURL
Function InternetLoadRate(
StartTime : TDateTime;
iBytes : integer
): integer;
Var
iStartSecond : integer;
iSeconds : integer;
Hour : word;
Min : word;
Sec : word;
MSec : word;
Begin
DecodeTime( StartTime, Hour, Min, Sec, MSec );
iStartSecond := Sec + Min * 60 + Hour * 360;
DecodeTime( Now, Hour, Min, Sec, MSec );
iSeconds := ( Sec + Min * 60 + Hour * 360 ) - iStartSecond;
If ( Trunc( Now - StartTime ) > 0 ) Then
Begin
iSeconds := iSeconds + Trunc( Now - StartTime ) * 24 * 60 * 60;
End;
If ( iSeconds > 0 ) Then
Begin
Result := iBytes div iSeconds;
End
Else
Begin
Result := 0;
End;
end;
Function InternetGetFile(
Source_Handle : HINTERNET;
DestFile_Handle : THandle;
ShowMessages : Boolean;
StatusPanel : TPanel
): Boolean;
const FILE_SMALL_BUFFER = 4096;
const RETRY_READ = 10;
Var
iRetry : integer;
bOk : bool;
StartTime : TDateTime;
EndTime : TDateTime;
iWriteFileTotal : integer;
iWriteFileCount : integer;
iReadFileCount : integer;
SmallBuffer : array [ 1..FILE_SMALL_BUFFER ] of char;
Msg : String;
Begin
Result := False;
Try
iWriteFileTotal := 0;
StartTime := Now;
Repeat
Begin
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption :=
IntToStr(iWriteFileTotal)+
' bytes transferred ... (' +
IntToStr(InternetLoadRate( StartTime, iWriteFileTotal ))+
' bytes/sec)';
StatusPanel.Refresh;
End;
iRetry := 0;
Repeat
Begin
iReadFileCount := 0;
bOk :=
InternetReadFile(
Source_Handle,
@SmallBuffer,
FILE_SMALL_BUFFER,
Cardinal(iReadFileCount));
Inc( iRetry );
End;
Until ((iReadFileCount <> 0) or (bOk) or (iRetry = RETRY_READ));
If (iReadFileCount > 0) Then
Begin
iWriteFileCount := 0;
bOk :=
WriteFile(
DestFile_Handle,
SmallBuffer,
iReadFileCount,
Cardinal(iWriteFileCount),
nil);
bOk := (bOk) and (iReadFileCount = iWriteFileCount);
If (bOk) Then
Begin
iWriteFileTotal := iWriteFileTotal + iWriteFileCount;
End
Else
Begin
iReadFileCount := 0;
Msg := 'Error writing to the output file.';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then
Begin
ShowMessage(Msg);
End;
Exit;
End;
End
Else
Begin
If (not bOk) Then
Begin
Msg := 'Error reading the data.';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then ShowMessage(Msg);
Exit;
End;
End;
End;
Until (iReadFileCount = 0);
EndTime := now();
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption :=
'('+
FormatFloat(
'###,###,##0',
TimeDeltaInSeconds(
StartTime,
EndTime))+
' seconds)';
StatusPanel.Refresh;
End;
Result := True;
Except
Result := False;
End;
end;
Function InternetFetchFile(
hSession : HINTERNET;
SourceURL : string;
DestFile : string;
hStdOut : THandle;
ShowMessages : Boolean;
RevealDest : Boolean;
StatusPanel : TPanel
): Boolean;
Var
Source_Handle : HINTERNET;
DestFile_Handle : THandle;
Msg : String;
Begin
Result := False;
Try
Msg := 'Opening "'+SourceURL+'"';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
Source_Handle :=
InternetOpenUrl(
hSession,
PChar(SourceURL),
nil,
Cardinal(-1),
INTERNET_FLAG_DONT_CACHE or
INTERNET_FLAG_RAW_DATA,
0);
If (Source_Handle <> nil) Then
Begin
If (DestFile = '') Then
Begin
DestFile_Handle := hStdOut;
If RevealDest Then
Begin
Msg := 'Output directed to default';
End
Else
Begin
Msg := 'Output initiated';
End;
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
End
Else
Begin
If RevealDest Then
Begin
Msg := 'Creating "'+DestFile+'"';
End
Else
Begin
Msg := 'Output initiated';
End;
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
DestFile_Handle :=
CreateFile(
PChar(DestFile),
GENERIC_WRITE,
FILE_SHARE_READ,
nil,
CREATE_NEW,
FILE_FLAG_WRITE_THROUGH or
FILE_FLAG_SEQUENTIAL_SCAN,
0 );
End;
If (DestFile_Handle <> INVALID_HANDLE_VALUE ) Then
Begin
Msg := 'Starting Download';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
InternetGetFile(
Source_Handle,
DestFile_Handle,
ShowMessages,
StatusPanel);
If (DestFile_Handle <> hStdOut ) Then
Begin
CloseHandle(DestFile_Handle);
End;
End
Else
Begin
Msg := 'Output Failed!!! Closing "'+SourceURL+'"';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then
Begin
ShowMessage(Msg);
End;
InternetCloseHandle(Source_Handle);
Exit;
End;
End
Else
Begin
Msg := 'URL could not be opened';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then
Begin
ShowMessage(Msg);
End;
Exit;
End;
Result := True;
Except
Result := False;
End;
End;
Function InternetCreateSession(
SourceUrl : string;
DestFile : string;
sCaller : string;
hStdOut : THandle;
ShowMessages : Boolean;
StatusPanel : TPanel
): Boolean;
Var
hSession : HINTERNET;
Msg : String;
Begin
Result := False;
Try
Msg := 'Opening Internet Session "'+ sCaller+'"';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
hSession :=
InternetOpen(
PChar(sCaller),
LOCAL_INTERNET_ACCESS,
nil,
PChar(INTERNET_INVALID_PORT_NUMBER),
INTERNET_FLAG_DONT_CACHE );
If (hSession <> nil) Then
Begin
Msg := 'Done "'+ sCaller+'" ';
If InternetFetchFile(
hSession,
SourceURL,
DestFile,
hStdOut,
ShowMessages,
False,
StatusPanel) Then
Begin
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg + StatusPanel.Caption;
StatusPanel.Refresh;
End;
InternetCloseHandle( hSession );
End
Else
Begin
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg + StatusPanel.Caption;
StatusPanel.Refresh;
End;
InternetCloseHandle( hSession );
Exit;
End;
End
Else
Begin
Msg := 'Internet session not opened. Process Aborted!';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then
Begin
ShowMessage(Msg);
End;
Exit;
End;
Result := True;
Except
Result := False;
End;
End;
// End Embedded Functions in CopyURL
Begin
Result := False;
Try
{Check the input parameters}
If SourceUrl = '' Then
Begin
If ShowMessages Then
Begin
ShowMessage('No Source URL was provided. Process Aborted!');
End;
Exit;
End;
If DestFile = '' Then
Begin
If ShowMessages Then
Begin
ShowMessage('No Destination File was provided. Process Aborted!');
End;
Exit;
End;
If (Length(SourceUrl) > INTERNET_MAX_URL_LENGTH ) Then
Begin
If ShowMessages Then
Begin
ShowMessage(
'URL is longer than '+
IntToStr(INTERNET_MAX_URL_LENGTH)+
'. Process Aborted!');
End;
Exit;
End;
If FileExists(OutFile) Then SysUtils.DeleteFile(OutFile);
OutDir := FilePath(DestFile);
OutFile:= ExtractFileName(DestFile);
If Not DirectoryExists(OutDir) Then
Begin
If ShowMessages Then
Begin
ShowMessage('Output Path = '+OutDir);
ShowMessage('The Output directory does not exist. Process Aborted!');
End;
Exit;
End;
If Length(DestFile) > 255 Then
Begin
If ShowMessages Then
Begin
ShowMessage('The Output File and Path are too long. Process Aborted!');
End;
Exit;
End;
hStdOut := GetStdHandle( STD_OUTPUT_HANDLE );
Result := InternetCreateSession(
SourceURL,
DestFile,
SourceURL,
hStdOut,
ShowMessages,
StatusPanel);
If Not Result Then
Begin
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := '';
StatusPanel.Refresh;
End;
End;
Except
Result := False;
End;
End;
{!~ Tests for the existence of a URL. True is returned
if the URL exists and False otherwise. The source URL
can be a remote http address or it can be a local file.}
//Unit Description UnitIndex Master Index
Function InternetIsUrl(URL : String): Boolean;
Var
hSession : HINTERNET;
Source_Handle : HINTERNET;
Avail : Integer;
Begin
Try
If FileExists(URL) Then
Begin
Result := True;
Exit;
End;
Except
End;
hSession := nil;
Source_Handle := nil;
Try
Try
hSession :=
InternetOpen(
PChar('nil'),
LOCAL_INTERNET_ACCESS,
nil,
PChar(INTERNET_INVALID_PORT_NUMBER),
INTERNET_FLAG_DONT_CACHE );
If (hSession <> nil) Then
Begin
Source_Handle :=
InternetOpenUrl(
hSession,
PChar(URL),
nil,
Cardinal(-1),
INTERNET_FLAG_DONT_CACHE or
INTERNET_FLAG_RAW_DATA,
0);
If (Source_Handle <> nil) Then
Begin
Try
Avail := -1;
InternetQueryDataAvailable(
Source_Handle,
Cardinal(Avail),
0,
0);
If Avail > 42 Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
Except
Result := False;
End;
End
Else
Begin
Result := False;
End;
End
Else
Begin
Result := False;
End;
Except
Result := False;
End;
Finally
InternetCloseHandle( hSession );
InternetCloseHandle(Source_Handle);
End;
End;
{!~ Returns the Base URL of a URL address. The source
URL can be a remote http address or it can be a local
file.}
//Unit Description UnitIndex Master Index
Function InternetGetBaseURL(URL : String): String;
Var
URLString : ShortString;
{StringToPeriod : ShortString;}{zzz}
i{,L}{zzz} : Integer;
PeriodPos : Integer;
C : Char;
ShouldBreak : Boolean;
ParseMin : Integer;
Begin
Result := '';
If Not InternetIsUrl(URL) Then Exit;
If FileExists(URL) Then
Begin
Result := FilePath(URL);
Exit;
End;
If Length(URL) > 255 Then
Begin
Result := URL;
Exit;
End;
If SubStr(URL,Length(URL),1) = '/' Then
Begin
Result := URL;
Exit
End;
URLString := ShortString(URL);
PeriodPos := Pos('.',SubStr(URLString,Length(URLString)-6,7));
{L := Length(URLString);}{zzz}
ParseMin := 8;
If UpperCase(SubStr(URL,1,7)) = 'HTTP://' Then ParseMin := 8;
If UpperCase(SubStr(URL,1,6)) = 'FTP://' Then ParseMin := 7;
If PeriodPos > 0 Then
Begin
For i := (Length(URLString)-6 + PeriodPos - 2) DownTo ParseMin Do
Begin
ShouldBreak := False;
C := URLString[i];
Case C of
'.' : ShouldBreak := True;
'/' : ShouldBreak := True;
'~' : ShouldBreak := True;
'-' : ShouldBreak := True;
End;
If ShouldBreak Then
Begin
Result := SubStr(URLString,1,i);
Exit;
End;
End;
End;
Result := URL+'/';
End;
//Unit Description UnitIndex Master Index
Function InputBoxFilterDetail(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string;
const FilterString : string
): string;
Var
Form : TForm;
Prompt : TLabel;
Edit : TEditKeyFilter;
DialogUnits : TPoint;
ButtonTop : Integer;
ButtonWidth : Integer;
ButtonHeight: Integer;
function GetAveCharSize(Canvas: TCanvas): TPoint;
var
I: Integer;
Buffer: array[0..51] of Char;
begin
for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
Result.X := Result.X div 52;
end;
Begin
Result := DefaultValue;
Form := TForm.Create(Application);
With Form Do
Begin
Try
Canvas.Font := Font;
DialogUnits := GetAveCharSize(Canvas);
BorderStyle := bsDialog;
Caption := DialogCaption;
ClientWidth := MulDiv(180, DialogUnits.X, 4);
ClientHeight := MulDiv(63, DialogUnits.Y, 8);
Position := poScreenCenter;
Prompt := TLabel.Create(Form);
With Prompt Do
Begin
Parent := Form;
AutoSize := True;
Left := MulDiv(8, DialogUnits.X, 4);
Top := MulDiv(8, DialogUnits.Y, 8);
Caption := InputPrompt;
End;
Edit := TEditKeyFilter.Create(Form);
With Edit Do
Begin
Parent := Form;
Left := Prompt.Left;
Top := MulDiv(19, DialogUnits.Y, 8);
Width := MulDiv(164, DialogUnits.X, 4);
MaxLength := 255;
Text := DefaultValue;
If FilterString <> '' Then
Begin
If FilterString = 'OnlyNumbers' Then
OnKeyPress:= OnlyNumbers;
If FilterString = 'OnlyNumbersAbsolute' Then
OnKeyPress:= OnlyNumbersAbsolute;
If FilterString = 'OnlyAToZ' Then
OnKeyPress:= OnlyAToZ;
End;
SelectAll;
End;
ButtonTop := MulDiv(41, DialogUnits.Y, 8);
ButtonWidth := MulDiv(50, DialogUnits.X, 4);
ButtonHeight:= MulDiv(14, DialogUnits.Y, 8);
With TButton.Create(Form) Do
Begin
Parent := Form;
Caption := 'OK';
ModalResult := mrOk;
Default := True;
SetBounds(
MulDiv(38, DialogUnits.X, 4),
ButtonTop,
ButtonWidth,
ButtonHeight);
End;
With TButton.Create(Form) Do
Begin
Parent := Form;
Caption := 'Cancel';
ModalResult := mrCancel;
Cancel := True;
SetBounds(
MulDiv(92, DialogUnits.X, 4),
ButtonTop,
ButtonWidth,
ButtonHeight);
End;
If ShowModal = mrOk Then
Begin
Result := Edit.Text;
End;
Finally
Form.Free;
End;
End;
End;
{!~ Presents an input dialog that accepts 0-9,-,+,".".
All other keys are thrown away except for the backspace key.
The result is returned as a string}
//Unit Description UnitIndex Master Index
Function InputBoxOnlyNumbers(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
Begin
Result :=
InputBoxFilterDetail(
DialogCaption,
InputPrompt,
DefaultValue,
'OnlyNumbers'
);
End;
{!~ Presents an input dialog that accepts 0-9.
All other keys are thrown away except for the backspace key.
The result is returned as a string}
//Unit Description UnitIndex Master Index
Function InputBoxOnlyNumbersAbsolute(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
Begin
Result :=
InputBoxFilterDetail(
DialogCaption,
InputPrompt,
DefaultValue,
'OnlyNumbersAbsolute'
);
End;
{!~ Presents an input dialog that accepts a-z and A-Z only.
All other keys are thrown away except for the backspace key.
The result is returned as a string}
//Unit Description UnitIndex Master Index
Function InputBoxOnlyAToZ(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
Begin
Result :=
InputBoxFilterDetail(
DialogCaption,
InputPrompt,
DefaultValue,
'OnlyAToZ'
);
End;
{!~ Presents an input dialog that accepts 0-9,-,+,".".
All other keys are thrown away except for the backspace key.
The result is returned as a string}
//Unit Description UnitIndex Master Index
Function DialogInputBoxOnlyNumbers(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
Begin
Result :=
InputBoxOnlyNumbers(
DialogCaption,
InputPrompt,
DefaultValue
);
End;
{!~ Presents an input dialog that accepts 0-9.
All other keys are thrown away except for the backspace key.
The result is returned as a string}
//Unit Description UnitIndex Master Index
Function DialogInputBoxOnlyNumbersAbsolute(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
Begin
Result :=
InputBoxOnlyNumbersAbsolute(
DialogCaption,
InputPrompt,
DefaultValue
);
End;
{!~ Presents an input dialog that accepts a-z and A-Z only.
All other keys are thrown away except for the backspace key.
The result is returned as a string}
//Unit Description UnitIndex Master Index
Function DialogInputBoxOnlyAToZ(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string): string;
Begin
Result :=
InputBoxOnlyAToZ(
DialogCaption,
InputPrompt,
DefaultValue
);
End;
{!~ Presents a lookup Dialog to the user. The selected
value is returned if the user presses OK and the Default
value is returned if the user presses Cancel unless the
TStringList is nil in which case a blank string is returned}
//Unit Description UnitIndex Master Index
Function DialogLookupDetail(
Const DialogCaption : string;
Const InputPrompt : string;
Const DefaultValue : string;
Const Values : TStringList;
Const ButtonSpacing : Integer;
Const SpacerHeight : Integer;
Const TopBevelWidth : Integer;
Const PromptHeight : Integer;
Const FormHeight : Integer;
Const FormWidth : Integer;
Const Hint_OK : string;
Const Hint_Cancel : string;
Const Hint_ListBox : string;
Const ListSorted : Boolean;
Const AllowDuplicates : Boolean
): string;
Var
Form : TForm;
Base_Panel : TPanel;
Base_Buttons : TPanel;
Spacer : TPanel;
Base_Top : TPanel;
ButtonSlider : TPanel;
ButtonSpacer : TPanel;
Prompt : TPanel;
ListBox : TListBox;
ButtonCancelB: TPanel;
ButtonOKB : TPanel;
Button_Cancel: TButton;
Button_OK : TButton;
DefItemIndex : Integer;
TempValues : TStringList;
Begin
Result := DefaultValue;
Form := TForm.Create(Application);
TempValues := TStringList.Create();
Try
TempValues.Sorted := ListSorted;
TempValues.Clear;
If AllowDuplicates Then
Begin
TempValues.Duplicates := dupAccept;
End
Else
Begin
TempValues.Duplicates := dupIgnore;
End;
If Values <> nil Then
Begin
TempValues.Assign(Values);
End;
With Form Do
Begin
Try
Canvas.Font := Font;
BorderStyle := bsSizeable;
Caption := DialogCaption;
Height := FormHeight;
Width := FormWidth;
ShowHint := True;
Position := poScreenCenter;
BorderIcons := [biMaximize];
Base_Panel := TPanel.Create(Form);
With Base_Panel Do
Begin
Parent := Form;
Align := alClient;
Caption := ' ';
BorderWidth := 10;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
End;
Base_Buttons := TPanel.Create(Form);
With Base_Buttons Do
Begin
Parent := Base_Panel;
Align := alBottom;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Height := 27;
End;
ButtonSlider := TPanel.Create(Form);
With ButtonSlider Do
Begin
Parent := Base_Buttons;
Align := alClient;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
End;
ButtonCancelB := TPanel.Create(Form);
With ButtonCancelB Do
Begin
Parent := ButtonSlider;
Align := alRight;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Width := 75+ButtonSpacing;
End;
ButtonSpacer := TPanel.Create(Form);
With ButtonSpacer Do
Begin
Parent := ButtonCancelB;
Align := alLeft;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Width := ButtonSpacing;
End;
ButtonOKB := TPanel.Create(Form);
With ButtonOKB Do
Begin
Parent := ButtonSlider;
Align := alRight;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Width := 75;
End;
Spacer := TPanel.Create(Form);
With Spacer Do
Begin
Parent := Base_Panel;
Align := alBottom;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Height := SpacerHeight;
End;
Base_Top := TPanel.Create(Form);
With Base_Top Do
Begin
Parent := Base_Panel;
Align := alClient;
Caption := ' ';
BorderWidth := 10;
BorderStyle := bsNone;
BevelOuter := bvRaised;
BevelInner := bvNone;
BevelWidth := TopBevelWidth;
End;
Prompt := TPanel.Create(Form);
With Prompt Do
Begin
Parent := Base_Top;
Align := alTop;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Caption := InputPrompt;
Height := PromptHeight;
Alignment := taCenter;
End;
Button_Cancel := TButton.Create(Form);
With Button_Cancel Do
Begin
Parent := ButtonCancelB;
Caption := 'Cancel';
ModalResult := mrCancel;
Default := True;
Align := alClient;
Hint := Hint_Cancel;
End;
Button_OK := TButton.Create(Form);
With Button_OK Do
Begin
Parent := ButtonOKB;
Caption := 'OK';
ModalResult := mrOK;
Default := False;
Align := alClient;
Hint := Hint_OK;
End;
ListBox := TListBox.Create(Form);
With ListBox Do
Begin
Parent := Base_Top;
Align := alClient;
Hint := Hint_ListBox;
Sorted := ListSorted;
Focused;
If TempValues <> nil Then
Begin
Items.Assign(TempValues);
DefItemIndex := Items.IndexOf(DefaultValue);
If DefItemIndex <> -1 Then
Begin
ItemIndex := DefItemIndex;
Selected[DefItemIndex];
End
Else
Begin
Result := '';
ItemIndex := 0;
Selected[0];
End;
IntegralHeight := True;
Button_OK.Default := True;
Button_Cancel.Default := False;
End
Else
Begin
Result := '';
End;
End;
SetFocusedControl(ListBox);
If ShowModal = mrOk Then
Begin
If ListBox.ItemIndex<>-1 Then
Result := ListBox.Items[ListBox.ItemIndex];
End;
Finally
Form.Free;
End;
End;
Finally
TempValues.Free;
End;
End;
{!~ Presents a lookup Dialog to the user. The selected
value is returned if the user presses OK and the Default
value is returned if the user presses Cancel unless the
TStringList is nil in which case a blank string is returned}
//Unit Description UnitIndex Master Index
Function DialogLookup(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string;
const Values : TStringList
): string;
Begin
Result :=
LookupDialog(
DialogCaption,
InputPrompt,
DefaultValue,
Values
);
End;
{!~ Presents a lookup Dialog to the user. The selected
value is returned if the user presses OK and the Default
value is returned if the user presses Cancel unless the
TStringList is nil in which case a blank string is returned}
//Unit Description UnitIndex Master Index
Function LookupDialog(
const DialogCaption : string;
const InputPrompt : string;
const DefaultValue : string;
const Values : TStringList
): string;
Begin
Result :=
DialogLookupDetail(
DialogCaption,
InputPrompt,
DefaultValue,
Values, //TStringList
5, //Spacer Height
5, //Button Spacing
2, //BevelWidth
25, //PromptHeight
300, //FormHeight
200, //FormWidth
'Close dialog and return selected value.', //Hint_Cancel
'Close dialog and make no changes.', //Hint_OK
'Click an item to select it.', //Hint_ListBox
True, //ListSorted
False //AllowDuplicates
);
End;
{!~ Presents a lookup Dialog to the user. The selected
value is returned if the user presses OK and the Default
value is returned if the user presses Cancel unless the
TStringList is nil in which case a blank string is returned}
//Unit Description UnitIndex Master Index
Function DialogDBLookUp(
Const DataBaseName : String;
Const TableName : String;
Const FieldName : String;
Const SessionName : String;
Const DefaultValue : String;
const DialogCaption : string;
const InputPrompt : string;
const DialogWidth : Integer
): String;
Var
Q : TQuery;
Values : TStringlist;
Begin
Result := '';
Q := TQuery.Create(nil);
Values := TStringlist.Create();
Try
Values.Clear;
Values.Sorted := True;
Values.Duplicates := dupIgnore;
Q.Active := False;
Q.DatabaseName := DatabaseName;
{$IFDEF WIN32}
Q.SessionName := SessionName;
{$ENDIF}
Q.Sql.Clear;
Q.Sql.Add('Select');
Q.Sql.Add('Distinct');
If Pos(' ',FieldName) > 0 Then
Begin
Q.Sql.Add('a."'+FieldName+'"');
End
Else
Begin
Q.Sql.Add('a.'+FieldName);
End;
Q.Sql.Add('From');
If Pos('.DB',UpperCase(TableName)) > 0 Then
Begin
Q.Sql.Add('"'+TableName+'" a');
End
Else
Begin
Q.Sql.Add(TableName+' a');
End;
Q.Sql.Add('Order By');
If Pos(' ',FieldName) > 0 Then
Begin
Q.Sql.Add('a."'+FieldName+'"');
End
Else
Begin
Q.Sql.Add('a.'+FieldName);
End;
Q.Active := True;
If Not (Q.EOF And Q.BOF) Then
Begin
Q.First;
While Not Q.EOF Do
Begin
Values.Add(Q.FieldByName(FieldName).AsString);
Q.Next;
End;
Result :=
DialogLookupDetail(
DialogCaption,
InputPrompt,
DefaultValue,
Values, //TStringList
5, //Spacer Height
5, //Button Spacing
2, //BevelWidth
25, //PromptHeight
300, //FormHeight
DialogWidth, //FormWidth
'Close dialog and return selected value.', //Hint_Cancel
'Close dialog and make no changes.', //Hint_OK
'Click an item to select it.', //Hint_ListBox
True, //ListSorted
False //AllowDuplicates
);
End;
Finally
Q.Free;
Values.Free;
End;
End;
{!~ Presents a lookup Dialog to the user. The selected
value is returned if the user presses OK and the Default
value is returned if the user presses Cancel unless the
TStringList is nil in which case a blank string is returned}
//Unit Description UnitIndex Master Index
Function DBLookUpDialog(
Const DataBaseName : String;
Const TableName : String;
Const FieldName : String;
Const SessionName : String;
Const DefaultValue : String;
const DialogCaption : string;
const InputPrompt : string;
const DialogWidth : Integer
): String;
Begin
Result :=
DialogDBLookUp(
DataBaseName,
TableName,
FieldName,
SessionName,
DefaultValue,
DialogCaption,
InputPrompt,
DialogWidth
);
End;
{!~ Populates a listbox with the executable's version information}
//Unit Description UnitIndex Master Index
Function VersionInformation(
ListBox : TListBox): Boolean;
const
InfoNum = 11;
InfoStr : array [1..InfoNum] of String =
('CompanyName', 'FileDescription', 'FileVersion', 'InternalName',
'LegalCopyright', 'LegalTradeMarks', 'OriginalFilename',
'ProductName', 'ProductVersion', 'Comments', 'Author');
LabelStr : array [1..InfoNum] of String =
('Company Name', 'Description', 'File Version', 'Internal Name',
'Copyright', 'TradeMarks', 'Original File Name',
'Product Name', 'Product Version', 'Comments', 'Author');
var
S : String;
n, Len, i : Integer;
Buf : PChar;
Value : PChar;
begin
Try
S := Application.ExeName;
ListBox.Items.Clear;
ListBox.Sorted := True;
ListBox.Font.Name := 'Courier New';
n := GetFileVersionInfoSize(PChar(S),Cardinal(n));
If n > 0 Then
Begin
Buf := AllocMem(n);
ListBox.Items.Add(StringPad('Size',' ',20,True)+' = '+IntToStr(n));
GetFileVersionInfo(PChar(S),0,n,Buf);
For i:=1 To InfoNum Do
Begin
If VerQueryValue(Buf,PChar('StringFileInfo\040904E4\'+
InfoStr[i]),Pointer(Value),Cardinal(Len)) Then
Begin
//Value := PChar(Trim(Value));
If Length(Value) > 0 Then
Begin
ListBox.Items.Add(StringPad(labelStr[i],' ',20,True)+' = '+Value);
End;
End;
End;
FreeMem(Buf,n);
End
Else
Begin
ListBox.Items.Add('No FileVersionInfo found');
End;
Result := True;
Except
Result := False;
End;
End;
{!~ ABOUTBOX_ADS
This procedure presents an About Box.
TITLE The title is set by the AboutTitle parameter.
INFORMATION
The information displayed in the about box is pulled directly
from the executable. The programmer can configure this information
in Delphi by doing the following:
(1) in Delphi go to Project|Options|VersionInfo and make sure
that the check box for Include Version information in project
is checked.
(2)Auto-increment build number should also be checked so
that each time a build-all is run the version number is
automatically updated. This makes life simple and in automatic.
(3)Edit/Add items in the section at the bottom of this page
where key and value items are listed. Whatever you put in
this section is what will appear in the about box.
(2) Save the project and recompile
(3) The newly edited information will appear in the about box.
IMAGE
The Application Icon is presented as the image. To change the
image do the following:
(1) in Delphi go to Project|Options|Application|Load Icon
and select an Icon for the application
(2) Save the project and
recompile
(3) The newly selected Icon will appear in the about box.
SIZE
The About box size can be pased as the parameters AboutWidth
and AboutHeight. If however you wish to have the procedure
size the About Box automatically set these two parameters to
zero. }
//Unit Description UnitIndex Master Index
Procedure AboutBox_ads(
AboutTitle : String;
AboutWidth : Integer;
AboutHeight : Integer
);
Var
Spacer : TPanel;
Spacer2 : TPanel;
Spacer3 : TPanel;
About_Title : TLabel;
Title : TPanel_Cmp_Sec_ads;
AboutImage : TImage;
AboutBaseTopTop : TPanel;
ListBoxFirst : TListBox;
ListBox : TListBox;
Bevel1 : TBevel;
AboutBaseTop : TPanel;
OKButton : TButton;
AboutBaseButtons: TPanel;
AboutBase : TPanel;
Form : TForm;
MaxLength : Integer;
i : Integer;
Begin
Form := TForm.Create(Application);
Try
With Form Do
Begin
Left := 209;
Top := 108;
Width := AboutWidth;
Height := AboutHeight;
BorderIcons := [biSystemMenu];
Caption := 'About';
Font.Charset := DEFAULT_CHARSET;
Font.Color := clWindowText;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [];
Position := poScreenCenter;
PixelsPerInch := 96;
End;
AboutBase := TPanel.Create(Form);
With AboutBase Do
Begin
Parent := Form;
Left := 0;
Top := 0;
Width := 420;
Height := 322;
Align := alClient;
BevelOuter := bvNone;
BorderWidth := 10;
Caption := ' ';
TabOrder := 0;
End;
AboutBaseButtons:= TPanel.Create(Form);
With AboutBaseButtons Do
Begin
Parent := AboutBase;
Left := 10;
Top := 285;
Width := 400;
Height := 27;
Align := alBottom;
BevelOuter := bvNone;
Caption := ' ';
TabOrder := 0;
OKButton := TButton.Create(Form);
End;
With OKButton Do
Begin
Parent := AboutBaseButtons;
Left := 168;
Top := 1;
Width := 75;
Height := 25;
Caption := 'OK';
Default := True;
ModalResult := 1;
TabOrder := 0;
Align := alRight;
end;
AboutBaseTop := TPanel.Create(Form);
With AboutBaseTop Do
Begin
Parent := AboutBase;
Left := 10;
Top := 10;
Width := 400;
Height := 268;
Align := alClient;
BevelWidth := 2;
BorderWidth := 10;
Caption := ' ';
ParentColor := True;
TabOrder := 1;
Bevel1 := TBevel.Create(Form);
End;
With Bevel1 Do
Begin
Parent := AboutBaseTop;
Left := 12;
Top := 62;
Width := 376;
Height := 5;
Align := alTop;
end;
ListBoxFirst := TListBox.Create(Form);
With ListBoxFirst Do
Begin
Parent := AboutBaseTop;
Left := 12;
Top := 75;
Width := 376;
Height := 50;
Align := alTop;
BorderStyle := bsNone;
ItemHeight := 13;
ParentColor := True;
TabOrder := 0;
Font.Style := [fsBold];
Font.Name := 'Courier New';
Height := ItemHeight;
end;
ListBox := TListBox.Create(Form);
With ListBox Do
Begin
Parent := AboutBaseTop;
Left := 12;
Top := 75;
Width := 376;
Height := 181;
Align := alClient;
BorderStyle := bsNone;
ItemHeight := 13;
ParentColor := True;
TabOrder := 0;
Font.Style := [fsBold];
Font.Name := 'Courier New';
end;
AboutBaseTopTop := TPanel.Create(Form);
With AboutBaseTopTop Do
Begin
Parent := AboutBaseTop;
Left := 12;
Top := 12;
Width := 376;
Height := 45;
Align := alTop;
BevelOuter := bvNone;
Caption := ' ';
TabOrder := 1;
AboutImage := TImage.Create(Form);
End;
With AboutImage Do
Begin
Parent := AboutBaseTopTop;
Left := 0;
Top := 0;
Width := 56;
Height := 45;
Align := alLeft;
Stretch := True;
end;
Title := TPanel_Cmp_Sec_ads.Create(Form);
With Title Do
Begin
Parent := AboutBaseTopTop;
Left := 56;
Top := 0;
Width := 320;
Height := 45;
Align := alClient;
BevelOuter := bvNone;
Caption := AboutTitle;
Font.Charset := ANSI_CHARSET;
Font.Color := clWhite;
Font.Height := -21;
Font.Name := 'Times New Roman';
Font.Style := [fsBold];
ParentFont := False;
TabOrder := 0;
OnResize := ResizeShadowLabel;
End;
About_Title := TLabel.Create(Form);
With About_Title Do
Begin
Parent := Title;
Left := 69;
Top := 18;
Width := 40;
Height := 24;
Caption := AboutTitle;
Font.Charset := DEFAULT_CHARSET;
Font.Color := clNavy;
Font.Height := -21;
Font.Name := 'Times New Roman';
Font.Style := [fsBold];
ParentFont := False;
Transparent := True;
end;
Spacer2 := TPanel.Create(Form);
With Spacer2 Do
Begin
Parent := AboutBaseTop;
Left := 12;
Top := 57;
Width := 376;
Height := 5;
Align := alTop;
BevelOuter := bvNone;
Caption := ' ';
TabOrder := 2;
end;
Spacer3 := TPanel.Create(Form);
With Spacer3 Do
Begin
Parent := AboutBaseTop;
Left := 12;
Top := 67;
Width := 376;
Height := 8;
Align := alTop;
BevelOuter := bvNone;
Caption := ' ';
TabOrder := 3;
end;
Spacer := TPanel.Create(Form);
With Spacer Do
Begin
Parent := AboutBase;
Left := 10;
Top := 278;
Width := 400;
Height := 7;
Align := alBottom;
BevelOuter := bvNone;
Caption := ' ';
TabOrder := 2;
end;
ListBoxFirst.Items.Clear;
ListBoxFirst.Items.Add(
StringPad('Version Date',' ',20,True)+' = '+
FormatDateTime('mm/dd/yyyy',FileDate(Application.ExeName))
);
VersionInformation(ListBox);
AboutImage.Picture := TPicture(Application.Icon);
AboutImage.Width := AboutImage.Height;
If AboutHeight = 0 Then
Begin
Form.Height :=
AboutBaseButtons.Height +
Spacer .Height +
Spacer2 .Height +
Spacer3 .Height +
AboutBaseTopTop .Height +
Bevel1 .Height +
(ListBox.Items.Count * ListBox.ItemHeight) +
(ListBoxFirst.Items.Count * ListBoxFirst.ItemHeight)+
(AboutBaseTop.BorderWidth * 2) +
(AboutBase .BorderWidth * 2) +
(AboutBaseTop.BevelWidth * 4) +
26
;
End;
If AboutWidth = 0 Then
Begin
MaxLength := 0;
For i := 0 To ListboxFirst.Items.Count - 1 Do
Begin
If Length(ListBox.Items[i]) > MaxLength Then
Begin
MaxLength := Length(ListBox.Items[i]);
End;
End;
For i := 0 To Listbox.Items.Count - 1 Do
Begin
If Length(ListBox.Items[i]) > MaxLength Then
Begin
MaxLength := Length(ListBox.Items[i]);
End;
End;
If MaxLength < 23 Then
Begin
Form.Width :=
(AboutBaseTop.BorderWidth * 2) +
(AboutBase .BorderWidth * 2) +
(AboutBaseTop.BevelWidth * 4) +
400;
End
Else
Begin
Form.Width :=
(AboutBaseTop.BorderWidth * 2) +
(AboutBase .BorderWidth * 2) +
(AboutBaseTop.BevelWidth * 4) +
(MaxLength * 9);
End;
End;
Form.ShowModal;
Finally
Form.Free;
End;
End;
{!~ DIALOGABOUTBOX_ADS
This procedure presents an About Box.
TITLE The title is set by the AboutTitle parameter.
INFORMATION
The information displayed in the about box is pulled directly
from the executable. The programmer can configure this information
in Delphi by doing the following:
(1) in Delphi go to Project|Options|VersionInfo and make sure
that the check box for Include Version information in project
is checked.
(2)Auto-increment build number should also be checked so
that each time a build-all is run the version number is
automatically updated. This makes life simple and in automatic.
(3)Edit/Add items in the section at the bottom of this page
where key and value items are listed. Whatever you put in
this section is what will appear in the about box.
(2) Save the project and recompile
(3) The newly edited information will appear in the about box.
IMAGE
The Application Icon is presented as the image. To change the
image do the following:
(1) in Delphi go to Project|Options|Application|Load Icon
and select an Icon for the application
(2) Save the project and
recompile
(3) The newly selected Icon will appear in the about box.
SIZE
The About box size can be pased as the parameters AboutWidth
and AboutHeight. If however you wish to have the procedure
size the About Box automatically set these two parameters to
zero. }
//Unit Description UnitIndex Master Index
Procedure DialogAboutBox_ads(
AboutTitle : String;
AboutWidth : Integer;
AboutHeight : Integer
);
Begin
AboutBox_ads(AboutTitle, AboutWidth, AboutHeight);
End;
{!~ Returns The Month}
//Unit Description UnitIndex Master Index
Function Date_Month(DateValue: TDateTime): Integer;
Var
Year, Month, Day: Word;
Begin
Try
DecodeDate(DateValue, Year, Month, Day);
Result := Integer(Month);
Except
Result := -1;
End;
End;
{!~ Returns The Next Month}
//Unit Description UnitIndex Master Index
Function Date_MonthNext(DateValue: TDateTime): Integer;
Var
Year, Month, Day: Word;
CurMonth : Integer;
NewMonth : Integer;
Begin
Try
DecodeDate(DateValue, Year, Month, Day);
CurMonth := Integer(Month);
NewMonth := ((CurMonth + 12 + 1) mod 12);
If NewMonth = 0 Then NewMonth := 12;
Result := NewMonth;
Except
Result := -1;
End;
End;
{!~ Returns The Prior Month}
//Unit Description UnitIndex Master Index
Function Date_MonthPrior(DateValue: TDateTime): Integer;
Var
Year, Month, Day: Word;
CurMonth : Integer;
NewMonth : Integer;
Begin
Try
DecodeDate(DateValue, Year, Month, Day);
CurMonth := Integer(Month);
NewMonth := ((CurMonth + 24 - 1) mod 12);
If NewMonth = 0 Then NewMonth := 12;
Result := NewMonth;
Except
Result := -1;
End;
End;
{!~ Replace all occurances of OldSubString with NewSubString in SourceString}
//Unit Description UnitIndex Master Index
Function String_Replace(
OldSubString : String;
NewSubString : String;
SourceString : String): String;
Var
P : Integer;
S : String;
R : String;
LOld : Integer;
LNew : Integer;
Begin
S := SourceString;
R := '';
LOld := Length(OldSubString);
LNew := Length(NewSubString);
Result := S;
If OldSubString = '' Then Exit;
If SourceString = '' Then Exit;
P := Pos(OldSubString,S);
If P = 0 Then
Begin
R := S;
End
Else
Begin
While P <> 0 Do
Begin
Delete(S,P,LOld);
R := R + Copy(S,1,P-1)+NewSubString;
S := Copy(S,P,Length(S)-(P-1));
P := Pos(OldSubString,S);
If P = 0 Then R := R + S;
End;
End;
Result := R;
End;
{!~ Replace all occurances of OldSubString with NewSubString in SourceString ignoring case}
//Unit Description UnitIndex Master Index
Function String_Replace_NoCase(
OldSubString : String;
NewSubString : String;
SourceString : String): String;
Var
P : Integer;
S : String;
R : String;
LOld : Integer;
LNew : Integer;
UOld : String;
Begin
S := SourceString;
R := '';
LOld := Length(OldSubString);
LNew := Length(NewSubString);
UOld := UpperCase(OldSubString);
Result := S;
If OldSubString = '' Then Exit;
If SourceString = '' Then Exit;
P := Pos(UOld,UpperCase(S));
If P = 0 Then
Begin
R := S;
End
Else
Begin
While P <> 0 Do
Begin
Delete(S,P,LOld);
R := R + Copy(S,1,P-1)+NewSubString;
S := Copy(S, P,Length(S)-(P-1));
P := Pos(UOld,UpperCase(S));
If P = 0 Then R := R + S;
End;
End;
Result := R;
End;
{!~
STRING_LINEFEED_FORMAT
The String_LineFeed_Format function adjusts all line breaks in the given
string "SourceString" to be true CR/LF sequences. The function changes any
CR characters not followed by a LF and any LF characters not preceded by a
CR into CR/LF pairs. It also converts LF/CR pairs to CR/LF pairs. The LF/CR
pair is common in Unix text files.
}
//Unit Description UnitIndex Master Index
Function String_LineFeed_Format(SourceString : String): String;
Begin
Result := AdjustLineBreaks(SourceString);
End;
{!~ Inserts a Carriage Return/Line Feed at the index position.}
//Unit Description UnitIndex Master Index
Function String_LineFeed_Insert(SourceString : String; Index : Integer): String;
Var
L : Integer;
Begin
Result := SourceString;
L := Length(SourceString);
If SourceString = '' Then
Begin
Result := #13 + #10;
Exit;
End;
If Index > L Then
Begin
Result := SourceString + #13 + #10;
Exit;
End;
If Index <= 1 Then
Begin
Result := #13 + #10 + SourceString;
Exit;
End;
Result :=
Copy(SourceString,1,Index-1)+
#13+
#10+
Copy(SourceString,Index,L-(Index-1));
End;
{!~
Returns a string whose values are all reversed,i.e. , the
first character is last and the last is first.
}
//Unit Description UnitIndex Master Index
Function String_Reverse(S : String): String;
Var
i : Integer;
Begin
Result := '';
For i := Length(S) DownTo 1 Do
Begin
Result := Result + Copy(S,i,1);
End;
End;
{!~
Returns the smaller of two integers
}
//Unit Description UnitIndex Master Index
Function Min_I(Number1, Number2: Integer): Integer;
Begin
If Number1 < Number2 Then
Begin
Result := Number1;
End
Else
Begin
Result := Number2;
End;
End;
{!~
Returns the contents of a string between two tags. The tag
information is not returned. Finding the tags is case sensitive.
}
//Unit Description UnitIndex Master Index
Function String_Grep_Contents(Source, StartTag, EndTag: String): String;
Var
Containing : String; //A match must contain this string
BeforeString : String; //The substring prior to the match
MatchWithTags : String; //The match string including tags
MatchWithoutTags : String; //the match string without the tags
AfterString : String; //The substring after the match with tags
CaseSensitiveTags : Boolean; //True if tags are casesensitive
CaseSensitiveContaining : Boolean; //True if Containing string is casesensitive
Begin
Containing := ''; //A match must contain this string
BeforeString := ''; //The substring prior to the match
MatchWithTags := ''; //The match string including tags
MatchWithoutTags := ''; //the match string without the tags
AfterString := ''; //The substring after the match with tags
CaseSensitiveTags := False; //True if tags are casesensitive
CaseSensitiveContaining := False; //True if Containing string is casesensitive
String_Grep_Detail(
Source, //Source : String; //The input string
StartTag, //StartTag : String; //The start tag
EndTag, //EndTag : String; //The end tag
Containing, //Containing : String; //A match must contain this string
BeforeString, //Var BeforeString : String; //The substring prior to the match
MatchWithTags, //Var MatchWithTags : String; //The match string including tags
MatchWithoutTags, //Var MatchWithoutTags : String; //the match string without the tags
AfterString, //Var AfterString : String; //The substring after the match with tags
CaseSensitiveTags, //CaseSensitiveTags : Boolean; //True if tags are casesensitive
CaseSensitiveContaining //CaseSensitiveContaining : Boolean //True if Containing string is casesensitive
); //): Boolean; //True if a match was found
Result := MatchWithoutTags;
End;
{!~
STRING_GREP_DETAIL
This is a full featured grep function. All data associated
with the grep operation is returned. The substring before the
match section is stored in the BeforeString variable. The Match
Substring is stored in two variables. The variable MatchwithTags
stores the match substring wrapped in the Start and End Tags.
The variable MatchWithoutTags stores the match substring without
the Start and End Tags. CaseSensitivity can be toggled for both
the tags and the Containing String using the booleans
CaseSensitiveTags and CaseSensitiveContaining. For a match to be
successful it must satisfy all criteria. If the Containing String
is null this criteria is not applied.
}
//Unit Description UnitIndex Master Index
Function String_Grep_Detail(
Source : String; //The input string
StartTag : String; //The start tag
EndTag : String; //The end tag
Containing : String; //A match must contain this string
Var BeforeString : String; //The substring prior to the match
Var MatchWithTags : String; //The match string including tags
Var MatchWithoutTags : String; //the match string without the tags
Var AfterString : String; //The substring after the match with tags
CaseSensitiveTags : Boolean; //True if tags are casesensitive
CaseSensitiveContaining : Boolean //True if Containing string is casesensitive
): Boolean; //True if a match was found
Var
P_StartTag : Integer;
P_EndTag : Integer;
P_Containing : Integer;
S : String;
//MaxCount : Integer;
i : Integer;
Temp : String;
StartTagUpper : String;
EndTagUpper : String;
StartTagLen : Integer;
EndTagLen : Integer;
ContainingUpper : String;
Begin
S := Source;
Result := False;
BeforeString := '';
MatchWithTags := '';
MatchWithoutTags := '';
AfterString := S;
Temp := '';
StartTagUpper := UpperCase(StartTag);
EndTagUpper := UpperCase(EndTag);
StartTagLen := Length(StartTag);
EndTagLen := Length(EndTag);
ContainingUpper := UpperCase(Containing);
If CaseSensitiveTags Then
Begin
P_StartTag := Pos(StartTag,S);
End
Else
Begin
P_StartTag := Pos(StartTagUpper,UpperCase(S));
End;
If P_StartTag = 0 Then
Begin
Result := False;
BeforeString := Source;
MatchWithTags := '';
MatchWithoutTags := '';
AfterString := '';
Exit;
End
Else
Begin
BeforeString := BeforeString + Copy(S,1,P_StartTag-1);
S := Copy(S,P_StartTag,Length(S)-P_StartTag+1);
If CaseSensitiveTags Then
Begin
P_EndTag := Pos(EndTag,S);
End
Else
Begin
P_EndTag := Pos(EndTagUpper,UpperCase(S));
End;
If P_EndTag = 0 Then
Begin
Result := False;
BeforeString := Source;
MatchWithTags := '';
MatchWithoutTags := '';
AfterString := '';
Exit;
End
Else
Begin
Temp := Copy(S,StartTagLen+1,P_EndTag-StartTagLen-1);
If Containing = '' Then
Begin
Result := True;
MatchWithTags := StartTag+Temp+EndTag;
MatchWithoutTags := Temp;
AfterString := Copy(S,P_EndTag+EndTagLen,Length(S)-P_EndTag-EndTagLen+1);
Exit;
End;
If CaseSensitiveContaining Then
Begin
P_Containing := Pos(Containing,Temp);
End
Else
Begin
P_Containing := Pos(ContainingUpper,UpperCase(Temp));
End;
If P_Containing = 0 Then
Begin
BeforeString := BeforeString + Copy(S,1,P_EndTag+EndTagLen-1);
S := Copy(S,P_EndTag+EndTagLen,Length(S)-P_EndTag-EndTagLen+1);
End
Else
Begin
Result := True;
MatchWithTags := StartTag+Temp+EndTag;
MatchWithoutTags := Temp;
AfterString := Copy(S,P_EndTag+EndTagLen,Length(S)-P_EndTag-EndTagLen+1);
Exit;
End;
End;
End;
End;
{!~
All matches are added to the Stringlist.
}
//Unit Description UnitIndex Master Index
Function String_GrepAllToStringList(
Source : String; //The input string
StartTag : String; //The start tag
EndTag : String; //The end tag
Containing : String; //A match must contain this string
Var StringList : TStringList; //A List of Matches
CaseSensitiveTags : Boolean; //True if tags are casesensitive
CaseSensitiveContaining : Boolean //True if Containing string is casesensitive
): Boolean; //True if a match was found
Var
S : String;
FoundMatch : Boolean;
BeforeString : String; //The substring prior to the match
MatchWithTags : String; //The match string including tags
MatchWithoutTags : String; //the match string without the tags
AfterString : String; //The substring after the match with tags
Begin
Result := False;
StringList.Clear;
S := Source;
FoundMatch := False;
BeforeString := ''; //The substring prior to the match
MatchWithTags := ''; //The match string including tags
MatchWithoutTags := ''; //the match string without the tags
AfterString := ''; //The substring after the match with tags
FoundMatch:=
String_Grep_Detail(
S, //Source : String; //The input string
StartTag, //StartTag : String; //The start tag
EndTag, //EndTag : String; //The end tag
Containing, //Containing : String; //A match must contain this string
BeforeString, //Var BeforeString : String; //The substring prior to the match
MatchWithTags, //Var MatchWithTags : String; //The match string including tags
MatchWithoutTags, //Var MatchWithoutTags : String; //the match string without the tags
AfterString, //Var AfterString : String; //The substring after the match with tags
CaseSensitiveTags,//CaseSensitiveTags : Boolean; //True if tags are casesensitive
CaseSensitiveContaining);//CaseSensitiveContaining : Boolean //True if Containing string is casesensitive
//): Boolean; //True if a match was found
Result := FoundMatch;
While FoundMatch Do
Begin
StringList.Add(Trim(MatchWithoutTags));
S := AfterString;
FoundMatch:=
String_Grep_Detail(
S, //Source : String; //The input string
StartTag, //StartTag : String; //The start tag
EndTag, //EndTag : String; //The end tag
Containing, //Containing : String; //A match must contain this string
BeforeString, //Var BeforeString : String; //The substring prior to the match
MatchWithTags, //Var MatchWithTags : String; //The match string including tags
MatchWithoutTags, //Var MatchWithoutTags : String; //the match string without the tags
AfterString, //Var AfterString : String; //The substring after the match with tags
CaseSensitiveTags,//CaseSensitiveTags : Boolean; //True if tags are casesensitive
CaseSensitiveContaining);//CaseSensitiveContaining : Boolean //True if Containing string is casesensitive
//): Boolean; //True if a match was found
End;
End;
{!~
The purpose of this procedure is to extract URL information from
web pages stored in the Temporary Internet Files Directory.
The URL's gathered by this procedure are stored in a new HTML page given
by the OutputFile argument.
This procedure needs a working directory designated
by the WorkingDirectoryName argument. This working directory should
be for the exclusive use of this procedure because all files in the
directory are deleted at the beginning of the process.
The location of the Temporary Internet Files Directory is provided by
the TemporaryInternetDirectory argument.
A number of boolean options are provided in this procedure:
SortByLabels : Sort the Results by the Unit Description UnitIndex Master Index
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
Internet_GetURLsFromCachePages(
Edit1.Text, //TemporaryInternetDirectory : String;
GlobalExecutablePath+Edit2.Text, //WorkingDirectoryName : String;
Edit3.Text, //OutputFile : String;
CheckBox1.Checked, //SortByLabels : Boolean;
CheckBox2.Checked, //EliminateDuplicates : Boolean;
CheckBox3.Checked, //DiscardRelativePaths : Boolean;
CheckBox4.Checked, //EmptyCacheWhenDone : Boolean;
Memo1.Lines); //EliminateURLsContaining : TStrings);
end;
}
//Unit Description UnitIndex Master Index
procedure Internet_GetURLsFromCachePages(
TemporaryInternetDirectory : String;
WorkingDirectoryName : String;
OutputFile : String;
SortByLabels : Boolean;
EliminateDuplicates : Boolean;
DiscardRelativePaths : Boolean;
EmptyCacheWhenDone : Boolean;
EliminateURLsContaining : TStrings);
Var
T : TStringList;
U : TStringList;
D : TStringList;
i,j,c,p : Integer;
ToFile : String;
FromFile : String;
BeginTag : String;
EndTag : String;
Containing : String;
S : String;
begin
T := TStringList.Create();
U := TStringList.Create();
D := TStringList.Create();
Try
If TemporaryInternetDirectory = '' Then
Begin
Msg('The Web Cache Directory needs to be provided!');
Exit;
End;
If Not DirectoryExists(TemporaryInternetDirectory) Then
Begin
Msg('The Web Cache Directory is invalid!');
Exit;
End;
If OutputFile = '' Then
Begin
Msg('The Output File need to be provided!');
Exit;
End;
If Not DirectoryExists(ExtractFileDir(OutputFile)) Then
Begin
Msg('The Output File Directory is invalid!');
Exit;
End;
If Copy(TemporaryInternetDirectory,Length(TemporaryInternetDirectory),1) <> '\' Then
Begin
TemporaryInternetDirectory := TemporaryInternetDirectory + '\';
End;
//Get SubDirectories Under The Temporary Internet Directory
FilesInDirDetail(
D, //FileList : TStrings;
TemporaryInternetDirectory, //Directory : String;
'*.*', //Mask : String;
True, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
True, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
True, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
False, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
T.Clear;
If Copy(WorkingDirectoryName,Length(WorkingDirectoryName),1) <> '\' Then
Begin
WorkingDirectoryName := WorkingDirectoryName + '\';
End;
If Not DirectoryExists(WorkingDirectoryName) Then
ForceDirectories(WorkingDirectoryName);
//Empty the Working Directory
T.Clear;
FilesInDirDetail(
T, //FileList : TStrings;
WorkingDirectoryName, //Directory : String;
'*.*', //Mask : String;
False, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
False, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
False, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
True, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
For i := 0 To T.Count - 1 Do
Begin
SysUtils.DeleteFile(WorkingDirectoryName+T[i]);
End;
//Get Files From SubDirectories Under The Temporary Internet Directory
For c:= 0 To D.Count - 1 Do
Begin
T.Clear;
{!~ Populates a TStrings FileList with the files meeting selected
file attribute criteria in a directory. The mask argument is a
standard DOS file argument like '*.*. The InclDotFiles argument
allows the user to exclude the system files "." and ".." by
setting the value to False. If the Intersection argument is set
to true then the result will reflect only those files that satisfy
all attribute criteria. If Intersection is set to false then the
result will be a union of files that meet any of the criteria.}
S := TemporaryInternetDirectory+D[c]+'\';
FilesInDirDetail(
T, //FileList : TStrings;
S, //Directory : String;
'*.htm*', //Mask : String;
False, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
False, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
False, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
True, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
For i := 0 To T.Count - 1 Do
Begin
FromFile := TemporaryInternetDirectory+D[c]+'\'+T[i];
ToFile :=
WorkingDirectoryName+
FileNextNumberName(WorkingDirectoryName,'*.*')+
'.htm';
CopyFile(FromFile, ToFile);
End;
End;
T.Clear;
{!~ Populates a TStrings FileList with the files meeting selected
file attribute criteria in a directory. The mask argument is a
standard DOS file argument like '*.*. The InclDotFiles argument
allows the user to exclude the system files "." and ".." by
setting the value to False. If the Intersection argument is set
to true then the result will reflect only those files that satisfy
all attribute criteria. If Intersection is set to false then the
result will be a union of files that meet any of the criteria.}
FilesInDirDetail(
T, //FileList : TStrings;
WorkingDirectoryName, //Directory : String;
'*.*', //Mask : String;
False, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
False, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
False, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
True, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
For i := 0 To T.Count - 1 Do
Begin
U.Clear;
U.LoadFromFile(WorkingDirectoryName+T[i]);
S := U.Text;
S := String_LineFeed_Format(S);
S :=
String_Replace(
#13+#10, //OldSubString : String;
'', //NewSubString : String;
S); //SourceString : String): String;
U.SetText(PChar(S));
T.Append(U.Text);
End;
//Capture Raw URL Information
U.Clear;
BeginTag := '';
Containing := '';
{!~ All matches are added to the Stringlist.}
String_GrepAllToStringList(
T.Text, //Source : String; //The input string
BeginTag, //StartTag : String; //The start tag
EndTag, //EndTag : String; //The end tag
Containing, //Containing : String; //A match must contain this string
U, //Var StringList : TStringList; //A List of Matches
False, //CaseSensitiveTags : Boolean; //True if tags are casesensitive
True); //CaseSensitiveContaining : Boolean //True if Containing string is casesensitive
//): Boolean; //True if a match was found
U.Sorted := True;
U.Sorted := False;
//Eliminate Partial Paths If Required
T.Clear;
If DiscardRelativePaths Then
Begin
For I := 0 To U.Count - 1 Do
Begin
If Pos('HTTP://',UpperCase(U[i])) > 0 Then T.Add(''+BeginTag+U[i]+EndTag+' ');
End;
End;
U.Clear;
U.Assign(T);
//Eliminate Duplicates If Required
T.Clear;
If EliminateDuplicates Then
Begin
T.Duplicates := dupIgnore;
For I := 0 To U.Count - 1 Do
Begin
T.Add(U[i]);
End;
T.Duplicates := dupAccept;
End;
U.Clear;
U.Assign(T);
//Eliminate everything but URL's
T.Clear;
For i := 0 To U.Count - 1 Do
Begin
Trim(U[i]);
If UpperCase(Copy(U[i],1,4)) = '' Then T.Add(U[i]);
End;
U.Clear;
U.Assign(T);
For j := 0 To EliminateURLsContaining.Count - 1 Do
Begin
T.Clear;
For i := 0 To U.Count - 1 Do
Begin
Trim(U[i]);
If Pos(UpperCase(EliminateURLsContaining[j]),UpperCase(U[i])) < 1 Then T.Add(U[i]);
End;
U.Clear;
U.Assign(T);
End;
If SortByLabels Then
Begin
T.Clear;
T.Sorted := True;
If EliminateDuplicates Then
Begin
T.Duplicates := dupIgnore;
End
Else
Begin
T.Duplicates := dupAccept;
End;
For i := 0 To U.Count - 1 Do
Begin
S := String_Reverse(U[i]);
p := Pos(UpperCase('>il/<>a/<'),S);
S := Copy(S,P+10,Length(S)-10);
p := Pos('>',S);
S := Copy(S,1,p-1);
S := Trim(s);
S := String_Reverse(S);
S := StringPad(S,' ',150,True);
S := S + U[i];
Try
T.Add(S);
Except
End;
End;
U.Clear;
U.Assign(T);
T.Sorted := False;
T.Duplicates := dupAccept;
For i := 0 To U.Count - 1 Do
Begin
U[i] := Copy(U[i],151,Length(U[i])-150);
End;
End;
T.Clear;
T.Add('');
T.Add('');
T.Add('');
T.Append(U.Text);
T.Add('
');
T.Add('');
T.Add('');
T.SaveToFile(OutputFile);
If EmptyCacheWhenDone Then
Begin
Internet_EmptyCacheDirectories(TemporaryInternetDirectory);
End;
Finally
T.Free;
U.Free;
D.Free;
End;
end;
{!~ Empties the Temporary Internet Files directory}
// Unit Description UnitIndex Master Index
procedure Internet_EmptyCacheDirectories(
TemporaryInternetDirectory : String);
Var
i,j: Integer;
T : TStringList;
D : TStringList;
begin
T := TStringlist.Create();
D := TStringList.Create();
Try
If TemporaryInternetDirectory = '' Then
Begin
Msg('The Web Cache Directory needs to be provided!');
Exit;
End;
If Not DirectoryExists(TemporaryInternetDirectory) Then
Begin
Msg('The Web Cache Directory is invalid!');
TemporaryInternetDirectory := '';
Exit;
End;
If Copy(TemporaryInternetDirectory,Length(TemporaryInternetDirectory),1) <> '\' Then
Begin
TemporaryInternetDirectory := TemporaryInternetDirectory + '\';
End;
FilesInDirDetail(
D, //FileList : TStrings;
TemporaryInternetDirectory, //Directory : String;
'*.*', //Mask : String;
True, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
True, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
True, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
False, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
For J := 0 To D.Count - 1 Do
Begin
T.Clear;
FilesInDirDetail(
T, //FileList : TStrings;
TemporaryInternetDirectory+D[j]+'\', //Directory : String;
'*.*', //Mask : String;
False, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
False, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
False, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
True, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
For i := 0 To T.Count - 1 Do
Begin
SysUtils.DeleteFile(TemporaryInternetDirectory+D[j]+'\'+T[i]);
End;
End;
Finally
T.Free;
D.Free;
End;
end;
{!~ Empties a directory of normal files.}
//Unit Description UnitIndex Master Index
Function EmptyDirectory(Directory : String): Boolean;
Var
T : TStringList;
i : Integer;
Begin
T := TStringList.Create();
Try
Result := False;
If Copy(Directory,Length(Directory),1) <> '\' Then
Directory := Directory + '\';
If Not DirectoryExists(Directory) Then Exit;
{!~ Populates a TStrings FileList with the files meeting selected
file attribute criteria in a directory. The mask argument is a
standard DOS file argument like '*.*. The InclDotFiles argument
allows the user to exclude the system files "." and ".." by
setting the value to False. If the Intersection argument is set
to true then the result will reflect only those files that satisfy
all attribute criteria. If Intersection is set to false then the
result will be a union of files that meet any of the criteria.}
FilesInDirDetail(
T, //FileList : TStrings;
Directory, //Directory : String;
'*.*', //Mask : String;
False, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
False, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
False, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
True, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
Result := True;
For i := 0 To T.Count - 1 Do
Begin
Try
DeleteFile(PChar(Directory+T[i]));
Except
Result := False;
End;
End;
Finally
T.Free;
End;
End;
{Replaces all occurances of specified substring in a String. This will have problems if
the OldSubString is Contained in the NewSubstring. This is case sensitive.}
//Unit Description UnitIndex Master Index
Function ReplaceSubStringInString(OldSubString,NewSubString,InputString: String): String;
Var
CharPos : Integer;
L_O : Integer;
Begin
Result := InputString;
L_O := Length(OldSubString);
While True Do
Begin
CharPos := Pos(OldSubString,InputString);
If Not (CharPos = 0) Then
Begin
Delete(InputString,CharPos,L_O);
Insert(NewSubString,InputString,CharPos);
End
Else
Begin
Break;
End;
End;
Result := InputString;
End;
{Replaces all occurances of specified substring in a String. This will have problems if
the OldSubString is Contained in the NewSubstring. This is case insensitive.}
//Unit Description UnitIndex Master Index
Function ReplaceSubStringInStringNoCase(OldSubString,NewSubString,InputString: String): String;
Var
CharPos : Integer;
L_O : Integer;
U_O : String;
Begin
Result := InputString;
L_O := Length(OldSubString);
U_O := UpperCase(OldSubString);
While True Do
Begin
CharPos := Pos(U_O,UpperCase(InputString));
If Not (CharPos = 0) Then
Begin
Delete(InputString,CharPos,L_O);
Insert(NewSubString,InputString,CharPos);
End
Else
Begin
Break;
End;
End;
Result := InputString;
End;
{Deletes all occurances of specified substring in a String and is case
insensitive.}
//Unit Description UnitIndex Master Index
Function DeleteSubStringInStringNoCase(substring,InputString: String): String;
Var
CharPos : Integer;
l : Integer;
U_S : String;
Begin
Result := InputString;
l := Length(SubString);
U_S := UpperCase(SubString);
While True Do
Begin
CharPos := Pos(U_S,UpperCase(InputString));
If Not (CharPos = 0) Then
Delete(InputString,CharPos,l)
Else
Break;
End;
Result := InputString;
End;
{!~ Deletes all LineFeed Carriage Returns}
//Unit Description UnitIndex Master Index
function DeleteLineBreaks(const S: string): string;
var
Source, SourceEnd: PChar;
begin
Source := Pointer(S);
SourceEnd := Source + Length(S);
while Source < SourceEnd do
begin
case Source^ of
#10: Source^ := #32;
#13: Source^ := #32;
end;
Inc(Source);
end;
Result := S;
end;
{!~ Sets a File Date.}
//Unit Description UnitIndex Master Index
Function SetFileDate(
Const FileName : String;
Const FileDate : TDateTime): Boolean;
Var
FileHandle : THandle;
FileSetDateResult : Integer;
Begin
Try
Try
FileHandle := FileOpen(FileName, fmOpenWrite OR fmShareDenyNone);
If FileHandle > 0 Then
Begin
FileSetDateResult :=
FileSetDate(
FileHandle,
DateTimeToFileDate(FileDate));
Result := (FileSetDateResult = 0);
End;
Except
Result := False;
End;
Finally
FileClose (FileHandle);
End;
End;
{!~ Returns the Creation Date for a file.}
//Unit Description UnitIndex Master Index
Function File_GetCreationDate(FileName : String): TDateTime;
var
SearchRec : TSearchRec;
DT : TFileTime;
ST : TSystemTime;
begin
Result := 0;
If Not FileExists(FileName) Then Exit;
Try
SysUtils.FindFirst(FileName, faAnyFile, SearchRec);
Try
FileTimeToLocalFileTime(SearchRec.FindData.ftCreationTime,DT);
FileTimeToSystemTime(DT, ST);
Result := SystemTimeToDateTime(ST);
Finally
SysUtils.FindClose(SearchRec);
End;
Except
Result := 0;
End;
end;
{!~ Returns the Date a file was last accessed.}
//Unit Description UnitIndex Master Index
Function File_GetLastAccessDate(FileName : String): TDateTime;
var
SearchRec : TSearchRec;
DT : TFileTime;
ST : TSystemTime;
begin
Result := 0;
If Not FileExists(FileName) Then Exit;
Try
SysUtils.FindFirst(FileName, faAnyFile, SearchRec);
Try
FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT);
FileTimeToSystemTime(DT, ST);
Result := SystemTimeToDateTime(ST);
Finally
SysUtils.FindClose(SearchRec);
End;
Except
Result := 0;
End;
end;
{!~ Returns the Date a file was last modified.}
//Unit Description UnitIndex Master Index
Function File_GetLastModifiedDate(FileName : String): TDateTime;
var
SearchRec : TSearchRec;
DT : TFileTime;
ST : TSystemTime;
begin
Result := 0;
If Not FileExists(FileName) Then Exit;
Try
SysUtils.FindFirst(FileName, faAnyFile, SearchRec);
Try
FileTimeToLocalFileTime(SearchRec.FindData.ftLastWriteTime,DT);
FileTimeToSystemTime(DT, ST);
Result := SystemTimeToDateTime(ST);
Finally
SysUtils.FindClose(SearchRec);
End;
Except
Result := 0;
End;
end;
{!~ Returns the Long File Name of a file.}
//Unit Description UnitIndex Master Index
Function File_GetLongFileName(FileName : String): String;
var
SearchRec : TSearchRec;
begin
Result := '';
If Not FileExists(FileName) Then Exit;
Try
SysUtils.FindFirst(FileName, faAnyFile, SearchRec);
Try
Result := String(SearchRec.FindData.cFileName);
Finally
SysUtils.FindClose(SearchRec);
End;
Except
Result := '';
End;
end;
{!~ Returns the Short File Name of a file.}
//Unit Description UnitIndex Master Index
Function File_GetShortFileName(FileName : String): String;
var
SearchRec : TSearchRec;
begin
Result := '';
If Not FileExists(FileName) Then Exit;
Try
SysUtils.FindFirst(FileName, faAnyFile, SearchRec);
Try
Result := String(SearchRec.FindData.cAlternateFileName);
Finally
SysUtils.FindClose(SearchRec);
End;
Except
Result := '';
End;
end;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
//Unit Description UnitIndex Master Index
Function DelTree(DirectoryName: String): Boolean;
begin
Result :=
File_DirOperations_Detail(
'DELETE', //Action : String; //COPY, DELETE, MOVE, RENAME
False, //RenameOnCollision : Boolean; //Renames if directory exists
True, //NoConfirmation : Boolean; //Responds "Yes to All" to any dialogs
True, //Silent : Boolean; //No progress dialog is shown
False, //ShowProgress : Boolean; //displays progress dialog but no file names
DirectoryName,//FromDir : String; //From directory
'' //ToDir : String //To directory
);
end;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
//Unit Description UnitIndex Master Index
Function KillDirectory(DirectoryName: String): Boolean;
Begin
Result := DelTree(DirectoryName);
End;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
//Unit Description UnitIndex Master Index
Function File_KillDirectory(DirectoryName: String): Boolean;
Begin
Result := DelTree(DirectoryName);
End;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
//Unit Description UnitIndex Master Index
Function File_DelTree(DirectoryName: String): Boolean;
Begin
Result := DelTree(DirectoryName);
End;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
//Unit Description UnitIndex Master Index
Function File_DeleteDirectory(DirectoryName: String): Boolean;
Begin
Result := DelTree(DirectoryName);
End;
{!~ Completely deletes a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
//Unit Description UnitIndex Master Index
Function File_RemoveDirectory(DirectoryName: String): Boolean;
Begin
Result := DelTree(DirectoryName);
End;
{!~ ReNames a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
//Unit Description UnitIndex Master Index
Function File_ReNameDirectory(
OldDirectoryName: String;
NewDirectoryName: String): Boolean;
begin
Result :=
File_DirOperations_Detail(
'RENAME', //Action : String; //COPY, DELETE, MOVE, RENAME
False, //RenameOnCollision : Boolean; //Renames if directory exists
True, //NoConfirmation : Boolean; //Responds "Yes to All" to any dialogs
True, //Silent : Boolean; //No progress dialog is shown
False, //ShowProgress : Boolean; //displays progress dialog but no file names
OldDirectoryName,//FromDir : String; //From directory
NewDirectoryName //ToDir : String //To directory
);
end;
{!~ ReNames a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
//Unit Description UnitIndex Master Index
Function ReNameDir(OldDirName, NewDirName: String): Boolean;
Begin
Result := File_ReNameDirectory(OldDirName, NewDirName);
End;
{!~ ReNames a directory regardless of whether the directory
is filled or has subdirectories. No confirmation is requested so be careful.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise}
//Unit Description UnitIndex Master Index
Function ReNameDirectory(
OldDirectoryName: String;
NewDirectoryName: String): Boolean;
Begin
Result := File_ReNameDirectory(OldDirectoryName, NewDirectoryName);
End;
{Removes A Directory}
//Unit Description UnitIndex Master Index
Function RD(DirName: String): Boolean;
Begin
Result := DelTree(DirName);
End;
{!~ Copies a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise.}
//Unit Description UnitIndex Master Index
Function File_CopyDirectory(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
begin
Result :=
File_DirOperations_Detail(
'COPY', //Action : String; //COPY, DELETE, MOVE, RENAME
False, //RenameOnCollision : Boolean; //Renames if directory exists
True, //NoConfirmation : Boolean; //Responds "Yes to All" to any dialogs
True, //Silent : Boolean; //No progress dialog is shown
False, //ShowProgress : Boolean; //displays progress dialog but no file names
SourceDirectoryName,//FromDir : String; //From directory
DestDirectoryName //ToDir : String //To directory
);
end;
{!~ Copies a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise.}
//Unit Description UnitIndex Master Index
Function CopyDirectory(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
Begin
Result := File_CopyDirectory(SourceDirectoryName, DestDirectoryName);
End;
{!~ Copies a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise.}
//Unit Description UnitIndex Master Index
Function DirectoryCopy(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
Begin
Result := File_CopyDirectory(SourceDirectoryName, DestDirectoryName);
End;
{!~ Moves a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise.}
//Unit Description UnitIndex Master Index
Function File_MoveDirectory(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
begin
Result :=
File_DirOperations_Detail(
'MOVE', //Action : String; //COPY, DELETE, MOVE, RENAME
False, //RenameOnCollision : Boolean; //Renames if directory exists
True, //NoConfirmation : Boolean; //Responds "Yes to All" to any dialogs
True, //Silent : Boolean; //No progress dialog is shown
False, //ShowProgress : Boolean; //displays progress dialog but no file names
SourceDirectoryName,//FromDir : String; //From directory
DestDirectoryName //ToDir : String //To directory
);
end;
{!~ Moves a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise.}
//Unit Description UnitIndex Master Index
Function MoveDirectory(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
Begin
Result := File_MoveDirectory(SourceDirectoryName, DestDirectoryName);
End;
{!~ Moves a directory regardless of whether the directory is filled or has subdirectories.
This is a powerful utility. If the operation is successful then True is
returned, False otherwise.}
//Unit Description UnitIndex Master Index
Function DirectoryMove(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
Begin
Result := File_MoveDirectory(SourceDirectoryName, DestDirectoryName);
End;
{!~ File_DirOperations_Detail
This is the directory management engine that is used by a number of other
file management functions. This function can COPY, DELETE, MOVE, and RENAME
directories.}
//Unit Description UnitIndex Master Index
Function File_DirOperations_Detail(
Action : String; //COPY, DELETE, MOVE, RENAME
RenameOnCollision : Boolean; //Renames if directory exists
NoConfirmation : Boolean; //Responds "Yes to All" to any dialogs
Silent : Boolean; //No progress dialog is shown
ShowProgress : Boolean; //displays progress dialog but no file names
FromDir : String; //From directory
ToDir : String //To directory
): Boolean;
var
SHFileOpStruct : TSHFileOpStruct;
FromBuf, ToBuf: Array [0..255] of Char;
begin
Try
If Not DirectoryExists(FromDir) Then
Begin
Result := False;
Exit;
End;
Fillchar(SHFileOpStruct, Sizeof(SHFileOpStruct), 0 );
FillChar(FromBuf, Sizeof(FromBuf), 0 );
FillChar(ToBuf, Sizeof(ToBuf), 0 );
StrPCopy(FromBuf, FromDir);
StrPCopy(ToBuf, ToDir);
With SHFileOpStruct Do
Begin
Wnd := 0;
If UpperCase(Action) = 'COPY' Then wFunc := FO_COPY;
If UpperCase(Action) = 'DELETE' Then wFunc := FO_DELETE;
If UpperCase(Action) = 'MOVE' Then wFunc := FO_MOVE;
If UpperCase(Action) = 'RENAME' Then wFunc := FO_RENAME;
pFrom := @FromBuf;
pTo := @ToBuf;
fFlags := FOF_ALLOWUNDO;
If RenameOnCollision Then fFlags := fFlags or FOF_RENAMEONCOLLISION;
If NoConfirmation Then fFlags := fFlags or FOF_NOCONFIRMATION;
If Silent Then fFlags := fFlags or FOF_SILENT;
If ShowProgress Then fFlags := fFlags or FOF_SIMPLEPROGRESS;
End;
Result := (SHFileOperation(SHFileOpStruct) = 0);
Except
Result := False;
End;
end;
{Returns The First Day Of the Week, i.e., Sunday, As A TDateTime. If an
error occurs then zero is returned.}
//Unit Description UnitIndex Master Index
Function Date_FirstDayOfWeek(DateValue: TDateTime): TDateTime;
Begin
Try
Result := DateValue - (DayOfWeek(DateValue)) +1;
Except
Result := 0;
End;
End;
{Returns The First Day Of next Week, i.e., Sunday, As A TDateTime. If an
error occurs then zero is returned.}
//Unit Description UnitIndex Master Index
Function Date_FirstDayOfNextWeek(DateValue: TDateTime): TDateTime;
Begin
Result := Date_FirstDayOfWeek(DateValue+7);
End;
{Returns The First Day Of Last Week, i.e., Sunday, As A TDateTime. If an
error occurs then zero is returned.}
//Unit Description UnitIndex Master Index
Function Date_FirstDayOfLastWeek(DateValue: TDateTime): TDateTime;
Begin
Result := Date_FirstDayOfWeek(DateValue-7);
End;
End.
//