{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_File;
(*UnitIndex Master Index Implementation Section Download UnitsDescription: ads_File.pas This unit contains the following routines.
ApOnlyOneInstance AppClose AppExecute AppHandle AppIsRunning AppLoad AppSwitchTo AppTerminate CD CompressDups CompressMax CopyDirectory CopyFile CopyFiles DeCompressMax DeleteFiles DelTree Directory DirectoryCopy DirectoryHide DirectoryMove DirectoryUnHide EmptyDirectory ExecutableUpdate ExecuteExe ExecuteExeParams ExecuteKnownFileType ExecuteNewProcess ExtractFileExtNoPeriod ExtractFileNameNoExt 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 FileFilterChar FileMove FileName FileNextNumberName FileNotTextSize FilePath FilesInDirDetail FileToProcInUnit GetDiskFreeSpace GetFileSize GetFileSize_ads Internet_EmptyCacheDirectories IsDir IsDirEmpty IsFile KillDirectory MD MoveDirectory NumberDirFiles RD ReNameDir ReNameDirectory SetFileDate TDoc_MainForm.Button2Click TDoc_MainForm.Button3Click TForm1.Button1Click TForm1.Button2Click TForm1.Button3Click WinExecute WinExecute32
*)
Interface
Uses Windows, Classes, Forms, Dialogs, SysUtils, FileCtrl, ShellAPI;
Procedure ApOnlyOneInstance;
procedure NumberDirFiles(
Directory : String;
StartNumber : Integer);
function GetFileSize_ads(const FileName: string): DWord;
function GetFileSize(const FileName: string): LongInt;
Function GetDiskFreeSpace(DriveLetter : String): Int64;
Function DeCompressMax(Var lstChr : TStringList; Var lstReplace: TStringList): Boolean;
Function CompressMax(Var lstChr : TStringList; Var lstReplace: TStringList): Integer;
{
CompressDups
This function replaces all duplicate character pairs with a new
single character value. Only duplicates with 3 or more occurances
are replaced.
The replacement values start at 267 and range up to 999.
This function returns True if more compression can be achieved
and false if there is no more opportunity for compression.
Maximum compression would be achieved by using this function
recursively until it returns False indicating that no further
compression can be achieved.
lstChr :
The lstChr argument is a TStringList variable that assumes special
formatting. It is assumed that this StringList contains each byte
from a file on individual lines in sequential order as their ascii
equilavent value with padded zeroes to the left for a width of 3.
An example would be:
lstChr[ 1] := '073';
lstChr[ 2] := '073';
lstChr[ 3] := '042';
lstChr[ 4] := '000';
lstChr[ 5] := '008';
lstChr[ 6] := '000';
lstChr[ 7] := '000';
lstChr[ 8] := '000';
lstChr[ 9] := '017';
lstChr[10] := '000';
lstChr[11] := '254';
lstChr[12] := '000';
lstChr[13] := '004';
lstChr[14] := '000';
lstChr[15] := '001';
lstChr[16] := '000';
lstChr[17] := '000';
This StringList is both an Input an Output variable. If compression
is achieved lstChr is replaced with the new values.
lstReplace :
The lstReplace argument is a TStringList variable that assumes special
formatting. It is assumed that this StringList contains each of the
replacement character definitions in sequential order. To restore the
original byte stream the replacements would need to be made in reverse
order.
An example would be:
lstReplace[ 1] := '0000257_000000';
lstReplace[ 2] := '0000258_065254';
lstReplace[ 3] := '0000259_137212';
lstReplace[ 4] := '0000260_178132';
lstReplace[ 5] := '0000261_151098';
boStartFirst :
The boStartFirst argument is a boolean that determines where the Character
pairs start. If boStartFirst is True then the first character pair is made
up of the first and second characters. If boStartFirst is False then the
first character pair is only the first character and the second character
pair is made up of the second and third characters. Different matches occur
depending on where the pairing starts. For maximum compression first run
all the boStartFirst=True Then Run all the boStartFirst=False.
}
Function CompressDups(
Var lstChr : TStringList;
Var lstReplace : TStringList;
boStartFirst : Boolean): Boolean;
{!~
FileToProcInUnit
Converts a File to a Procedure in a Delphi Unit
Arguments
FromFile : The full name and path of the file to be converted to a procedure.
NewUnitPath : The path to the new Delphi Unit that will be created.
NewUnitNoExt : The name of the new Delphi Unit without any file extension.
ResourceName : The variable name that will be associated with this file.
Example
//The following procedure creates a Delphi Unit called oasis_resstr01.pas.
//The path to this unit is contained in the variable GlobalExecutablePath.
//The file being converted to a procedure is GlobalCacheDir+'blank.tif'.
//The variable name assocated with this file is BlankPage.
procedure TDoc_MainForm.Button2Click(Sender: TObject);
begin
FileToProcInUnit(
GlobalCacheDir+'blank.tif',//FromFile,
GlobalExecutablePath,//ResFilePath,
'oasis_resstr01',//ResFileNoExt,
'BlankPage');//ResourceName:String): Boolean;
end;
//The following procedure uses the generated procedure to create a file
//called TestTif.
procedure TDoc_MainForm.Button3Click(Sender: TObject);
begin
WriteFileBlankPage(
GlobalExecutablePath,//ToFilePath : String;
'TestTif' //ToFileNameNoExt : String
); //);
end;
}
Function FileToProcInUnit(
FromFile,
NewUnitPath,
NewUnitNoExt,
ResourceName: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;
{!~ Changes Directory}
Function CD(DirName: 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.}
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;
{!~ 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;
{!~ Deletes Files}
Function DeleteFiles(FilePath,FileMask: String): Boolean;
{!~ 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.}
Function DirectoryCopy(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
{!~ Hides a directory. Returns true if
successful and false otherwise}
Function DirectoryHide(Const FileString : 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;
{!~ UnHides a directory. Returns true if
successful and false otherwise}
Function DirectoryUnHide(Const FileString : String): Boolean;
{!~
Empties a directory of normal files.
}
Function EmptyDirectory(Directory : String): Boolean;
{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;
{!~Executes an executable in a completely new process}
Function ExecuteNewProcess(
FileName : String;
Visibility : integer):integer;
{!~ 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 Files Date Time Stamp as TDateTime.
Returns 0 if there is an error}
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;
{!~This is a file handling routine. This function reads a file (FromFile) ...
searching for every occurrance of OldChar and replacing it with NewString. ...
The changed file is output to ToFile.}
{Copies A File}
Function FileFilterChar(
FromFile : String;
ToFile : String;
OldChar : Char;
NewString : ShortString): 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 next available file name number as a string
in the format 00000001}
Function FileNextNumberName(
Directory : String;
Mask : String
): String;
{!~ Returns The File size in bytes. Does not work on a text file.}
Function FileNotTextSize(FileString: String): LongInt;
{!~ Returns The File Path Without The Name, Extension ,Period or trailing Backslash}
Function FilePath(FileString: String): 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.}
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_DelTree(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_DeleteDirectory(DirectoryName: String): Boolean;
{!~ 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.}
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;
{!~ 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;
{!~ 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;
{!~ 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;
{!~
Empties the Temporary Internet Files directory.
Only validated with MS Internet Explorer 3.02
}
procedure Internet_EmptyCacheDirectories(
TemporaryInternetDirectory : String);
{!~ Tests Directory Existence}
Function IsDir(IsDirPath: String): Boolean;
{!~ Returns True If Directory Is Empty, False Otherwise}
Function IsDirEmpty(DirName: String): Boolean;
{!~ Returns True If The File Exists, False Otherwise}
Function IsFile(DirName: 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 KillDirectory(DirectoryName: String): Boolean;
{!~ Makes A Directory}
Function MD(DirName: 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 MoveDirectory(
SourceDirectoryName: String;
DestDirectoryName: String): Boolean;
{!~ Removes A Directory}
Function RD(DirName: 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 ReNameDir(OldDirName, NewDirName: 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 ReNameDirectory(
OldDirectoryName: String;
NewDirectoryName: String): Boolean;
{!~ Sets a File Date.}
Function SetFileDate(
Const FileName : String;
Const FileDate : TDateTime): Boolean;
{!~ Executes An External Executable}
Function WinExecute(ApToExec: String): THandle;
{!~ Executes An External Executable}
Function WinExecute32(
FileName : String;
Visibility : integer):integer;
implementation
Uses Ads_Strg, Ads_Conv;
{!~ ApOnlyOneInstance
Allows only one instance of an executable}
//Unit Description UnitIndex Master Index
Procedure ApOnlyOneInstance;
Var
ApOnlyOneInstanceHandle : THandle;
MainCaption : String;
Begin
ApOnlyOneInstanceHandle := CreateMutex(nil, False, PChar(ParamStr(0)));
If ApOnlyOneInstanceHandle < 1 Then
Begin
MainCaption := Application.MainForm.Caption;
ShowMessage('Only one instance of the application can run at a time.');
Halt;
End;
End;
{!~ AppClose
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
example:
This ButtonClick Closes Solitaire if it is open
//Unit Description UnitIndex Master Index
procedure TForm1.Button2Click(Sender: TObject);
begin
AppClose('Sol','Solitaire');
end;
}
//Unit Description UnitIndex Master Index
procedure AppClose(ExecutableName,WinClassName : String);
Begin
If AppIsRunning(WinClassName) Then
Begin
If AppTerminate(ExecutableName) Then Exit;;
End;
end;
{!~ AppExecute
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
example:
This ButtonClick activates Solitaire
//Unit Description UnitIndex Master Index
procedure TForm1.Button1Click(Sender: TObject);
begin
AppExecute('SOL.EXE','Sol');
end;
}
//Unit Description UnitIndex Master Index
procedure AppExecute(
ExecutableName : String;
WinClassName : String);
Begin
If Not AppSwitchTo(WinClassName) Then
Begin
AppLoad(ExecutableName,SW_SHOWNORMAL)
End;
End;
{!~ AppHandle
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;
{!~ AppIsRunning
Returns True if Application is running, False otherwise
example:
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;
}
//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;
{!~ AppLoad
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;
{!~ AppSwitchTo
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;
{!~ AppTerminate
A SubRoutine of AppClose}
//Unit Description UnitIndex Master Index
Function AppTerminate(AppName: String): Boolean;
{$IFDEF NOT WIN32}
Var
Task : TTaskEntry;
CurName : String;
i : Integer;
{$ENDIF}
Begin
Result := False;
If Not (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;
{!~ CD
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 Not (IOResult = 0) Then
Begin
Result := False;
End
Else
Begin
Result := True;
End;
End;
End;
{!~ CopyDirectory
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;
{!~ CopyFile
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);
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 (Not (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;
{!~ CopyFiles
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;
{!~ DelTree
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;
{!~ DeleteFiles
Deletes Files}
//Unit Description UnitIndex Master Index
Function DeleteFiles(FilePath,FileMask: String): Boolean;
var
DeleteFilesSearchRec: TSearchRec;
PreviousFileName, ThisFileName: String;
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
ThisFileName:= FilePath+'\'+DeleteFilesSearchRec.Name;
DeleteFile(
{$IFDEF WIN32}ConvertStringToPChar({$ENDIF}
FilePath+'\'+DeleteFilesSearchRec.Name
{$IFDEF WIN32}){$ENDIF}
);
If ThisFileName=PreviousFileName then begin
Result:= False;
Exit;
end;
PreviousFileName:= ThisFileName;
End;
End;
End;
End;
{!~ Directory
Returns Current Working Directory}
//Unit Description UnitIndex Master Index
Function Directory: String;
Var
DirName: String;
Begin
GetDir(0,DirName);
Result := DirName;
End;
{!~ DirectoryCopy
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;
{!~ DirectoryHide
Hides a directory. Returns true if
successful and false otherwise}
//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;
{!~ DirectoryMove
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;
{!~ DirectoryUnHide
UnHides a directory. Returns true if
successful and false otherwise}
//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;
{!~ EmptyDirectory
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 Not (Copy(Directory,Length(Directory),1) = '\') Then
Directory := Directory + '\';
If Not DirectoryExists(Directory) Then Exit;
{!~ FilesInDirDetail
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
If FileExists(Directory+T[i]) Then DeleteFile(PChar(Directory+T[i]));
Except
Result := False;
End;
End;
Finally
T.Free;
End;
End;
{!~ ExecutableUpdate
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 FileExists(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 FileExists(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');
ShowMessage('The Software is going to be upgraded');
ExecuteKnownFileType(
Handle,
ExecutablePath+
ExecutableName+
'.bat');
Result := True;
Finally
Bat.Clear;
If Result Then Halt;
End;
End;
{!~ ExecuteExe
Executes an executable with no parameters}
//Unit Description UnitIndex Master Index
Function ExecuteExe(FileName : String): Boolean;
Begin
{ Result := False;}{zzz}
ShellExecute(
Application.Handle,
nil,
PChar(FileName),
nil,
nil,
SW_SHOWNORMAL);
Result := True;
End;
{!~ ExecuteExeParams
Executes an executable with parameters}
//Unit Description UnitIndex Master Index
Function ExecuteExeParams(
FileName : String;
ParamString : String;
DefaultDir : String): Boolean;
Begin
ShellExecute(
Application.Handle,
nil,
PChar(FileName),
PChar(ParamString),
PChar(DefaultDir),
SW_SHOWNORMAL);
Result := True;
End;
{!~ ExecuteKnownFileType
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;
{!~ ExtractFileExtNoPeriod
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;
LenExt: Integer;
Begin
FileWithExtString := ExtractFileName(FileString);
FileExtString := ExtractFileExt(FileString);
LenExt := Length(FileExtString);
If LenExt = 0 Then
Begin
Result := '';
End
Else
Begin
If Copy(FileExtString,1,1) = '.' Then
Begin
FileExtString := Copy(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;
{!~ ExtractFileNameNoExt
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;
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 := Copy(FileWithExtString,1,(LenNameWithExt-LenExt));
End;
End;
{!~ FileDate
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;
{!~ FileDatesSame
Returns True is the file 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.}
Try
If FileDate(FileString1)=FileDate(FileString2) Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
Except
Result := True;
End;
End;
{!~ FileExt
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;
{!~ FileFilterChar
This is a file handling routine. This function reads a file (FromFile) ...
searching for every occurrance of OldChar and replacing it with NewString. ...
The changed file is output to ToFile.}
{Copies A File}
//Unit Description UnitIndex Master Index
Function FileFilterChar(
FromFile : String;
ToFile : String;
OldChar : Char;
NewString : ShortString): Boolean;
Var
FromF, ToF: file;
{$IFDEF WIN32}
NumRead, NumWritten, i,j: Integer;
{$ELSE}
NumRead, NumWritten: Word;
{$ENDIF}
{Buf: array[1..2048] of Char;}
Buf: array[1..1] 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);
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);
For i := 1 to SizeOf(Buf) Do
Begin
If Buf[i] = OldChar Then
Begin
For j := 1 To Length(NewString) Do
Begin
BlockWrite(ToF, NewString[j], NumRead, NumWritten);
End;
End
Else
Begin
BlockWrite(ToF, Buf, NumRead, NumWritten);
End;
End;
until (NumRead = 0) {or (Not (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;
{!~ FileMove
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;
{!~ FileName
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;
{!~ FileNextNumberName
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(
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;
{!~ FileNotTextSize
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;
{!~ FilePath
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;
{!~ File_CopyDirectory
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;
{!~ File_DelTree
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;
{!~ File_DeleteDirectory
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;
{!~ 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;
{!~ File_GetCreationDate
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;
{!~ File_GetLastAccessDate
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;
{!~ File_GetLastModifiedDate
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;
{!~ File_GetLongFileName
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;
{!~ File_GetShortFileName
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;
{!~ File_KillDirectory
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;
{!~ File_MoveDirectory
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;
{!~ File_ReNameDirectory
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;
{!~ File_RemoveDirectory
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;
{!~ FilesInDirDetail
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 Not (MaskPtr = nil) do
begin
Ptr := StrScan (MaskPtr, ';');
If Not (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 (Not (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 Not (FindNext(FileInfo) = 0);
FindClose(FileInfo);
End;
If Not (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;
{!~ Internet_EmptyCacheDirectories
Empties the Temporary Internet Files directory.
Only validated with MS Internet Explorer 3.02
}
//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
ShowMessage('The Web Cache Directory needs to be provided!');
Exit;
End;
If Not DirectoryExists(TemporaryInternetDirectory) Then
Begin
ShowMessage('The Web Cache Directory is invalid!');
TemporaryInternetDirectory := '';
Exit;
End;
If Not (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
If FileExists(TemporaryInternetDirectory+D[j]+'\'+T[i]) Then
SysUtils.DeleteFile(TemporaryInternetDirectory+D[j]+'\'+T[i]);
End;
End;
Finally
T.Free;
D.Free;
End;
end;
{!~ IsDir
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;
{!~ IsDirEmpty
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;
{!~ IsFile
Returns True If The File Exists, False Otherwise}
//Unit Description UnitIndex Master Index
Function IsFile(DirName: String): Boolean;
Var
IsFileSearchRec: TSearchRec;
JustPath: String;
Counter: Integer;
NameHolder: String;
Begin
{$IFDEF WIN32}
Result := FileExists(DirName);
Exit;
{$ENDIF}
Counter := 1;
Try
JustPath := ExtractFilePath(DirName);
JustPath := Copy(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;
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;
{!~ KillDirectory
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;
{!~ MD
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 Not (IOResult = 0) Then
Begin
Result := False;
End
Else
Begin
Result := True;
End;
{$ENDIF}
End;
End;
End;
{!~ MoveDirectory
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;
{!~ RD
Removes A Directory}
//Unit Description UnitIndex Master Index
Function RD(DirName: String): Boolean;
Begin
Result := DelTree(DirName);
End;
{!~ ReNameDir
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;
{!~ ReNameDirectory
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;
{!~ SetFileDate
Sets a File Date.}
//Unit Description UnitIndex Master Index
Function SetFileDate(
Const FileName : String;
Const FileDate : TDateTime): Boolean;
Var
FileHandle : THandle;
FileSetDateResult : Integer;
Begin
FileHandle := 0;
Result := False;
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;
{!~ WinExecute
Executes An External Executable}
//Unit Description UnitIndex Master IndexFunction WinExecute(ApToExec: String): THandle; Begin Result := WinExec(ConvertStringToPChar(ApToExec),SW_SHOWNORMAL); 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;
{!~ CompressDups
This function replaces all duplicate character pairs with a new
single character value. Only duplicates with 3 or more occurances
are replaced.
The replacement values start at 267 and range up to 999.
This function returns True if more compression can be achieved
and false if there is no more opportunity for compression.
Maximum compression would be achieved by using this function
recursively until it returns False indicating that no further
compression can be achieved.
lstChr :
The lstChr argument is a TStringList variable that assumes special
formatting. It is assumed that this StringList contains each byte
from a file on individual lines in sequential order as their ascii
equilavent value with padded zeroes to the left for a width of 3.
An example would be:
lstChr[ 1] := '073';
lstChr[ 2] := '073';
lstChr[ 3] := '042';
lstChr[ 4] := '000';
lstChr[ 5] := '008';
lstChr[ 6] := '000';
lstChr[ 7] := '000';
lstChr[ 8] := '000';
lstChr[ 9] := '017';
lstChr[10] := '000';
lstChr[11] := '254';
lstChr[12] := '000';
lstChr[13] := '004';
lstChr[14] := '000';
lstChr[15] := '001';
lstChr[16] := '000';
lstChr[17] := '000';
This StringList is both an Input an Output variable. If compression
is achieved lstChr is replaced with the new values.
lstReplace :
The lstReplace argument is a TStringList variable that assumes special
formatting. It is assumed that this StringList contains each of the
replacement character definitions in sequential order. To restore the
original byte stream the replacements would need to be made in reverse
order.
An example would be:
lstReplace[ 1] := '0000257T000000';
lstReplace[ 2] := '0000258T065254';
lstReplace[ 3] := '0000259T137212';
lstReplace[ 4] := '0000260T178132';
lstReplace[ 5] := '0000261T151098';
The T in the lstReplace values indicates that boStartFirst was True. An
F would indicate that boStartFirst was False.
boStartFirst :
The boStartFirst argument is a boolean that determines where the Character
pairs start. If boStartFirst is True then the first character pair is made
up of the first and second characters. If boStartFirst is False then the
first character pair is only the first character and the second character
pair is made up of the second and third characters. Different matches occur
depending on where the pairing starts. For maximum compression first run
all the boStartFirst=True Then Run all the boStartFirst=False.
}
//Unit Description UnitIndex Master Index
Function CompressDups(
Var lstChr : TStringList;
Var lstReplace: TStringList;
boStartFirst : Boolean): Boolean;
Var
lstPairsOrig : TStringList;
lstPairsUniq : TStringList;
lstPairsCount : TStringList;
lstTemp : TStringList;
inCounter : Integer;
inCounter2 : Integer;
inSecond : Integer;
sgTemp : String;
inTemp : Integer;
inChrMax : Integer;
inMaxDups : Integer;
inMaxLen : Integer;
inReplaceNum : Integer;
sgReplaceNum : String;
sgReplaceNum3 : String;
sgStartFirst : String;
Begin
lstPairsOrig := TStringList.Create();
lstPairsUniq := TStringList.Create();
lstPairsCount:= TStringList.Create();
lstTemp := TStringList.Create();
inMaxLen := 7;
Try
Try
lstPairsOrig.Clear;
If boStartFirst Then
Begin
inSecond := 1;
End
Else
Begin
inSecond := 2;
End;
sgTemp := '';
inChrMax := lstChr.Count - 1;
For inCounter := 0 To inChrMax Do
Begin
If inSecond = 1 Then
Begin
sgTemp := lstChr[inCounter];
If inCounter = inChrMax Then lstPairsOrig.Add(sgTemp);
inSecond := 2;
End
Else
Begin
sgTemp := sgTemp + lstChr[inCounter];
lstPairsOrig.Add(sgTemp);
inSecond := 1;
End;
End;
lstPairsUniq.Clear;
lstPairsuniq.Sorted := True;
lstPairsUniq.Duplicates := dupIgnore;
For inCounter := 0 To lstPairsOrig.Count - 1 Do
Begin
lstPairsUniq.Add(lstPairsOrig[inCounter]);
End;
lstTemp.SetText(PChar(lstPairsOrig.Text));
lstPairsCount.Clear;
lstPairsCount.Sorted := True;
For inCounter := 0 To lstPairsUniq.Count - 1 Do
Begin
sgTemp := lstPairsUniq[inCounter];
inTemp := 0;
For inCounter2 := (lstTemp.Count - 1) DownTo 0 Do
Begin
If lstTemp[inCounter2] = sgTemp Then
Begin
inTemp := inTemp + 1;
lstTemp.Delete(inCounter2);
End;
End;
lstPairsCount.Add(StringPad(IntToStr(inTemp),'0',inMaxLen,False)+'_'+sgTemp);
sgTemp := '';
End;
inMaxDups := StrToInt(Copy(lstPairsCount[lstPairsCount.Count-1],1,inMaxLen));
If inMaxDups <= 2 Then
Begin
Result := False;
Exit;
End
Else
Begin
Result := True;
End;
If lstReplace.Count < 1 Then
Begin
inReplaceNum := 257;
End
Else
Begin
inReplaceNum := lstReplace.Count + 257;
End;
For inCounter := lstPairsCount.Count - 1 DownTo 0 Do
Begin
inMaxDups := StrToInt(Copy(lstPairsCount[inCounter],1,inMaxLen));
If inMaxDups <= 2 Then Break;
sgTemp := Copy(lstPairsCount[inCounter],inMaxLen+2,6);
sgReplaceNum := IntToStr(inReplaceNum);
sgReplaceNum3 := StringPad(sgReplaceNum,'0',3,False);
If boStartFirst Then
Begin
sgStartFirst := 'T';
End
Else
Begin
sgStartFirst := 'F';
End;
lstReplace.Add(StringPad(sgReplaceNum,'0',inMaxLen,False)+sgStartFirst+sgTemp);
For inCounter2 := 0 To lstPairsOrig.Count - 1 Do
Begin
If lstPairsOrig[inCounter2] = sgTemp Then
lstPairsOrig[inCounter2] := sgReplaceNum3;
End;
inReplaceNum := inReplaceNum + 1;
If inReplaceNum > 999 Then
Begin
Result := False;
Break;
End;
End;
lstTemp.Clear;
lstTemp.Sorted := False;
For inCounter := 0 To lstPairsOrig.Count - 1 Do
Begin
sgTemp := Copy(lstPairsOrig[inCounter],1,3);
If Not (sgTemp = '') Then lstTemp.Add(sgTemp);
sgTemp := Copy(lstPairsOrig[inCounter],4,3);
If Not (sgTemp = '') Then lstTemp.Add(sgTemp);
End;
lstChr.SetText(PChar(lstTemp.Text));
Result := True;
Except
Result := False;
End;
Finally
lstPairsOrig .Free;
lstPairsUniq .Free;
lstPairsCount.Free;
lstTemp .Free;
End;
End;
{!~ CompressMax
}
//Unit Description UnitIndex Master Index
Function CompressMax(Var lstChr : TStringList; Var lstReplace: TStringList): Integer;
Var
inCounter : Integer;
boCompressMore : Boolean;
lstTemp : TStringList;
inBefore : Integer;
inAfter : Integer;
Begin
lstTemp := TStringList.Create();
Try
inBefore := Length(lstChr.Text+lstReplace.Text);
inCounter := 257;
boCompressMore := True;
lstTemp.SetText(PChar(lstChr.Text+lstReplace.Text));
lstTemp.SaveToFile(IntToStr(inCounter-1)+'.txt');
While boCompressMore Do
Begin
boCompressMore :=
CompressDups(lstChr, lstReplace, True);
lstTemp.SetText(PChar(lstChr.Text+lstReplace.Text));
lstTemp.SaveToFile(StringPad(IntToStr(inCounter),'0',3,False)+'.txt');
Inc(inCounter);
ShowMessage('CompressMax1:'+IntToStr(inCounter));
If inCounter > 999 Then Break;
End;
boCompressMore := True;
While boCompressMore Do
Begin
boCompressMore :=
CompressDups(lstChr, lstReplace, False);
lstTemp.SetText(PChar(lstChr.Text+lstReplace.Text));
lstTemp.SaveToFile(StringPad(IntToStr(inCounter),'0',3,False)+'.txt');
Inc(inCounter);
ShowMessage('CompressMax2:'+IntToStr(inCounter));
If inCounter > 999 Then Break;
End;
While boCompressMore Do
Begin
boCompressMore :=
CompressDups(lstChr, lstReplace, True);
lstTemp.SetText(PChar(lstChr.Text+lstReplace.Text));
lstTemp.SaveToFile(StringPad(IntToStr(inCounter),'0',3,False)+'.txt');
Inc(inCounter);
ShowMessage('CompressMax3:'+IntToStr(inCounter));
If inCounter > 999 Then Break;
End;
boCompressMore := True;
While boCompressMore Do
Begin
boCompressMore :=
CompressDups(lstChr, lstReplace, False);
lstTemp.SetText(PChar(lstChr.Text+lstReplace.Text));
lstTemp.SaveToFile(StringPad(IntToStr(inCounter),'0',3,False)+'.txt');
Inc(inCounter);
ShowMessage('CompressMax4:'+IntToStr(inCounter));
If inCounter > 999 Then Break;
End;
inAfter := Length(lstChr.Text+lstReplace.Text);
Result := StrToInt(FormatFloat('##',(((inBefore-inAfter)/inBefore)*100)));
Finally
lstTemp.Free;
End;
End;
{!~ DeCompressMax
}
//Unit Description UnitIndex Master Index
Function DeCompressMax(Var lstChr : TStringList; Var lstReplace: TStringList): Boolean;
Var
inCounter : Integer;
inReplace : Integer;
sgReplace : String;
sgReplaceAll : String;
sgReplaceCur : String;
sgReplaceNew : String;
sgReplaceNew1 : String;
sgReplaceNew2 : String;
Begin
Try
For inReplace := lstReplace.Count - 1 DownTo 0 Do
Begin
sgReplaceall := lstReplace[inReplace];
sgReplaceCur := Copy(lstReplace[inReplace],5,3);
sgReplaceNew := Copy(lstReplace[inReplace],9,6);
sgReplaceNew1 := Copy(sgReplaceNew,1,3);
sgReplaceNew2 := Copy(sgReplaceNew,4,3);
If sgReplaceNew1 = '' Then
Begin
sgReplace := sgReplaceNew2;
End
Else
Begin
If sgReplaceNew2 = '' Then
Begin
sgReplace := sgReplaceNew1;
End
Else
Begin
sgReplace := sgReplaceNew1+#13+sgReplaceNew2;
End;
End;
For inCounter := lstChr.Count - 1 DownTo 0 Do
Begin
If lstChr[inCounter] = sgReplaceCur Then lstChr[inCounter] := sgReplace;
End;
lstChr.SetText(PChar(lstChr.Text));
End;
Result := True;
Except
Result := False;
End;
End;
{!~ FileToProcInUnit
Converts a File to a Procedure in a Delphi Unit
Arguments
FromFile : The full name and path of the file to be converted to a procedure.
NewUnitPath : The path to the new Delphi Unit that will be created.
NewUnitNoExt : The name of the new Delphi Unit without any file extension.
ResourceName : The variable name that will be associated with this file.
Example
//The following procedure creates a Delphi Unit called oasis_resstr01.pas.
//The path to this unit is contained in the variable GlobalExecutablePath.
//The file being converted to a procedure is GlobalCacheDir+'blank.tif'.
//The variable name assocated with this file is BlankPage.
//Unit Description UnitIndex Master Index
procedure TDoc_MainForm.Button2Click(Sender: TObject);
begin
FileToProcInUnit(
GlobalCacheDir+'blank.tif',//FromFile,
GlobalExecutablePath,//ResFilePath,
'oasis_resstr01',//ResFileNoExt,
'BlankPage');//ResourceName:String): Boolean;
end;
//The following procedure uses the generated procedure to create a file
//called TestTif.
//Unit Description UnitIndex Master Index
procedure TDoc_MainForm.Button3Click(Sender: TObject);
begin
WriteFileBlankPage(
GlobalExecutablePath,//ToFilePath : String;
'TestTif' //ToFileNameNoExt : String
); //);
end;
}
//Unit Description UnitIndex Master Index
Function FileToProcInUnit(
FromFile,
NewUnitPath,
NewUnitNoExt,
ResourceName:String): Boolean;
Var
{$IFDEF WIN32}
NumRead : Integer;
{$ELSE}
NumRead : Word;
{$ENDIF}
sgChar : Char;
FromF : file;
inCounter : Integer;
//inPad : Integer;
inPos : Integer;
lst : TStringList;
sg : String;
sgFileExt : String;
sgIndent : String;
CharTotal : Integer;
sgPlus : String;
sgRes : String;
sgTemp : String;
lstChr : TStringList;
lstReplace: TStringList;
Begin
lst := TStringList.Create();
lstChr := TStringList.Create();
lstReplace := TStringList.Create();
Try
lstChr .Clear;
lstReplace.Clear;
CharTotal := 0;
sgIndent := ' ';
sgRes := '';
sgFileExt := ExtractFileExt(FromFile);
inPos := Pos('.',sgFileExt);
If inPos > 0 Then sgFileExt := Copy(sgFileExt,inPos+1,Length(sgFileExt)-inPos);
sg := '';
If IsDir(FromFile) Then
Begin
Result := False;
End
Else
Begin
AssignFile(FromF, FromFile);
Try
FileMode := 0; {Sets Reset To ReadOnly}
Reset(FromF, 1);{ Record size = 1 }
FileMode := 2; {Sets Reset To ReadWrite}
While True Do
Begin
If CharTotal = 0 Then
Begin
sgPlus := '';
End
Else
Begin
sgPlus := '+';
End;
BlockRead(FromF, sgChar, 1, NumRead);
If NumRead = 0 Then Break;
sgRes := sgRes + StringPad(IntToStr(Ord(sgChar)),'0',3,False);
lstChr.Add(StringPad(IntToStr(Ord(sgChar)),'0',3,False));
CharTotal := CharTotal + 1;
End;
CompressMax(lstChr,lstReplace);
CharTotal := lstChr.Count;
lst.Clear;
lst.Add('unit '+NewUnitNoExt+';');
lst.Add('{Copyright(c)'+FormatDateTime('yyyy',Now())+' Advanced Delphi Systems');
lst.Add('');
lst.Add(' Richard Maley');
lst.Add(' Advanced Delphi Systems');
lst.Add(' 12613 Maidens Bower Drive');
lst.Add(' Potomac, MD 20854 USA');
lst.Add(' phone 301-840-1554');
lst.Add(' http://www.advdelphisys.com');
lst.Add(' maley@advdelphisys.com');
lst.Add(' maley@compuserve.com');
lst.Add(' maley@cpcug.org}');
lst.Add('');
lst.Add('interface');
lst.Add('');
lst.Add('Procedure WriteFile'+ResourceName+'(');
lst.Add(' ToFilePath : String;');
lst.Add(' ToFileNameNoExt : String');
lst.Add(' );');
lst.Add('');
lst.Add('implementation');
lst.Add('');
lst.Add('Procedure WriteFile'+ResourceName+'(');
lst.Add(' ToFilePath : String;');
lst.Add(' ToFileNameNoExt : String');
lst.Add(' );');
lst.Add('const');
lst.Add(sgIndent+'sg_FileExt = '''+sgFileExt+''';');
lst.Add(sgIndent+'inBytesTotal = '+IntToStr(CharTotal)+';');
lst.Add(sgIndent+'arRp1 '+' : Array[1..'+IntToStr(lstReplace.Count)+'] of Integer =');
lst.Add(sgIndent+sgIndent+'(');
sgTemp := '';
For inCounter := 0 To lstReplace.Count-1 Do
Begin
sgTemp := sgTemp+StringPad(IntToStr(StrToInt(Copy(lstReplace[inCounter],5,3))),' ',3,False);
If Not (inCounter = lstReplace.Count-1) Then sgTemp := sgTemp + ',';
If (Length(sgTemp) > 72) Or (inCounter = (lstReplace.Count-1)) Then
Begin
lst.Add(sgIndent+sgIndent+sgTemp);
sgTemp := '';
End;
End;
lst.Add(sgIndent+sgIndent+');');
lst.Add('');
lst.Add(sgIndent+'arRp2 '+' : Array[1..'+IntToStr(lstReplace.Count)+'] of Integer =');
lst.Add(sgIndent+sgIndent+'(');
sgTemp := '';
For inCounter := 0 To lstReplace.Count-1 Do
Begin
sgTemp := sgTemp+StringPad(IntToStr(StrToInt(Copy(lstReplace[inCounter],9,3))),' ',3,False);
If Not (inCounter = lstReplace.Count-1) Then sgTemp := sgTemp + ',';
If (Length(sgTemp) > 72) Or (inCounter = (lstReplace.Count-1)) Then
Begin
lst.Add(sgIndent+sgIndent+sgTemp);
sgTemp := '';
End;
End;
lst.Add(sgIndent+sgIndent+');');
lst.Add('');
lst.Add(sgIndent+'arRp3 '+' : Array[1..'+IntToStr(lstReplace.Count)+'] of Integer =');
lst.Add(sgIndent+sgIndent+'(');
sgTemp := '';
For inCounter := 0 To lstReplace.Count-1 Do
Begin
sgTemp := sgTemp+StringPad(IntToStr(StrToInt(Copy(lstReplace[inCounter],12,3))),' ',3,False);
If Not (inCounter = lstReplace.Count-1) Then sgTemp := sgTemp + ',';
If (Length(sgTemp) > 72) Or (inCounter = (lstReplace.Count-1)) Then
Begin
lst.Add(sgIndent+sgIndent+sgTemp);
sgTemp := '';
End;
End;
lst.Add(sgIndent+sgIndent+');');
lst.Add('');
lst.Add(sgIndent+'ar '+' : Array[1..'+IntToStr(CharTotal)+'] of Integer =');
lst.Add(sgIndent+sgIndent+'(');
sgTemp := '';
For inCounter := 1 To CharTotal Do
Begin
sgTemp := sgTemp+StringPad(IntToStr(StrToInt(lstChr[inCounter-1])),' ',3,False);
If Not (inCounter = CharTotal) Then sgTemp := sgTemp + ',';
If (Length(sgTemp) > 72) Or (inCounter = (CharTotal)) Then
Begin
lst.Add(sgIndent+sgIndent+sgTemp);
sgTemp := '';
End;
End;
lst.Add(sgIndent+sgIndent+');');
lst.Add('');
lst.Add('Var');
lst.Add(' inNumRead : Integer;');
lst.Add(' inNumWritten : Integer;');
lst.Add(' sgChar : Char;');
lst.Add(' sgToFile : String;');
lst.Add(' ToF : File;');
lst.Add('');
lst.Add(' Procedure WriteToFile(inChr : Integer);');
lst.Add(' Begin');
lst.Add(' sgChar := Chr(inChr);');
lst.Add(' BlockWrite(ToF, sgChar, inNumRead, inNumWritten);');
lst.Add(' End;');
lst.Add('');
lst.Add(' Procedure ReplaceValue(inSg : Integer);');
lst.Add(' Var');
lst.Add(' inCur : Integer;');
lst.Add(' inDex : Integer;');
lst.Add(' inCounter : Integer;');
lst.Add(' Begin');
lst.Add(' If inSg < 257 Then');
lst.Add(' Begin');
lst.Add(' WriteToFile(inSg);');
lst.Add(' Exit;');
lst.Add(' End;');
lst.Add(' inDex := -1;');
lst.Add(' For inCounter := 1 To SizeOf(arRp1) Do');
lst.Add(' Begin');
lst.Add(' If arRp1[inCounter] = inSg Then');
lst.Add(' Begin');
lst.Add(' inDex := inCounter;');
lst.Add(' Break;');
lst.Add(' End;');
lst.Add(' End;');
lst.Add(' If inDex = -1 Then');
lst.Add(' Begin');
lst.Add(' Exit;');
lst.Add(' End;');
lst.Add(' inCur := arRp2[inDex];');
lst.Add(' If inCur < 257 Then');
lst.Add(' Begin');
lst.Add(' WriteToFile(inCur);');
lst.Add(' End');
lst.Add(' Else');
lst.Add(' Begin');
lst.Add(' ReplaceValue(inCur);');
lst.Add(' End;');
lst.Add(' inCur := arRp3[inDex];');
lst.Add(' If inCur < 257 Then');
lst.Add(' Begin');
lst.Add(' WriteToFile(inCur);');
lst.Add(' End');
lst.Add(' Else');
lst.Add(' Begin');
lst.Add(' ReplaceValue(inCur);');
lst.Add(' End;');
lst.Add(' End;');
lst.Add('');
lst.Add(' Function DeCompressMax: Boolean;');
lst.Add(' Var');
lst.Add(' inCounter : Integer;');
lst.Add(' Begin');
lst.Add(' Try');
lst.Add(' For inCounter := 1 To inBytesTotal Do');
lst.Add(' Begin');
lst.Add(' ReplaceValue(ar[inCounter]);');
lst.Add(' End;');
lst.Add(' Result := True;');
lst.Add(' Except');
lst.Add(' Result := False;');
lst.Add(' End;');
lst.Add(' End;');
lst.Add('Begin');
lst.Add(' If Not (Copy(ToFilePath,Length(ToFilePath),1) = ''\'') Then');
lst.Add(' ToFilePath := ToFilePath + ''\'';');
lst.Add(' sgToFile := ToFilePath + ToFileNameNoExt+''.''+sg_FileExt;');
lst.Add(' AssignFile(ToF, sgToFile);');
lst.Add(' inNumRead := 1;');
lst.Add(' Rewrite(ToF, 1);');
lst.Add(' DeCompressMax;');
lst.Add(' System.CloseFile(ToF);');
lst.Add('end;');
lst.Add('');
lst.Add('end.');
lst.SaveToFile(NewUnitPath +NewUnitNoExt+'.pas');
System.CloseFile(FromF);
Result := True;
Except
On EInOutError Do
Begin
Result := False;
End;
Else Result := False;
End;
End;
Finally
lst .Free;
lstChr .Free;
lstReplace .Free;
End;
End;
{!~ ExecuteNewProcess
Executes an executable in a completely new process}
//Unit Description UnitIndex Master Index
Function ExecuteNewProcess(
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_PROCESS_GROUP,
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo)
Then
Begin
Result := -1 { pointer to PROCESS_INF }
End
Else
Begin
WaitforSingleObject(ProcessInfo.hProcess,300);
GetExitCodeProcess(ProcessInfo.hProcess,Cardinal(Result));
End;
End;
{!~ GetFileSize
}
//Unit Description UnitIndex Master Index
function GetFileSize(const FileName: string): LongInt;
Var
SearchRec: TSearchRec;
sgPath : String;
inRetval : Integer;
begin
sgPath := ExpandFileName(FileName);
Try
inRetval := FindFirst(ExpandFileName(FileName), faAnyFile, SearchRec);
If inRetval = 0 Then
Result := SearchRec.Size
Else Result := -1;
Finally
SysUtils.FindClose(SearchRec);
End;
end;
{!~ GetFileSize_ads
}
//Unit Description UnitIndex Master Index
function GetFileSize_ads(const FileName: string): DWord;
Var
Handle : Integer;
begin
Result := 0;
Try
Handle := CreateFile(PChar(FileName), GENERIC_READ, 0, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
Try
Result := Windows.GetFileSize(Handle, nil);
Finally
CloseHandle(Handle);
End;
Except
End;
end;
{!~ GetDiskFreeSpace
}
//Unit Description UnitIndex Master IndexFunction GetDiskFreeSpace(DriveLetter : String): Int64; Var sgDrive : String; pcDrive : PChar; chDrive : Char; inDrive : Int64; Begin sgDrive := Trim(DriveLetter); sgDrive := Copy(sgDrive,1,1); sgDrive := UpperCase(sgDrive); pcDrive := PChar(sgDrive); chDrive := pcDrive[0]; inDrive := Ord(chDrive)-64; If inDrive < 0 Then inDrive := 0; //ShowMessage(sgDrive+'='+IntToStr(inDrive)); Result := DiskFree(inDrive); End; //Unit Description UnitIndex Master Index
procedure NumberDirFiles(
Directory : String;
StartNumber : Integer);
Var
lstOriginal : TStringList;
lstNewNames : TStringList;
sgExt : String;
sgZeros : String;
inLen : Integer;
sgFile : String;
inCounter : Integer;
inNum : Integer;
destFile : String;
TempFile : String;
SrcFile : String;
inCount : Integer;
inMax : Integer;
inIndex : Integer;
Begin
lstOriginal := TStringList.Create();
lstNewNames := TStringList.Create();
Try
If Copy(Directory,Length(Directory),1) <> '\' Then
Directory := Directory + '\';
sgZeros := '00000000';
FilesInDirDetail(
lstOriginal, //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;
lstNewNames.Clear;
inNum := StartNumber;
For inCounter := 0 To lstOriginal.Count - 1 Do
Begin
lstNewNames.Add('');
sgFile := IntToStr(inNum);
inLen := Length(sgFile);
sgFile := Copy(sgZeros,1,8-inLen)+sgFile;
sgExt := ExtractFileExt(lstOriginal[inCounter]);
sgFile := sgFile+sgExt;
lstNewNames[inCounter] := sgFile;
inc(inNum);
End;
inMax := lstOriginal.Count-1;
For inCount := 0 To inMax Do
Begin
For inCounter := (lstOriginal.Count - 1) DownTo 0 Do
Begin
destFile := Directory+lstNewNames[inCounter];
SrcFile := Directory+lstOriginal[inCounter];
If Not FileExists(DestFile) Then
Begin
ReNameFile(SrcFile,destFile);
lstNewNames.Delete(inCounter);
lstOriginal.Delete(inCounter);
Continue;
End;
End;
If lstOriginal.Count = 0 Then Break;
End;
For inCounter := (lstOriginal.Count - 1) DownTo 0 Do
Begin
destFile := Directory+lstNewNames[inCounter];
SrcFile := Directory+lstOriginal[inCounter];
If UpperCase(DestFile) = UpperCase(SrcFile) Then
Begin
lstNewNames.Delete(inCounter);
lstOriginal.Delete(inCounter);
Continue;
End;
If Not FileExists(DestFile) Then
Begin
ReNameFile(SrcFile,destFile);
lstNewNames.Delete(inCounter);
lstOriginal.Delete(inCounter);
Continue;
End
Else
Begin
TempFile := FormatDateTime('yyyymmddhhnnss',now());
inIndex := lstOriginal.IndexOf(lstNewNames[inCounter]);
If inIndex <> -1 Then
Begin
ReNameFile(
Directory+lstOriginal[inIndex],
Directory+TempFile);
lstOriginal[inIndex] := TempFile;
If Not FileExists(DestFile) Then
Begin
ReNameFile(SrcFile,destFile);
lstNewNames.Delete(inCounter);
lstOriginal.Delete(inCounter);
Continue;
End
End;
End;
End;
If lstOriginal.Count <> 0 Then
Begin
ShowMessage('Not all files were renumbered');
End;
Finally
lstOriginal.Free;
lstNewNames.Free;
End;
End;
End.
//