{Copyright(c)2000 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
maley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to maley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
Please note if you are viewing this Delphi unit as a web page all you have to
do to turn it into a Delphi unit is save it with a ".pas" extension. The
html in the unit should not affect its performance.
}
Unit ads_Com;
(*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 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 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 := Current