I am using Delphi2006 and I want to find the location of a particular program using Delphi code.
Here's a Delphi program that can find all files called aFileName, and puts the results into the aDestFiles stringlist.
function findFilesCalled(aFileName : String; aDestFiles : TStringList) : boolean;
var
subDirs : TStringList;
dir : Char;
sRec : TSearchRec;
toSearch : string;
begin
subdirs := TStringList.Create;
for dir := 'A' to 'Z' do
if DirectoryExists(dir + ':\') then
subdirs.add(dir + ':');
try
while (subdirs.count > 0) do begin
toSearch := subdirs[subdirs.count - 1];
subdirs.Delete(subdirs.Count - 1);
if FindFirst(toSearch + '\*.*', faDirectory, sRec) = 0 then begin
repeat
if (sRec.Attr and faDirectory) <> faDirectory then
Continue;
if (sRec.Name = '.') or (sRec.Name = '..') then
Continue;
subdirs.Add(toSearch + '\' + sRec.Name);
until FindNext(sRec) <> 0;
end;
FindClose(sRec);
if FindFirst(toSearch + '\' + aFileName, faAnyFile, sRec) = 0 then begin
repeat
aDestFiles.Add(toSearch + '\' + sRec.Name);
until FindNext(sRec) <> 0;
end;
FindClose(sRec);
end;
finally
FreeAndNil(subdirs);
end;
Result := aDestFiles.Count > 0;
end;
Related
A parent directory D:\AAA has 2 child empty Directory D:\AAA\BB1 and D:\AAA\BB2
my requirement is how to remove empty Directory recursively.
Here are two function found on internet as below :
//remove empty Directory recursively
function RemoveEmptyDirectory(path: string) : Boolean;
var
MySearch: TSearchRec;
Ended: Boolean;
begin
if FindFirst(path + '\*.*', faDirectory, MySearch) = 0 then
begin
repeat
if ((MySearch.Attr and faDirectory) = faDirectory) and
(MySearch.Name[1] <> '.') then
begin
if DirectoryIsEmpty(path + '\' + MySearch.Name) then
TDirectory.Delete(path + '\' + MySearch.Name)
else
begin
RemoveEmptyDirectory(path + '\' + MySearch.Name);
if DirectoryIsEmpty(path + '\' + MySearch.Name) then
RemoveEmptyDirectory(path + '\' + MySearch.Name);
end;
end;
until FindNext(MySearch) <> 0;
FindClose(MySearch);
end;
end;
// check directory is empty or not
function DirectoryIsEmpty(Directory: string): Boolean;
var
SR: TSearchRec;
i: Integer;
begin
Result := False;
FindFirst(IncludeTrailingPathDelimiter(Directory) + '*', faAnyFile, SR);
for i := 1 to 2 do
if (SR.Name = '.') or (SR.Name = '..') then
Result := FindNext(SR) <> 0;
FindClose(SR);
end;
My problem is here : at first run function RemoveEmptyDirectory will found D:\AAA is not empty, then will run send round (recursively way),
After remove 2 child directory D:\AAA\BB1 and D:\AAA\BB2, the parent will become an empty Directory,
Back to first round place the function DirectoryIsEmpty report the parent is not an empty directory!!!!
Why !!!!
Is windows system still not change the directory state ???
So, is there any good suggestion that could meet my requirement.
You never check D:\AAA itself.
Just make checking and deletion in the end:
function RemoveEmptyDirectory(path: string) : Boolean;
var
MySearch: TSearchRec;
Ended: Boolean;
begin
if FindFirst(path + '\*.*', faDirectory, MySearch) = 0 then
begin
repeat
if ((MySearch.Attr and faDirectory) = faDirectory) and
(MySearch.Name[1] <> '.') then
begin
if DirectoryIsEmpty(path + '\' + MySearch.Name) then
TDirectory.Delete(path + '\' + MySearch.Name)
else
begin
RemoveEmptyDirectory(path + '\' + MySearch.Name);
if DirectoryIsEmpty(path + '\' + MySearch.Name) then
RemoveEmptyDirectory(path + '\' + MySearch.Name);
end;
end;
until FindNext(MySearch) <> 0;
FindClose(MySearch);
end;
if DirectoryIsEmpty(path) then
TDirectory.Delete(path);
end;
You can use TDirectory as
TDirectory.Delete('D:\AAA', True);
If you need to check if the directories are empty or not, you can use TDirectory.GetDirectories() as
Var
S: string;
begin
for S in TDirectory.GetDirectories('D:\AAA', '*', TSearchOption.soAllDirectories) do
begin
if TDirectory.IsEmpty(S) then
TDirectory.Delete(S);
end;
If TDirectory.IsEmpty('D:\AAA') then
TDirectory.Delete('D:\AAA');
I think this is simple and straightforward and should do fine if top performance is not crucial:
procedure RemoveEmptyDirs;
var
i,Removed:integer;
Arr:TStringDynArray;
const
TargedDir = 'C:\BunchOfDirs\';
begin
Arr := TDirectory.GetDirectories(TargedDir,'*',TSearchOption.soAllDirectories);
Repeat
Removed := 0;
For i := High(Arr) downto Low(Arr) do begin
If TDirectory.IsEmpty(Arr[i]) then begin
TDirectory.Delete(Arr[i]);
System.Delete(Arr,i,1);
Inc(Removed);
end;
end;
Until Removed = 0;
end;
Have some old code (written by someone else) that I need to fix to work with Unicode strings in Delphi 10.1. EDIT: I've narrowed my question down to the following: code below fails with unicode strings. Suggestions?
//global variable:
var
UpCaseLookup : array[ 1..255 ] of char;
// ---- Knuth, Morris, Pratt:
type
failure = array[1..255] of word;
procedure PrepareUpcaseLookup;
var
S : string; //was shortstring;
i : integer;
begin
for i := 1 to 255 do
begin
S := ToUpper( chr(i) ); //was AnsiUpperCase
UpCaseLookup[i] := S[1]
end
end;
function PosKnuthMorrisPratt(Pattern, Text: string): Integer;
var
Prefix: array of Integer;
i, k: Integer;
begin
Result := 0;
if (Pattern = '') or (Text = '') then
Exit;
Pattern := UpperCase(Pattern); // case-insensitive
Text := UpperCase(Text);
// Buld prefix function array
SetLength(Prefix, Length(Pattern) + 1);
Prefix[1] := 0;
k := 0;
for i := 2 to Length(Pattern) do begin
while (k > 0) and (Pattern[k + 1] <> Pattern[i]) do
k := Prefix[k];
if Pattern[k + 1] = Pattern[i] then
Inc(k);
Prefix[i] := k;
end;
k := 0;
for i := 1 to Length(Text) do begin
while (k > 0) and (Pattern[k + 1] <> Text[i]) do
k := Prefix[k];
if Pattern[k + 1] = Text[i] then
Inc(k);
if k = Length(Pattern) then
Exit(i + 1 - Length(Pattern));
end;
end;
begin
Memo1.Lines.Add(IntToStr(PosKnuthMorrisPratt('abaBc', 'ggabagabAbccsab')));
Memo1.Lines.Add(IntToStr(PosKnuthMorrisPratt('ab', 'ggagbc')));
I'm french so sorry for my little language...
So, my project is here Memo and create file and folder?
i have a problem with my code :
var
path: String;
F: TextFile;
i, e: Integer;
begin
for i := 0 to Memo1.Lines.Count - 1 do
begin
if Length(Memo1.Lines[i]) > 0 then
begin
if Memo1.Lines[i][1] = '\' then // first character for file
if Pos('.', Memo1.Lines[i]) > 0 then // confirm file
begin
path := extractfilepath(Edit1.Text) + Memo1.Lines[i];
// showmessage(path);
if not FileExists(path) then
begin
AssignFile(F, path);
Rewrite(F);
CloseFile(F);
end;
end;
e := Length(Memo1.Lines[i]);
case Memo1.Lines[i][e] of // last character for folder
'\':
begin
path := extractfilepath(Edit1.Text) + Memo1.Lines[i];
if not DirectoryExists(path) then
ForceDirectories(path); // create folder
end;
end;
end;
end;
end;
my structure in Tmemo is :
and my bad result:
i test first and last character for know what is it file or folder and my problem is file saved in currentPath, no in folder1:
Dir:
folder1->file1.txt
folder2 ->file2.txt and file2-3.txt
etc..
can you help me please?
Thanks a lot.
You have to test first.
is the token a directory then isFolder:=true.
"memo2" is just about to create file.txt easier. (more convenient)
Delphi 5
implementation
{$R *.DFM}
uses FileCtrl;
procedure TForm1.FormActivate(Sender: TObject);
begin
Memo1.Text:='test.txt'#13#10'folder1\'#13#10'\file1.txt'#13#10'folder2\'#13#10'\file2.txt'#13#10'\file2-3.txt'#13#10;
Memo2.Text:='';
Edit1.Text:='F:\testdir';
end;
procedure TForm1.Button1Click(Sender: TObject);
var
path,aktpath,actToken: String;
backSl : Char;
i: Integer;
isFolder:Boolean;
begin
backSl := #92; // This only for better reading the code in SO
isFolder:=false;
aktpath:='';actToken:='';
for i := 0 to Memo1.Lines.Count - 1 do
begin
if Length(Memo1.Lines[i]) > 0 then
begin
actToken:=Memo1.Lines[i];
// Folder -----------------------------------------
if copy(actToken,length(actToken),1)= backSl then begin
if copy(Edit1.Text,length(Edit1.Text),1)= backSl then
path := Edit1.Text + actToken else
path := Edit1.Text + backSl + actToken;
if not DirectoryExists(path) then
ForceDirectories(path); // create folder
isFolder:=true;
aktpath:=path;
continue;
end;
// File -----------------------------------------
if copy(actToken,1,1) = backSl then // first character for file
if Pos('.', actToken) > 0 then // confirm file
begin
if isFolder then path:=aktpath + actToken else
path:=Edit1.Text + actToken;
path:=StringReplace(path,'\\',backSl,[rfReplaceAll]);
if not FileExists(path) then Memo2.Lines.SaveToFile(path);
continue;
end;
end;
end;
end;
end.
UPDATE : \file1.txt:Hello to the world
var
[...]
actTokenTxt: String;
count: Integer;
begin
isFolder:=false;
[...]
// File -----------------------------------------
if copy(actToken,1,1) = backSl then // first character for file
if Pos('.', actToken) > 0 then // confirm file
begin
count:=Pos(':', actToken);
if count > 0 then begin
actTokenTxt:=copy(actToken,1,count);
Memo2.Text:=StringReplace(actToken,actTokenTxt,'',[]);
actToken:=copy(actToken,1,count-1);;
end;
if isFolder then path:=aktpath + actToken else
path:=Edit1.Text + actToken;
path:=StringReplace(path,'\\',backSl,[rfReplaceAll]);
if not FileExists(path) then Memo2.Lines.SaveToFile(path);
continue;
end;
Remember to delete file1.txt if it is present
Do'nt forget to set Memo2.Text:='' if there is not : Otherwise, all files of the same text !!
Try it with if count > 0 then begin [...] else Memo2.Text:=''
var
folder_path, path: String;
F: TextFile;
i, e, num: Integer;
begin
for i := 0 to Memo1.Lines.Count - 1 do
begin
if Length(Memo1.Lines[i]) > 0 then
begin
e := Length(Memo1.Lines[i]);
if Memo1.Lines[i][e] = '\' then // last character for folder
begin
num := StrToInt(Memo1.Lines[i][7]);
folder_path := Copy(Memo1.Lines[i], 1, Length(Memo1.Lines[i])-1);
path := extractfilepath(Edit1.Text) + Memo1.Lines[i];
//showmessage(path);
if not DirectoryExists(folder_path) then
ForceDirectories(folder_path); // create folder
end
else if Memo1.Lines[i][1] = '\' then // first character for file
if Pos('.', Memo1.Lines[i]) > 0 then // confirm file
begin
if (num = StrToInt(Memo1.Lines[i][6])) then
path := extractfilepath(Edit1.Text) + folder_path + Memo1.Lines[i]
else path := extractfilepath(Edit1.Text) + Memo1.Lines[i];
//showmessage(path);
if not FileExists(path) then
begin
AssignFile(F, path);
Rewrite(F);
CloseFile(F);
end;
end;
end;
end;
end;
This assumes that folder# will always be the folder string with # = number.
Similar with files.
using code from a tutorial and making various modifications i have got working code for a recursive procedure which searches for a file with a file name which has been entered by the user at a given path and through sub folders when the parameters are passed from another procedure at a button click.
it is as follows :
procedure TfrmProject.btnOpenDocumentClick(Sender: TObject);
begin
FileSearch('C:\Users\Guest\Documents', edtDocument.Text+'.docx');
end;
procedure TfrmProject.FileSearch(const Pathname, FileName : string);
var Word : Variant;
Rec : TSearchRec;
Path : string;
begin
Path := IncludeTrailingBackslash(Pathname);
if FindFirst(Path + FileName, faAnyFile - faDirectory, Rec) = 0
then repeat Word:=CreateOLEObject('Word.Application');
Word.Visible:=True;
Word.Documents.Open(Path + FileName);
until FindNext(Rec) <> 0;
FindClose(Rec);
if FindFirst(Path + '*.*', faDirectory, Rec) = 0 then
try
repeat
if ((Rec.Attr and faDirectory) <> 0) and (Rec.Name<>'.') and (Rec.Name<>'..') then
FileSearch(Path + Rec.Name, FileName);
until FindNext(Rec) <> 0;
finally
FindClose(Rec);
end;
end; //procedure FileSearch
After trying to learn what is happening of i have gained a good understanding up until the point of the first FindClose(Rec), however this section of code i'm still unsure of :
if FindFirst(Path + '*.*', faDirectory, Rec) = 0 then
try
repeat
if ((Rec.Attr and faDirectory) <> 0) and (Rec.Name<>'.') and (Rec.Name<>'..') then
FileSearch(Path + Rec.Name, FileName);
until FindNext(Rec) <> 0;
finally
FindClose(Rec);
end;
end;
my guess is that the first line is checking whether there are any subfolders found in the given path, but i'm not too sure on the rest and how it works if that is even correct.
help would be appreciated.
I want to loop through all the files in a given directory and return their version number and exe name. I have tried digging into the shell to see if I can pull this off, however I have not been able to find a solution. Any tips would be appreciated.
This does it:
Drop a TMemo and a TButton on your form and do
type
TVerInfo = packed record
vMajor, vMinor, vRelease, vBuild: word;
end;
function GetFileVerNumbers(const FileName: string): TVerInfo;
var
len, dummy: cardinal;
verdata: pointer;
verstruct: pointer;
const
InvalidVersion: TVerInfo = (vMajor: 0; vMinor: 0; vRelease: 0; vBuild: 0);
begin
len := GetFileVersionInfoSize(PWideChar(FileName), dummy);
if len = 0 then
Exit(InvalidVersion);
GetMem(verdata, len);
try
GetFileVersionInfo(PWideChar(FileName), 0, len, verdata);
VerQueryValue(verdata, '\', verstruct, dummy);
result.vMajor := HiWord(TVSFixedFileInfo(verstruct^).dwFileVersionMS);
result.vMinor := LoWord(TVSFixedFileInfo(verstruct^).dwFileVersionMS);
result.vRelease := HiWord(TVSFixedFileInfo(verstruct^).dwFileVersionLS);
result.vBuild := LoWord(TVSFixedFileInfo(verstruct^).dwFileVersionLS);
finally
FreeMem(verdata);
end;
end;
function GetFileVer(const FileName: string): string;
begin
with GetFileVerNumbers(FileName) do
result := IntToStr(vMajor) + '.' +
IntToStr(vMinor) + '.' + IntToStr(vRelease) + '.' +
IntToStr(vBuild);
end;
procedure TForm1.Button1Click(Sender: TObject);
const
path = 'C:\WINDOWS';
var
SR: TSearchRec;
begin
Memo1.Clear;
if FindFirst(IncludeTrailingBackslash(path) + '*.exe', faAnyFile, SR) = 0 then
try
repeat
Memo1.Lines.Add(SR.Name + #9 +
GetFileVer(IncludeTrailingBackslash(path) + SR.Name));
until FindNext(SR) <> 0;
finally
FindClose(SR);
end;
end;