I'd like to replace a file (= delete old and add new) in a zip archive with the Delphi XE2/XE3 standard System.Zip unit. But there are no replace/delete methods. Does anybody have an idea how it could be achieved without needing to extract all files and add them to a new archive?
I have this code, but it adds the "document.txt" once more if it's already present:
var
ZipFile: TZipFile;
SS: TStringStream;
const
ZipDocument = 'E:\document.zip';
begin
ZipFile := TZipFile.Create; //Zipfile: TZipFile
SS := TStringStream.Create('hello');
try
if FileExists(ZipDocument) then
ZipFile.Open(ZipDocument, zmReadWrite)
else
ZipFile.Open(ZipDocument, zmWrite);
ZipFile.Add(SS, 'document.txt');
ZipFile.Close;
finally
SS.Free;
ZipFile.Free;
end;
end;
Note: I used TPAbbrevia before (that did the job), but I'd like to use Delphi's Zip unit now. So please do not answer something like "use another library". Thank you.
I'd recommend Abbrevia because I'm biased :), you already know it, and it doesn't require any hacks. Barring that, here's your hack:
type
TZipFileHelper = class helper for TZipFile
procedure Delete(FileName: string);
end;
{ TZipFileHelper }
procedure TZipFileHelper.Delete(FileName: string);
var
i, j: Integer;
StartOffset, EndOffset, Size: UInt32;
Header: TZipHeader;
Buf: TBytes;
begin
i := IndexOf(FileName);
if i <> -1 then begin
// Find extents for existing file in the file stream
StartOffset := Self.FFiles[i].LocalHeaderOffset;
EndOffset := Self.FEndFileData;
for j := 0 to Self.FFiles.Count - 1 do begin
if (Self.FFiles[j].LocalHeaderOffset > StartOffset) and
(Self.FFiles[j].LocalHeaderOffset <= EndOffset) then
EndOffset := Self.FFiles[j].LocalHeaderOffset;
end;
Size := EndOffset - StartOffset;
// Update central directory header data
Self.FFiles.Delete(i);
for j := 0 to Self.FFiles.Count - 1 do begin
Header := Self.FFiles[j];
if Header.LocalHeaderOffset > StartOffset then begin
Header.LocalHeaderOffset := Header.LocalHeaderOffset - Size;
Self.FFiles[j] := Header;
end;
end;
// Remove existing file stream
SetLength(Buf, Self.FEndFileData - EndOffset);
Self.FStream.Position := EndOffset;
if Length(Buf) > 0 then
Self.FStream.Read(Buf[0], Length(Buf));
Self.FStream.Size := StartOffset;
if Length(Buf) > 0 then
Self.FStream.Write(Buf[0], Length(Buf));
Self.FEndFileData := Self.FStream.Position;
end;
end;
Usage:
ZipFile.Delete('document.txt');
ZipFile.Add(SS, 'document.txt');
Related
I would like to modernize the GUI of my Delphi 7 App, I have already .manifest file and it looks quite good, but the Fileopen dialogs are terrible. How the make them modern?
I am using this code at the moment.
What would it require to use e.g. IFileOpenDialog instead, how to compile the header for that, or any tweaks to dialogs.pas ?
FileOpenDialog := TOpenDialog.create(parent);
FileOpenDialog.DefaultExt := '*.x';
FileOpenDialog.Filter := 'my|*.x|Text File (CSV)|*.csv';
FileOpenDialog.options := [ofHideReadOnly,ofFileMustExist ,ofNoChangeDir,ofPathMustExist ];
if FileOpenDialog.Execute then begin
// do my tricks with FileOpenDialog.filename
FormUpdate;
end;
The following example code of IFileDialog cannot be compiled with D7:
var
FolderDialog : IFileDialog;
hr: HRESULT;
IResult: IShellItem;
FileName: PChar;
Settings: DWORD;
begin
if Win32MajorVersion >= 6 then
begin
hr := CoCreateInstance(CLSID_FileOpenDialog,
nil,
CLSCTX_INPROC_SERVER,
IFileDialog,
FolderDialog);
if hr = S_OK then
begin
FolderDialog.SetOkButtonLabel(PChar('Select'));
FolderDialog.SetTitle(PChar('Select a Directory'));
hr := FolderDialog.Show(Handle);
if hr = S_OK then
begin
hr := FolderDialog.GetResult(IResult);
if hr = S_OK then
begin
IResult.GetDisplayName(SIGDN_FILESYSPATH,FileName);
ConfigPathEdit.Text := FileName;
end;
end;
end;
end;
I used this one, I tested it with D7.
// uses commdlg
function OpenSaveFileDialog( Parent: TWinControl;
const DefExt,Filter,InitialDir,Title: string;
var FileName: string;
MustExist,OverwritePrompt,NoChangeDir,DoOpen: Boolean): Boolean;
var ofn: TOpenFileName;
szFile: array[0..MAX_PATH] of Char;
begin
Result := False;
FillChar(ofn, SizeOf(TOpenFileName), 0);
with ofn do
begin
lStructSize := SizeOf(TOpenFileName);
hwndOwner := Parent.Handle;
lpstrFile := szFile;
nMaxFile := SizeOf(szFile);
if (Title <> '') then
lpstrTitle := PChar(Title);
if (InitialDir <> '') then
lpstrInitialDir := PChar(InitialDir);
StrPCopy(lpstrFile, FileName);
lpstrFilter := PChar(StringReplace(Filter, '|', #0,[rfReplaceAll, rfIgnoreCase])+#0#0);
if DefExt <> '' then
lpstrDefExt := PChar(DefExt);
end;
if MustExist then
ofn.Flags := ofn.Flags or OFN_FILEMUSTEXIST;
if OverwritePrompt then
ofn.Flags := ofn.Flags or OFN_OVERWRITEPROMPT;
if NoChangeDir then
ofn.Flags := ofn.Flags or OFN_NOCHANGEDIR;
if DoOpen
then begin
if GetOpenFileName(ofn) then
begin
Result := True;
FileName := StrPas(szFile);
end;
end
else begin
if GetSaveFileName(ofn) then
begin
Result := True;
FileName := StrPas(szFile);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
VAR FilSelez : String;
begin
If OpenSaveFileDialog(Form1,'','*.*','c:\windows','',FilSelez,False,False,True,True) Then
Edit1.Text := FilSelez;
end;
Instead of using the IFileDialog interface you can also just modify Delphi's 7 Dialogs.pas file to display the "modern" dialogs.
First make a backup copy of the Dialogs.pas file in the Source\VCL folder under the Delphi installation directory. Then search the file for the term OFN_ENABLEHOOK. The complete line should be Flags := OFN_ENABLEHOOK;. Comment out the line. Add a new line Flags := 0; directly below.
Now search for the term OFN_ENABLETEMPLATE. Two lines above this should be an if Template <> nil then statement. Comment out this statement and all following ones up to and including hWndOwner := Application.Handle; and add the line hWndOwner := Screen.ActiveForm.Handle;.
Now make sure to replace the precompiled units Dialogs.dcu in the Lib and SLib directory under the Delphi installation directory with newly compiled Dialogs.dcu containing the changes. In the Lib directory you store a version without debug information, while the SLib directory contains a version with debug information. Make backup copies of the files before replacing them.
Please take note that the instructions given above only apply to Delphi 7. Furthermore, the code disables event handling for the common dialog components.
I am trying to find and replace text in a text file. I have been able to do this in the past with methods like:
procedure SmallFileFindAndReplace(FileName, Find, ReplaceWith: string);
begin
with TStringList.Create do
begin
LoadFromFile(FileName);
Text := StringReplace(Text, Find, ReplaceWith, [rfReplaceAll, rfIgnoreCase]);
SaveToFile(FileName);
Free;
end;
end;
The above works fine when a file is relatively small, however; when the the file size is something like 170 Mb the above code will cause the following error:
EOutOfMemory with message 'Out of memory'
I have tried the following with success, however it takes a long time to run:
procedure Tfrm_Main.button_MakeReplacementClick(Sender: TObject);
var
fs : TFileStream;
s : AnsiString;
//s : string;
begin
fs := TFileStream.Create(edit_SQLFile.Text, fmOpenread or fmShareDenyNone);
try
SetLength(S, fs.Size);
fs.ReadBuffer(S[1], fs.Size);
finally
fs.Free;
end;
s := StringReplace(s, edit_Find.Text, edit_Replace.Text, [rfReplaceAll, rfIgnoreCase]);
fs := TFileStream.Create(edit_SQLFile.Text, fmCreate);
try
fs.WriteBuffer(S[1], Length(S));
finally
fs.Free;
end;
end;
I am new to "Streams" and working with buffers.
Is there a better way to do this?
Thank You.
You have two mistakes in first code example and three - in second example:
Do not load whole large file in memory, especially in 32bit application. If file size more than ~1 Gb, you always get "Out of memory"
StringReplace slows with large strings, because of repeated memory reallocation
In second code you don`t use text encoding in file, so (for Windows) your code "think" that file has UCS2 encoding (two bytes per character). But what you get, if file encoding is Ansi (one byte per character) or UTF8 (variable size of char)?
Thus, for correct find&replace you must use file encoding and read/write parts of file, as LU RD said:
interface
uses
System.Classes,
System.SysUtils;
type
TFileSearchReplace = class(TObject)
private
FSourceFile: TFileStream;
FtmpFile: TFileStream;
FEncoding: TEncoding;
public
constructor Create(const AFileName: string);
destructor Destroy; override;
procedure Replace(const AFrom, ATo: string; ReplaceFlags: TReplaceFlags);
end;
implementation
uses
System.IOUtils,
System.StrUtils;
function Max(const A, B: Integer): Integer;
begin
if A > B then
Result := A
else
Result := B;
end;
{ TFileSearchReplace }
constructor TFileSearchReplace.Create(const AFileName: string);
begin
inherited Create;
FSourceFile := TFileStream.Create(AFileName, fmOpenReadWrite);
FtmpFile := TFileStream.Create(ChangeFileExt(AFileName, '.tmp'), fmCreate);
end;
destructor TFileSearchReplace.Destroy;
var
tmpFileName: string;
begin
if Assigned(FtmpFile) then
tmpFileName := FtmpFile.FileName;
FreeAndNil(FtmpFile);
FreeAndNil(FSourceFile);
TFile.Delete(tmpFileName);
inherited;
end;
procedure TFileSearchReplace.Replace(const AFrom, ATo: string;
ReplaceFlags: TReplaceFlags);
procedure CopyPreamble;
var
PreambleSize: Integer;
PreambleBuf: TBytes;
begin
// Copy Encoding preamble
SetLength(PreambleBuf, 100);
FSourceFile.Read(PreambleBuf, Length(PreambleBuf));
FSourceFile.Seek(0, soBeginning);
PreambleSize := TEncoding.GetBufferEncoding(PreambleBuf, FEncoding);
if PreambleSize <> 0 then
FtmpFile.CopyFrom(FSourceFile, PreambleSize);
end;
function GetLastIndex(const Str, SubStr: string): Integer;
var
i: Integer;
tmpSubStr, tmpStr: string;
begin
if not(rfIgnoreCase in ReplaceFlags) then
begin
i := Pos(SubStr, Str);
Result := i;
while i > 0 do
begin
i := PosEx(SubStr, Str, i + 1);
if i > 0 then
Result := i;
end;
if Result > 0 then
Inc(Result, Length(SubStr) - 1);
end
else
begin
tmpStr := UpperCase(Str);
tmpSubStr := UpperCase(SubStr);
i := Pos(tmpSubStr, tmpStr);
Result := i;
while i > 0 do
begin
i := PosEx(tmpSubStr, tmpStr, i + 1);
if i > 0 then
Result := i;
end;
if Result > 0 then
Inc(Result, Length(tmpSubStr) - 1);
end;
end;
var
SourceSize: int64;
procedure ParseBuffer(Buf: TBytes; var IsReplaced: Boolean);
var
i: Integer;
ReadedBufLen: Integer;
BufStr: string;
DestBytes: TBytes;
LastIndex: Integer;
begin
if IsReplaced and (not(rfReplaceAll in ReplaceFlags)) then
begin
FtmpFile.Write(Buf, Length(Buf));
Exit;
end;
// 1. Get chars from buffer
ReadedBufLen := 0;
for i := Length(Buf) downto 0 do
if FEncoding.GetCharCount(Buf, 0, i) <> 0 then
begin
ReadedBufLen := i;
Break;
end;
if ReadedBufLen = 0 then
raise EEncodingError.Create('Cant convert bytes to str');
FSourceFile.Seek(ReadedBufLen - Length(Buf), soCurrent);
BufStr := FEncoding.GetString(Buf, 0, ReadedBufLen);
if rfIgnoreCase in ReplaceFlags then
IsReplaced := ContainsText(BufStr, AFrom)
else
IsReplaced := ContainsStr(BufStr, AFrom);
if IsReplaced then
begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end
else
LastIndex := Length(BufStr);
SetLength(BufStr, LastIndex);
FSourceFile.Seek(FEncoding.GetByteCount(BufStr) - ReadedBufLen, soCurrent);
BufStr := StringReplace(BufStr, AFrom, ATo, ReplaceFlags);
DestBytes := FEncoding.GetBytes(BufStr);
FtmpFile.Write(DestBytes, Length(DestBytes));
end;
var
Buf: TBytes;
BufLen: Integer;
bReplaced: Boolean;
begin
FSourceFile.Seek(0, soBeginning);
FtmpFile.Size := 0;
CopyPreamble;
SourceSize := FSourceFile.Size;
BufLen := Max(FEncoding.GetByteCount(AFrom) * 5, 2048);
BufLen := Max(FEncoding.GetByteCount(ATo) * 5, BufLen);
SetLength(Buf, BufLen);
bReplaced := False;
while FSourceFile.Position < SourceSize do
begin
BufLen := FSourceFile.Read(Buf, Length(Buf));
SetLength(Buf, BufLen);
ParseBuffer(Buf, bReplaced);
end;
FSourceFile.Size := 0;
FSourceFile.CopyFrom(FtmpFile, 0);
end;
how to use:
procedure TForm2.btn1Click(Sender: TObject);
var
Replacer: TFileSearchReplace;
StartTime: TDateTime;
begin
StartTime:=Now;
Replacer:=TFileSearchReplace.Create('c:\Temp\123.txt');
try
Replacer.Replace('some текст', 'some', [rfReplaceAll, rfIgnoreCase]);
finally
Replacer.Free;
end;
Caption:=FormatDateTime('nn:ss.zzz', Now - StartTime);
end;
Your first try creates several copies of the file in memory:
it loads the whole file into memory (TStringList)
it creates a copy of this memory when accessing the .Text property
it creates yet another copy of this memory when passing that string to StringReplace (The copy is the result which is built in StringReplace.)
You could try to solve the out of memory problem by getting rid of one or more of these copies:
e.g. read the file into a simple string variable rather than a TStringList
or keep the string list but run the StringReplace on each line separately and write the result to the file line by line.
That would increase the maximum file size your code can handle, but you will still run out of memory for huge files. If you want to handle files of any size, your second approach is the way to go.
No - I don't think there's a faster way that the 2nd option (if you want a completely generic search'n'replace function for any file of any size). It may be possible to make a faster version if you code it specifically according to your requirements, but as a general-purpose search'n'replace function, I don't believe you can go faster...
For instance, are you sure you need case-insensitive replacement? I would expect that this would be a large part of the time spent in the replace function. Try (just for kicks) to remove that requirement and see if it doesn't speed up the execution quite a bit on large files (this depends on how the internal coding of the StringReplace function is made - if it has a specific optimization for case-sensitive searches)
I believe refinement of Kami's code is needed to account for the string not being found, but the start of a new instance of the string might occur at the end of the buffer. The else clause is different:
if IsReplaced then begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end else
LastIndex :=Length(BufStr) - Length(AFrom) + 1;
Correct fix is this one:
if IsReplaced then
begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end
else
if FSourceFile.Position < SourceSize then
LastIndex := Length(BufStr) - Length(AFrom) + 1
else
LastIndex := Length(BufStr);
I have an app that needs to do heavy text manipulation in a TStringList. Basically i need to split text by a delimiter ; for instance, if i have a singe line with 1000 chars and this delimiter occurs 3 times in this line, then i need to split it in 3 lines. The delimiter can contain more than one char, it can be a tag like '[test]' for example.
I've wrote two functions to do this task with 2 different approaches, but both are slow in big amounts of text (more then 2mbytes usually).
How can i achieve this goal in a faster way ?
Here are both functions, both receive 2 paramaters : 'lines' which is the original tstringlist and 'q' which is the delimiter.
function splitlines(lines : tstringlist; q: string) : integer;
var
s, aux, ant : string;
i,j : integer;
flag : boolean;
m2 : tstringlist;
begin
try
m2 := tstringlist.create;
m2.BeginUpdate;
result := 0;
for i := 0 to lines.count-1 do
begin
s := lines[i];
for j := 1 to length(s) do
begin
flag := lowercase(copy(s,j,length(q))) = lowercase(q);
if flag then
begin
inc(result);
m2.add(aux);
aux := s[j];
end
else
aux := aux + s[j];
end;
m2.add(aux);
aux := '';
end;
m2.EndUpdate;
lines.text := m2.text;
finally
m2.free;
end;
end;
function splitLines2(lines : tstringlist; q: string) : integer;
var
aux, p : string;
i : integer;
flag : boolean;
begin
//maux1 and maux2 are already instanced in the parent class
try
maux2.text := lines.text;
p := '';
i := 0;
flag := false;
maux1.BeginUpdate;
maux2.BeginUpdate;
while (pos(lowercase(q),lowercase(maux2.text)) > 0) and (i < 5000) do
begin
flag := true;
aux := p+copy(maux2.text,1,pos(lowercase(q),lowercase(maux2.text))-1);
maux1.add(aux);
maux2.text := copy(maux2.text,pos(lowercase(q),lowercase(maux2.text)),length(maux2.text));
p := copy(maux2.text,1,1);
maux2.text := copy(maux2.text,2,length(maux2.text));
inc(i);
end;
finally
result := i;
maux1.EndUpdate;
maux2.EndUpdate;
if flag then
begin
maux1.add(p+maux2.text);
lines.text := maux1.text;
end;
end;
end;
I've not tested the speed, but for academic purposes, here's an easy way to split the strings:
myStringList.Text :=
StringReplace(myStringList.Text, myDelimiter, #13#10, [rfReplaceAll]);
// Use [rfReplaceAll, rfIgnoreCase] if you want to ignore case
When you set the Text property of TStringList, it parses on new lines and splits there, so converting to a string, replacing the delimiter with new lines, then assigning it back to the Text property works.
The problems with your code (at least second approach) are
You are constantly using lowecase which is slow if called so many times
If I saw correctly you are copying the whole remaining text back to the original source. This is sure to be extra slow for large strings (eg files)
I have a tokenizer in my library. Its not the fastest or best but it should do (you can get it from Cromis Library, just use the units Cromis.StringUtils and Cromis.Unicode):
type
TTokens = array of ustring;
TTextTokenizer = class
private
FTokens: TTokens;
FDelimiters: array of ustring;
public
constructor Create;
procedure Tokenize(const Text: ustring);
procedure AddDelimiters(const Delimiters: array of ustring);
property Tokens: TTokens read FTokens;
end;
{ TTextTokenizer }
procedure TTextTokenizer.AddDelimiters(const Delimiters: array of ustring);
var
I: Integer;
begin
if Length(Delimiters) > 0 then
begin
SetLength(FDelimiters, Length(Delimiters));
for I := 0 to Length(Delimiters) - 1 do
FDelimiters[I] := Delimiters[I];
end;
end;
constructor TTextTokenizer.Create;
begin
SetLength(FTokens, 0);
SetLength(FDelimiters, 0);
end;
procedure TTextTokenizer.Tokenize(const Text: ustring);
var
I, K: Integer;
Counter: Integer;
NewToken: ustring;
Position: Integer;
CurrToken: ustring;
begin
SetLength(FTokens, 100);
CurrToken := '';
Counter := 0;
for I := 1 to Length(Text) do
begin
CurrToken := CurrToken + Text[I];
for K := 0 to Length(FDelimiters) - 1 do
begin
Position := Pos(FDelimiters[K], CurrToken);
if Position > 0 then
begin
NewToken := Copy(CurrToken, 1, Position - 1);
if NewToken <> '' then
begin
if Counter > Length(FTokens) then
SetLength(FTokens, Length(FTokens) * 2);
FTokens[Counter] := Trim(NewToken);
Inc(Counter)
end;
CurrToken := '';
end;
end;
end;
if CurrToken <> '' then
begin
if Counter > Length(FTokens) then
SetLength(FTokens, Length(FTokens) * 2);
FTokens[Counter] := Trim(CurrToken);
Inc(Counter)
end;
SetLength(FTokens, Counter);
end;
How about just using StrTokens from the JCL library
procedure StrTokens(const S: string; const List: TStrings);
It's open source
http://sourceforge.net/projects/jcl/
As an additional option, you can use regular expressions. Recent versions of Delphi (XE4 and XE5) come with built in regular expression support; older versions can find a free regex library download (zip file) at Regular-Expressions.info.
For the built-in regex support (uses the generic TArray<string>):
var
RegexObj: TRegEx;
SplitArray: TArray<string>;
begin
SplitArray := nil;
try
RegexObj := TRegEx.Create('\[test\]'); // Your sample expression. Replace with q
SplitArray := RegexObj.Split(Lines, 0);
except
on E: ERegularExpressionError do begin
// Syntax error in the regular expression
end;
end;
// Use SplitArray
end;
For using TPerlRegEx in earlier Delphi versions:
var
Regex: TPerlRegEx;
m2: TStringList;
begin
m2 := TStringList.Create;
try
Regex := TPerlRegEx.Create;
try
Regex.RegEx := '\[test\]'; // Using your sample expression - replace with q
Regex.Options := [];
Regex.State := [preNotEmpty];
Regex.Subject := Lines.Text;
Regex.SplitCapture(m2, 0);
finally
Regex.Free;
end;
// Work with m2
finally
m2.Free;
end;
end;
(For those unaware, the \ in the sample expression used are because the [] characters are meaningful in regular expressions and need to be escaped to be used in the regular expression text. Typically, they're not required in the text.)
I am trying to find all files that have the extenstion .cbr or .cbz
If i set my mask to *.cb?
it finds *.cbproj files. How can i set the mask to only find .cbr and .cbz files?
here is code i am using.
I have two edit boxes EDIT1 is the location to search, EDIT2 is where i put my mask. A listbox to show what it found and a Search button.
edit1 := c:\
edit2 := mask (*.cb?)
space
procedure TFAutoSearch.FileSearch(const PathName, FileName : string; const InDir : boolean);
var Rec : TSearchRec;
Path : string;
begin
Path := IncludeTrailingBackslash(PathName);
if FindFirst(Path + FileName, faAnyFile - faDirectory, Rec) = 0 then
try
repeat
ListBox1.Items.Add(Path + Rec.Name);
until FindNext(Rec) <> 0;
finally
FindClose(Rec);
end;
If not InDir then Exit;
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, True);
until FindNext(Rec) <> 0;
finally
FindClose(Rec);
end;
end; //procedure FileSearch
procedure TFAutoSearch.Button1Click(Sender: TObject);
begin
FileSearch(Edit1.Text, Edit2.Text, CheckBox1.State in [cbChecked]);
end;
end.
The easiest way is to use ExtractFileExt against the current filename and check to see if it matches either of your desired extensions.
Here's a fully-rewritten version of your FileSearch routine which does exactly what you're trying to do (according to your question, anyway):
procedure TFAutoSearch.FileSearch(const ARoot: String);
var
LExt, LRoot: String;
LRec: TSearchRec;
begin
LRoot := IncludeTrailingPathDelimiter(ARoot);
if FindFirst(LRoot + '*.*', faAnyFile, LRec) = 0 then
begin
try
repeat
if (LRec.Attr and faDirectory <> 0) and (LRec.Name <> '.') and (LRec.Name <> '..') then
FileSearch(LRoot + LRec.Name)
else
begin
LExt := UpperCase(ExtractFileExt(LRoot + LRec.Name));
if (LExt = '.CBR') or (LExt = '.CBZ') then
ListBox1.Items.Add(LRoot + LRec.Name);
end;
until (FindNext(LRec) <> 0);
finally
FindClose(LRec);
end;
end;
end;
While the other answer suggesting the use of multiple extensions as a mask *.cbr;*.cbz should (in principal anyway) work, I've noted through bitter experience that the FindFirst and FindNext methods in Delphi tend not to accept multiple extensions in a mask!
The code I've provided should work just fine for your needs, so enjoy!
UPDATED: To allow the use of multiple extensions in a Mask dynamically at runtime (as indicated by the OP's first comment to this answer).
What we're going to do is take a String from your TEdit control (this String is one or more File Extensions as you would expect), "Explode" the String into an Array, and match each file against each Extension in the Array.
Sounds more complicated than it is:
type
TStringArray = Array of String; // String Dynamic Array type...
// Now let's provide a "Mask Container" inside the containing class...
TFAutoSearch = class(TForm)
// Normal stuff in here
private
FMask: TStringArray; // Our "Mask Container"
end;
This code will populate FMask with each individual mask extension separated by a ; such as .CBR;.CBZ.
Note this method will not accept Wildcard characters or any other Regex magic, but you can modify it as you require!
procedure TFAutoSearch.ExplodeMask(const AValue: String);
var
LTempVal: String;
I, LPos: Integer;
begin
LTempVal := AValue;
I := 0;
while Length(LTempVal) > 0 do
begin
Inc(I);
SetLength(FMask, I);
LPos := Pos(';', LTempVal);
if (LPos > 0) then
begin
FMask[I - 1] := UpperCase(Copy(LTempVal, 0, LPos - 1));
LTempVal := Copy(LTempVal, LPos + 1, Length(LTempVal));
end
else
begin
FMask[I - 1] := UpperCase(LTempVal);
LTempVal := EmptyStr;
end;
end;
end;
We now need a function to determine if the nominated file matches any of the defined Extensions:
function TFAutoSearch.MatchMask(const AFileName: String): Boolean;
var
I: Integer;
LExt: String;
begin
Result := False;
LExt := UpperCase(ExtractFileExt(LExt));
for I := Low(FMask) to High(FMask) do
if (LExt = FMask[I]) then
begin
Result := True;
Break;
end;
end;
Now here's the modified FileSearch procedure:
procedure TFAutoSearch.FileSearch(const ARoot: String);
var
LRoot: String;
LRec: TSearchRec;
begin
LRoot := IncludeTrailingPathDelimiter(ARoot);
if FindFirst(LRoot + '*.*', faAnyFile, LRec) = 0 then
begin
try
repeat
if (LRec.Attr and faDirectory <> 0) and (LRec.Name <> '.') and (LRec.Name <> '..') then
FileSearch(LRoot + LRec.Name)
else
begin
if (MatchMask(LRoot + LRec.Name)) then
ListBox1.Items.Add(LRoot + LRec.Name);
end;
until (FindNext(LRec) <> 0);
finally
FindClose(LRec);
end;
end;
end;
Finally, here's how you initiate your search:
procedure TFAutoSearch.btnSearchClick(Sender: TObject);
begin
ExplodeMask(edMask.Text);
FileSearch(edPath.Text);
end;
Where edMask is defined in your question as Edit2 and edPath is defined in your question as Edit1. Just remember that this method doesn't support the use of Wildcard or other Special Chars, so edMask.Text should be something like .CBR;.CBZ
If you use the Regex library for Delphi, you could easily modify this method to support all of the Expression Cases you could ever imagine!
Dorin's suggestion to replace your mask with *.cbr;*.cbz should work. That is, it won't match cbproj anymore. It would, however, still match cbzy or any other extension that starts with cbr or cbz. The reason for this is that FindFirst/FindNext match both the long form and the legacy short forms (8.3) of file names. So the short forms will always have truncated extensions where cbproj is shortened to cbp, and therefore matches cb?.
This is supposed to be avoidable by using FindFirstEx instead, but this requires a small rewrite of your search function and actually didn't work for me. So instead I just double checked all matches with the MatchesMask function.
I'm having problem with SHGetFileInfoW function I'm using.
It's a quite slow and first read on startup (Initialization) consumes 100ms.
In MSDN stays that it should be read from thread, not the main thread because it can stuck process.
I want to use some other function, if there is any, in order to read Icons.
Another thing. How is possible to read big icons, currently I can read up to 32x32 (SHGFI_LARGEICON)
Thanks!
Actual code:
procedure TForm1.LoadIcons;
var
Info: TShFileInfo;
Icon: TIcon;
Flags: UINT;
FileName: PAnsiChar;
begin
FileName := '.txt';
Flags := SHGFI_USEFILEATTRIBUTES or SHGFI_ICON or SHGFI_LARGEICON;
Icon := TIcon.Create;
try
SHGetFileInfo(FileName, FILE_ATTRIBUTE_NORMAL, Info,
SizeOf(Info), Flags);
Icon.Handle := Info.hIcon;
Image1.Picture.Assign(Icon);
Image1.Refresh;
finally
DestroyIcon(Info.hIcon);
Icon.Free;
end;
end;
You could find the DefaultIcon for a given file extension from the Registry and use ExtractIconEx. Here is an example
I don't know if it's faster than SHGetFileInfo
EDIT:
I have extracted (from the sample) the part which gets the ICON from the Extension.
It actually works very fast. could be optimized more.
(I modified the code a bit):
// find the icon for a certain file extension in the registry
function TForm1.RegistryIconExtraction(Extension : string): integer;
var
RegKey : TRegistry;
IconPos : integer;
AssocAppInfo : string;
ExtractPath, FileName : string;
IconHandle, PLargeIcon, PSmallIcon : HICON;
AnIcon : TIcon;
begin
Result := 0; // default icon
if Extension[1] <> '.' then Extension := '.' + Extension;
RegKey := TRegistry.Create(KEY_READ);
try
// KEY_QUERY_VALUE grants permission to query subkey data.
RegKey.RootKey := HKEY_CLASSES_ROOT; // set folder for icon info lookup
if RegKey.OpenKeyReadOnly(Extension) then // extension key exists?
try
AssocAppInfo := RegKey.ReadString(''); // read app key
RegKey.CloseKey;
except
Exit;
end;
if ((AssocAppInfo <> '') and // app key and icon info exists?
(RegKey.OpenKeyReadOnly(AssocAppInfo + '\DefaultIcon'))) then
try
ExtractPath := RegKey.ReadString(''); // icon path
RegKey.CloseKey;
except
Exit;
end;
finally
RegKey.Free;
end;
// IconPos after comma in key ie: C:\Program Files\Winzip\Winzip.Exe,0
// did we get a key for icon, does IconPos exist after comma seperator?
If ((ExtractPath <> '') and (pos(',', ExtractPath) <> 0)) then
begin
// Filename in registry key is before the comma seperator
FileName := Copy(ExtractPath, 1, Pos(',', ExtractPath) - 1);
// extract the icon Index from after the comma in the ExtractPath string
try
IconPos := StrToInt(copy(ExtractPath, Pos(',', ExtractPath) + 1,
Length(ExtractPath) - Pos(',', ExtractPath) + 1));
except
Exit;
end;
IconHandle := ExtractIconEx(PChar(FileName), IconPos, PLargeIcon, PSmallIcon, 1);
If (PLargeIcon <> 0) then
begin
AnIcon := TIcon.Create;
AnIcon.Handle := PLargeIcon;
Image1.Picture.Assign(AnIcon);
Image1.Refresh;
AnIcon.Free;
end;
DestroyIcon(PLargeIcon);
DestroyIcon(PSmallIcon);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
t1, t2: DWORD;
begin
t1 := GetTickCount;
RegistryIconExtraction('.txt');
t2 := GetTickCount;
Memo1.Lines.Add(IntToStr(t2-t1));
end;
EDIT2: The sample code is now Vista/Win7 UAC compliant.