Unit ads_File;
{Copyright(c)2016 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
dickmaley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to dickmaley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
(*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 CDDriveDetail CDDriveGetAll CDDriveGetFirst CDDriveGetLast CDDriveGetNext CDDriveGetPrior CompressDups CompressMax CopyDirectory CopyFile CopyFiles CreateShortCutFile_1 CreateShortCutFile_2 DeCompressMax DeleteFiles DeleteFilesInDirectories DelTree Directory DirectoryCopy DirectoryHide DirectoryMove DirectoryNextNumberName DirectoryUnHide EmptyDirectory ExecutableUpdate ExecuteExe ExecuteExeParams ExecuteKnownFileType ExecuteNewProcess ExecuteProcessAndWait 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 FileReNameNDate FileReNameToDate FilesInDirDetail FileToProcInUnit FileToStr FindFilesInDirectories FirstFileInDir GetDiskFreeSpace GetFileSize GetFileSize_ads Internet_EmptyCacheDirectories IsDir IsDirEmpty IsFile KillDirectory ListOfSpecFoldersToFile LongFileName MD MoveDirectory NumberDirFiles PAnsiChr PathOfAppDataCommon PathOfAppDataLocal PathOfHistory PathOfInternetCache PathOfInternetCookies PathOfMyDocuments PathOfMyPictures PathOfProgramFiles PathOfProgramFilesCommon PathOfSpecialFolder PathOfSpecialFolders PathOfSystem32 PathOfWindows RD ReNameDir ReNameDirectory SetFileDate SetFileDates ShortFileName StrToFile TDoc_MainForm.Button2Click TDoc_MainForm.Button3Click TForm1.Button1Click TForm1.Button2Click TForm1.Button3Click WinExecute WinExecute32
*)
Interface
Uses Windows, Classes, Forms, Dialogs,SysUtils,
{$WARNINGS OFF}
FileCtrl,
{$WARNINGS ON}
ShellAPI;
Function CDDriveDetail(StartAtEnd,GoTowardLast,GetAll: Boolean;Start: String): String;
Function CDDriveGetAll: String;
Function CDDriveGetFirst: String;
Function CDDriveGetLast: String;
Function CDDriveGetNext(CurDrive: String): String;
Function CDDriveGetPrior(CurDrive: String): String;
Function CompressMax(Var lstChr : TStringList; Var lstReplace: TStringList): Integer;
Function DeCompressMax(Var lstChr : TStringList; Var lstReplace: TStringList): Boolean;
Function DeleteFilesInDirectories(mask,Path: String): Boolean;
Function ExecuteProcessAndWait(FileName: String;Visibility: integer):integer;
Function FileToStr(FileName: String): String;
Function FindFilesInDirectories(mask,Path: String): String;
Function FirstFileInDir(mask,Path: String): String;
Function GetDiskFreeSpace(DriveLetter : String): Int64;
function GetFileSize(const FileName: string): LongInt;
function GetFileSize_ads(const FileName: string): DWord;
Function ListOfSpecFoldersToFile(FileName: String) :Boolean;
{$WARNINGS OFF}Function PAnsiChr(s: String): PAnsiChar;{$WARNINGS ON}
Function PathOfAppDataCommon() :String;
Function PathOfAppDataLocal() :String;
Function PathOfHistory() :String;
Function PathOfInternetCache() :String;
Function PathOfInternetCookies() :String;
Function PathOfMyDocuments() :String;
Function PathOfMyPictures() :String;
Function PathOfProgramFiles() :String;
Function PathOfProgramFilesCommon():String;
Function PathOfSpecialFolder(Folder: Integer): String;
Function PathOfSpecialFolders() :String;
Function PathOfSystem32() :String;
Function PathOfWindows() :String;
Function StrToFile(FileData,FileName: String): Boolean;
Procedure ApOnlyOneInstance;
procedure NumberDirFiles(Directory : String;StartNumber : 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 next available directory name number as a string
in the format 00000001}
Function DirectoryNextNumberName(
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;
Function FileReNameToDate(FileName: String): Boolean;
Function FileReNameNDate(FileName: String;FileDateNew: TDateTime;ChangeDate,ChangeName: Boolean): 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;
Function SetFileDates(
Const FileName : String;
Const CreationDate : TDateTime;
Const AccessedDate : TDateTime;
Const ModifiedDate : TDateTime): Boolean;
{!~ Executes An External Executable}
Function WinExecute(ApToExec: String): THandle;
{!~ Executes An External Executable}
Function WinExecute32(
FileName : String;
Visibility : integer):integer;
procedure CreateShortCutFile(Target, Args, WorkDir, ShortCutName: String);OverLoad;
procedure CreateShortCutFile(Target, Args, WorkDir, SaveDir, ShortCutName: String);OverLoad;
Function LongFileName(ShortName: String): String;
Function ShortFileName(Const FileName: String): String;
implementation
Uses
{$WARNINGS OFF}ads_Conv,{$WARNINGS ON}
Ads_Strg,
ShlObj,
ActiveX,
ComObj;
{$WARNINGS OFF}
//Unit Description UnitIndex Master Index
Function PAnsiChr(s: String): PAnsiChar;
Begin
Result:=PAnsiChar(s);
End;
{$WARNINGS ON}
{!~ 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, PAnsiChr(ParamStr(0)));
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;
{$WARNINGS OFF}
{!~ 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 : PAnsiChar;
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 := PAnsiChar(StrPLCopy(cmdLinePChar,'',1));
show := @showCmd;
reserved1 := 0;
reserved2 := 0;
End;
Result := LoadModule(
PAnsiChar(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;
{$WARNINGS OFF}
Attributes := faDirectory + faHidden + faSysFile;
FileSetAttr(FileString,Attributes);
{$WARNINGS ON}
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;
{$WARNINGS OFF}
FileSetAttr(FileString,Attributes);
{$WARNINGS ON}
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(PAnsiChr(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(PAnsiChr(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(PAnsiChr(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,
PWideChar(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,
PWideChar(FileName),
PWideChar(ParamString),
PWideChar(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;
Try
If Not FileExists(FileName) Then Exit;
FilePath := ExtractFilePath(FileName);
StrPCopy(PFileName,FileName);
StrPCopy(PFilePath,FilePath);
ShellExecute(
Handle,
nil,
PFileName,
nil,
PFilePath,
SW_SHOWNORMAL);
Result := True;
Except
End;
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;
{$WARNINGS OFF}
Result := FileDateToDateTime(FileAge(FileString));
{$WARNINGS ON}
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 }
{$WARNINGS OFF}
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))};
{$WARNINGS ON}
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;
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;}
For i:=(StringList.Count-1) DownTo 0 Do
Begin
StringList[i]:=NumbersOnlyAbsolute(StringList[i]);
If StringList[i]='' Then Begin StringList.Delete(i);Continue;End;
StringList[i]:=IntToStr(StrToInt(StringList[i]));
StringList[i]:=StringPad(StringList[i],'0',8,False);
End;
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;
{!~ Returns the next available directory name number as a string
in the format 00000001}
//Unit Description UnitIndex Master Index
Function DirectoryNextNumberName(
Directory : String;
Mask : String
): String;
Begin
Result := FileNextNumberName(Directory,Mask);
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
{$WARNINGS OFF}
AssignFile(f, FileString);
Reset(f);
size := FileSize(f);
CloseFile(f);
Result := Size;
{$WARNINGS ON}
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;
{$WARNINGS OFF}
pFrom := @FromBuf;
pTo := @ToBuf;
{$WARNINGS ON}
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
{$WARNINGS OFF}
FileTimeToLocalFileTime(SearchRec.FindData.ftCreationTime,DT);
{$WARNINGS ON}
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
{$WARNINGS OFF}
FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT);
{$WARNINGS ON}
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
{$WARNINGS OFF}
FileTimeToLocalFileTime(SearchRec.FindData.ftLastWriteTime,DT);
{$WARNINGS ON}
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
{$WARNINGS OFF}
Result := String(SearchRec.FindData.cFileName);
{$WARNINGS ON}
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
{$WARNINGS OFF}
Result := String(SearchRec.FindData.cAlternateFileName);
{$WARNINGS ON}
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;
{$WARNINGS OFF}
{!~ 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 : PAnsiChar;
Ptr : PAnsiChar;
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;
Try GetDir(0,CurDir); Except End;
Try ChDir(Directory); Except End; { go to the directory we want }
FileList.Clear; { clear the list }
MaskPtr := PAnsiChr(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;
{$WARNINGS ON}
{!~ 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}
{$WARNINGS OFF}
FileGetAttrValue := FileGetAttr(IsDirPath);
{$WARNINGS ON}
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. All values are changed: Creation, Access, Modified}
//Unit Description UnitIndex Master Index
Function SetFileDate(
Const FileName : String;
Const FileDate : TDateTime): Boolean;
Begin
Result :=
SetFileDates(
FileName, //Const FileName : String;
FileDate, //Const CreationDate : TDateTime;
FileDate, //Const AccessedDate : TDateTime;
FileDate //Const ModifiedDate : TDateTime
);//): Boolean;
End;
{$WARNINGS OFF}
//Unit Description UnitIndex Master Index
Function SetFileDates(
Const FileName : String;
Const CreationDate : TDateTime;
Const AccessedDate : TDateTime;
Const ModifiedDate : TDateTime): Boolean;
Var
FileHandle : THandle;
FileDateTime : TFileTime;
TimeInt : Integer;
TimeLocal : TFileTime;
Begin
FileHandle := 0;
Result := False;
Try
Try
FileHandle := FileOpen(FileName, fmOpenWrite OR fmShareDenyNone);
If FileHandle > 0 Then
Begin
TimeInt:=DateTimeToFileDate(CreationDate);
If DosDateTimeToFileTime(LongRec(TimeInt).Hi,LongRec(TimeInt).Lo,TimeLocal) Then
Begin
If Windows.LocalFileTimeToFileTime(TimeLocal,FileDateTime) Then
Begin
SetFileTime(FileHandle,@FileDateTime,nil,nil);
Result:=True;
End;
End;
TimeInt:=DateTimeToFileDate(AccessedDate);
If DosDateTimeToFileTime(LongRec(TimeInt).Hi,LongRec(TimeInt).Lo,TimeLocal) Then
Begin
If Windows.LocalFileTimeToFileTime(TimeLocal,FileDateTime) Then
Begin
SetFileTime(FileHandle,nil,@FileDateTime,nil);
Result:=True;
End;
End;
TimeInt:=DateTimeToFileDate(ModifiedDate);
If DosDateTimeToFileTime(LongRec(TimeInt).Hi,LongRec(TimeInt).Lo,TimeLocal) Then
Begin
If Windows.LocalFileTimeToFileTime(TimeLocal,FileDateTime) Then
Begin
SetFileTime(FileHandle,nil,nil,@FileDateTime);
Result:=True;
End;
End;
End;
Except
Result := False;
End;
Finally
FileClose (FileHandle);
End;
End;
{$WARNINGS ON}
{!~ WinExecute
Executes An External Executable}
//Unit Description UnitIndex Master IndexFunction WinExecute(ApToExec: String): THandle; Begin //Result := WinExec(ConvertStringToPChar(ApToExec),SW_SHOWNORMAL); Result := WinExec(PAnsiChar(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(PWideChar(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(PWideChar(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(PWideChar(lstChr.Text+lstReplace.Text));
lstTemp.SaveToFile(IntToStr(inCounter-1)+'.txt');
While boCompressMore Do
Begin
boCompressMore :=
CompressDups(lstChr, lstReplace, True);
lstTemp.SetText(PWideChar(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(PWideChar(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(PWideChar(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(PWideChar(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(PWideChar(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;
{$WARNINGS OFF}
BlockRead(FromF, sgChar, 1, NumRead);
{$WARNINGS ON}
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(PWideChar(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
}
{$WARNINGS OFF}
//Unit Description UnitIndex Master Index
Function GetDiskFreeSpace(DriveLetter : String): Int64;
Var
sgDrive : String;
pcDrive : PAnsiChar;
chDrive : Char;
inDrive : Int64;
Begin
sgDrive := Trim(DriveLetter);
sgDrive := Copy(sgDrive,1,1);
sgDrive := UpperCase(sgDrive);
pcDrive := PAnsiChr(sgDrive);
chDrive := Char(pcDrive[0]);
inDrive := Ord(chDrive)-64;
If inDrive < 0 Then inDrive := 0;
//ShowMessage(sgDrive+'='+IntToStr(inDrive));
Result := DiskFree(inDrive);
End;
{$WARNINGS ON}
//Unit Description UnitIndex Master Index
procedure NumberDirFiles(
Directory : String;
StartNumber : Integer);
Var
i : Integer;
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;
inSigFigs : 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;
inSigFigs := Length(IntToStr(lstOriginal.Count+StartNumber-1));
sgZeros := '';
For i:=1 To inSigFigs Do sgZeros:=sgZeros+'0';
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,inSigFigs-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;
//Unit Description UnitIndex Master Indexprocedure CreateShortCutFile(Target, Args, WorkDir, ShortCutName: String); begin CreateShortCutFile(Target, Args, WorkDir, WorkDir, ShortCutName); end; //Unit Description UnitIndex Master Index
procedure CreateShortCutFile(Target, Args, WorkDir, SaveDir, ShortCutName: String);
var
IObj : IUnknown;
Link : IShellLink;
IPFile : IPersistFile;
TargetW: WideString;
begin
IObj := CreateComObject(CLSID_ShellLink);
Link := IObj as IShellLink;
IPFile := IObj as IPersistFile;
with Link do
begin
SetPath(PWideChar(Target));
SetArguments(PWideChar(Args));
SetShowCmd(SW_SHOWNORMAL);
SetWorkingDirectory(PWideChar(WorkDir));
end;
If WorkDir <> '' Then
Begin
If Copy(WorkDir,Length(WorkDir),1) <> '\' Then WorkDir := WorkDir + '\';
End;
TargetW := ShortCutName;
{$WARNINGS OFF}
IPFile.Save(PWChar(SaveDir+TargetW+'.lnk'), False);
{$WARNINGS ON}
end;
{$WARNINGS ON}
//Unit Description UnitIndex Master Index
Function FindFilesInDirectories(mask,Path: String): String;
procedure FindFilesSubDirs(var lst:TStringList;mask,Path: String);
Var
Files : TStringList;
inCounter : Integer;
sgPath : String;
Begin
If Copy(Path,Length(Path),1) <> '\' Then Path := Path + '\';
If Not DirectoryExists(Path) Then Exit;
Files := TStringList.Create();
Try
Files.Clear;
FilesInDirDetail(
Files, //FileList : TStrings;
Path, //Directory : String;
mask, //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;
If Files.Count <> 0 Then
Begin
lst.Sorted := False;
For inCounter := 0 To Files.Count - 1 Do
Begin
Files[inCounter] := Path + Files[inCounter];
End;
lst.Duplicates := dupIgnore;
lst.Sorted := True;
lst.SetText(PWideChar(lst.Text+Files.Text));
lst.Sorted := False;
End;
Files.Clear;
FilesInDirDetail(
Files, //FileList : TStrings;
Path, //Directory : String;
'*', //Mask : String;
False, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
False, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
True, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
False, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
If Files.Count = 0 Then Exit;
For inCounter := 0 To Files.Count - 1 Do
Begin
sgPath := Path + Files[inCounter] + '\';
FindFilesSubDirs(lst,mask,sgPath);
End;
Finally
Files.Free;
End;
End;
Var
lst : TStringList;
Begin
Result := '';
If Copy(Path,Length(Path),1) <> '\' Then Path := Path + '\';
If Not DirectoryExists(Path) Then Exit;
lst := TStringList.Create();
Try
FindFilesSubDirs(lst,mask,Path);
Result := lst.Text;
Finally
lst.Free;
End;
End;
//Unit Description UnitIndex Master Index
Function DeleteFilesInDirectories(mask,Path: String): Boolean;
Var
lst : TStringList;
Files : String;
inCounter : Integer;
boRetVal : Boolean;
Begin
Result := True;
lst := TStringList.Create();
Try
lst.Clear;
Files := FindFilesInDirectories(mask,Path);
If Files = '' Then Exit;
lst.SetText(PWideChar(Files));
For inCounter := 0 To lst.Count - 1 Do
Begin
If FileExists(lst[inCounter]) Then
Begin
boRetVal := DeleteFile(lst[inCounter]);
If Not boRetVal Then Result := False;
End;
End;
Finally
lst.Free;
End;
End;
//Unit Description UnitIndex Master Index
Function FileToStr(FileName: String): String;
Var
StrStream : TStringStream;
FileStream : TFileStream;
Begin
Result := '';
If Not FileExists(FileName) Then Exit;
FileStream := TFileStream.Create(FileName,fmOpenRead);
Try
StrStream:= TStringStream.Create('');
Try
StrStream.CopyFrom(FileStream,0);
Result := StrStream.DataString;
Finally
StrStream.Free;
End;
Finally
FileStream.Free;
End;
End;
//Unit Description UnitIndex Master Index
Function ShortFileName(Const FileName: String): String;
Var
aTmp: Array[0..255] Of Char;
Begin
If Not FileExists(FileName) Then
Begin
Result := '';
End
Else
Begin
If GetShortPathName(PWideChar (FileName), aTmp, Sizeof (aTmp) - 1) = 0 Then
Begin
Result:= FileName;
End
Else
Begin
Result:= StrPas (aTmp);
End;
End;
End;
//Unit Description UnitIndex Master Index
Function LongFileName(ShortName: String): String;
Var
SR: TSearchRec;
Begin
Result := '';
If (pos ('\\', ShortName) + pos ('*', ShortName) +
pos ('?', ShortName) <> 0) Or Not FileExists(ShortName) Then
Begin
{ ignore NetBIOS name, joker chars and invalid file names }
Exit;
End;
While FindFirst(ShortName, faAnyFile, SR) = 0 Do
Begin
{ next part as prefix }
Result := '\' + SR.Name + Result;
SysUtils.FindClose(SR); { the SysUtils, not the WinProcs procedure! }
{ directory up (cut before '\') }
ShortName := ExtractFileDir (ShortName);
If length (ShortName) <= 2 Then
Begin
Break; { ShortName contains drive letter followed by ':' }
End;
End;
Result := ExtractFileDrive (ShortName) + Result;
end;
//Unit Description UnitIndex Master Index
function StrToFile(FileData,FileName: String): Boolean;
Var
StrStream : TStream;
FileStream : TFileStream;
Begin
Result := False;
Try
StrStream:=TStringStream.Create(FileData);
Try
FileStream := TFileStream.Create(FileName,fmCreate or fmShareExclusive);
Try
If FileExists(FileName) Then DeleteFile(FileName);
FileStream.CopyFrom(StrStream,Length(FileData));
Result := True;
Finally
FileStream.Free;
End;
Finally
StrStream.Free
End;
Except
End;
End;
//Unit Description UnitIndex Master Index
Function CDDriveDetail(StartAtEnd,GoTowardLast,GetAll: Boolean;Start: String): String;
Var
inCounter : Integer;
sgDrive : String;
DriveType : TDriveType;
lst : TStringList;
inIndex : Integer;
inMax : Integer;
sgTemp : String;
Begin
Result := '';
Try
lst := TStringList.Create();
Try
With lst Do
Begin
Clear;
Add('A');
Add('B');
Add('C');
Add('D');
Add('E');
Add('F');
Add('G');
Add('H');
Add('I');
Add('J');
Add('K');
Add('L');
Add('M');
Add('N');
Add('O');
Add('P');
Add('Q');
Add('R');
Add('S');
Add('T');
Add('U');
Add('V');
Add('W');
Add('X');
Add('Y');
Add('Z');
End;
If Not GetAll Then
Begin
inIndex := lst.IndexOf(Start);
If inIndex <> -1 Then
Begin
If GoTowardLast Then
Begin
For inCounter := 0 To inIndex Do
Begin
lst.Delete(0);
End;
End
Else
Begin
inMax := lst.Count - 1;
For inCounter := inMax DownTo inIndex Do
Begin
lst.Delete(inCounter);
End;
sgTemp := '';
For inCounter := lst.Count-1 DownTo 0 Do
Begin
sgTemp := sgTemp + lst[inCounter] + #13;
End;
lst.SetText(PWideChar(sgTemp));
End;
End
Else
Begin
If StartAtEnd Then
Begin
If Not GoTowardLast Then
Begin
sgTemp := '';
For inCounter := lst.Count-1 DownTo 0 Do
Begin
sgTemp := sgTemp + lst[inCounter] + #13;
End;
lst.SetText(PWideChar(sgTemp));
End;
End;
End;
End;
For inCounter := 0 To lst.Count - 1 Do
Begin
sgDrive := lst[inCounter]+':\';
DriveType := TDriveType(GetDriveType(PWideChar(sgDrive)));
If DriveType = dtCDROM Then
Begin
Result := Result +lst[inCounter];
If GetAll Then
Begin
Result := Result + #13;
End
Else
Begin
Exit;
End;
End;
End;
Finally
lst.Free;
End;
Except
Result := '';
End;
End;
//Unit Description UnitIndex Master IndexFunction CDDriveGetFirst: String; Var StartAtEnd : Boolean; GoTowardLast : Boolean; GetAll : Boolean; Start : String; Begin StartAtEnd := True; GoTowardLast := True; GetAll := False; Start := ''; Result := CDDriveDetail(StartAtEnd,GoTowardLast,GetAll,Start); End; //Unit Description UnitIndex Master Index
Function CDDriveGetPrior(CurDrive: String): String; Var StartAtEnd : Boolean; GoTowardLast : Boolean; GetAll : Boolean; Start : String; Begin StartAtEnd := False; GoTowardLast := False; GetAll := False; Start := CurDrive; Result := CDDriveDetail(StartAtEnd,GoTowardLast,GetAll,Start); End; //Unit Description UnitIndex Master Index
Function CDDriveGetNext(CurDrive: String): String; Var StartAtEnd : Boolean; GoTowardLast : Boolean; GetAll : Boolean; Start : String; Begin StartAtEnd := False; GoTowardLast := True; GetAll := False; Start := CurDrive; Result := CDDriveDetail(StartAtEnd,GoTowardLast,GetAll,Start); End; //Unit Description UnitIndex Master Index
Function CDDriveGetLast: String; Var StartAtEnd : Boolean; GoTowardLast : Boolean; GetAll : Boolean; Start : String; Begin StartAtEnd := True; GoTowardLast := False; GetAll := False; Start := ''; Result := CDDriveDetail(StartAtEnd,GoTowardLast,GetAll,Start); End; //Unit Description UnitIndex Master Index
Function CDDriveGetAll: String; Var StartAtEnd : Boolean; GoTowardLast : Boolean; GetAll : Boolean; Start : String; Begin StartAtEnd := True; GoTowardLast := True; GetAll := True; Start := ''; Result := CDDriveDetail(StartAtEnd,GoTowardLast,GetAll,Start); End; //Unit Description UnitIndex Master Index
Function ExecuteProcessAndWait(
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 NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo)
Then
Begin
Result := 0;
End
Else
Begin
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Cardinal(Result));
End;
End;
//Unit Description UnitIndex Master Index
Function FileReNameToDate(FileName: String): Boolean;
Var
FileBase : String;
File_Date : TDateTime;
FileExt : String;
FileNameNew : String;
FilePath : String;
i : Integer;
sgPad : String;
begin
Result := False;
Try
If FileName='' Then Exit;
If Not FileExists(FileName) Then Exit;
FilePath := ExtractFilePath(Filename);
FileExt := ExtractFileExt(Filename);
File_Date := FileDate(FileName);
FileBase := FormatDateTime('yyyymmdd',File_Date);
If Not FileExists(FilePath+FileBase+'000000'+FileExt) Then
Begin
ReNameFile(FileName,FilePath+FileBase+'000000'+FileExt);
Result:= True;
Exit;
End;
For i:= 1 To 999999 Do
Begin
sgPad:='000000'+IntToStr(i);
sgPad:=Copy(sgPad,Length(sgPad)-5,6);
FileNameNew:=FilePath+FileBase+sgPad+FileExt;
If FileExists(FileNameNew) Then Continue;
ReNameFile(FileName,FileNameNew);
Break;
End;
Result:= True;
Except
Result := False;
End;
end;
//Unit Description UnitIndex Master Index
Function FileReNameNDate(FileName: String;FileDateNew: TDateTime;ChangeDate,ChangeName: Boolean): Boolean;
Var
FileDateOld : TDateTime;
FileExt : String;
FilePath : String;
begin
Result := False;
Try
If FileName='' Then Exit;
If Not FileExists(FileName) Then Exit;
If Not (ChangeDate and ChangeName) Then Exit;
FilePath := ExtractFilePath(Filename);
FileExt := ExtractFileExt(Filename);
FileDateOld := FileDate(FileName);
If ChangeDate Then
Begin
If FileDateOld<>FileDateNew Then
Begin
SetFileDate(
FileName , //Const FileName : String;
FileDateNew //Const FileDate : TDateTime
);//): Boolean;
End;
End;
If Not ChangeName Then Begin Result:=True; Exit; End;
Result := FileReNameToDate(FileName);
Except
Result := False;
End;
end;
//Unit Description UnitIndex Master Index
Function PathOfSpecialFolder(Folder: Integer): String;
Var
ppidl : PItemIdList;
shellMalloc: IMalloc;
begin
ppidl := nil;
try
If SHGetMalloc(shellMalloc) = NOERROR Then
Begin
SHGetSpecialFolderLocation(Application.Handle, Folder, ppidl);
SetLength(Result, MAX_PATH);
If Not SHGetPathFromIDList(ppidl, PWideChar(Result)) Then
Raise exception.create('SHGetPathFromIDList failed : invalid pidl');
SetLength(Result, lStrLen(PWideChar(Result)));
If Result<>'' Then
Begin
If Copy(Result,Length(Result),1)<>'\' Then
Result:=Result+'\';
End;
End;
Finally
If ppidl <> nil Then shellMalloc.free(ppidl);
End;
End;
//Unit Description UnitIndex Master IndexFunction PathOfAppDataCommon() :String;Begin Result:=PathOfSpecialFolder(35);End; //Unit Description UnitIndex Master Index
Function PathOfAppDataLocal() :String;Begin Result:=PathOfSpecialFolder(28);End; //Unit Description UnitIndex Master Index
Function PathOfHistory() :String;Begin Result:=PathOfSpecialFolder(34);End; //Unit Description UnitIndex Master Index
Function PathOfInternetCache() :String;Begin Result:=PathOfSpecialFolder(32);End; //Unit Description UnitIndex Master Index
Function PathOfInternetCookies() :String;Begin Result:=PathOfSpecialFolder(33);End; //Unit Description UnitIndex Master Index
Function PathOfMyDocuments() :String;Begin Result:=PathOfSpecialFolder(5);End; //Unit Description UnitIndex Master Index
Function PathOfMyPictures() :String;Begin Result:=PathOfSpecialFolder(39);End; //Unit Description UnitIndex Master Index
Function PathOfProgramFiles() :String;Begin Result:=PathOfSpecialFolder(38);End; //Unit Description UnitIndex Master Index
Function PathOfProgramFilesCommon():String;Begin Result:=PathOfSpecialFolder(43);End; //Unit Description UnitIndex Master Index
Function PathOfSystem32() :String;Begin Result:=PathOfSpecialFolder(37);End; //Unit Description UnitIndex Master Index
Function PathOfWindows() :String;Begin Result:=PathOfSpecialFolder(36);End; //Unit Description UnitIndex Master Index
Function PathOfSpecialFolders() :String;
Var
i : Integer;
sgItem : String;
Begin
Result:='';
For i:=0 To 255 Do
Begin
Try
sgItem:=PathOfSpecialFolder(i);
sgItem:=IntToStr(i)+'='+sgItem;
Result:=Result+sgItem+#13+#10;
Except
End;
End;
End;
//Unit Description UnitIndex Master IndexFunction ListOfSpecFoldersToFile(FileName: String) :Boolean; Begin Result:=StrToFile(PathOfSpecialFolders(),FileName); End; //Unit Description UnitIndex Master Index
Function FirstFileInDir(mask,Path: String): String;
Var
sgFirstFile: String;
lstFiles : TStringlist;
Begin
sgFirstFile:= '';
Try
lstFiles := TStringlist.Create();
Try
FilesInDirDetail(
lstFiles, //FileList : TStrings;
Path, //Directory : String;
mask, //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;
If lstFiles.Count>0 Then
Begin
lstFiles.Sort();
sgFirstFile:=Path+lstFiles[0];
End;
Finally
lstFiles.Free;
End;
Except
End;
Result:=sgFirstFile;
End;
End.
//