neoturk: ...Set a file's date ?...
function SetFileDateTime(FileName: string; NewDateTime: TDateTime): Boolean;
var
FileHandle: Integer;
FileTime: TFileTime;
LFT: TFileTime;
LST: TSystemTime;
begin
Result := False;
try
DecodeDate(NewDateTime, LST.wYear, LST.wMonth, LST.wDay);
DecodeTime(NewDateTime, LST.wHour, LST.wMinute, LST.wSecond, LST.wMilliSeconds);
if SystemTimeToFileTime(LST, LFT) then
begin
if LocalFileTimeToFileTime(LFT, FileTime) then
begin
FileHandle := FileOpen(FileName, fmOpenReadWrite or
fmShareExclusive);
if SetFileTime(FileHandle, nil, nil, @FileTime) then
Result := True;
end;
end;
finally
FileClose(FileHandle);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
if SetFileDateTime(OpenDialog1.FileName, now) then
ShowMessage('Date set to now !');
end;
Delphi - .....................................
neoturk: ...Write to-read text files ?...
// Create a new text file and write some text into it
procedure NewTxt;
var
f: Textfile;
begin
AssignFile(f, 'c:ek.txt'); {Assigns the Filename}
ReWrite(f); {Create a new file named ek.txt}
Writeln(f, 'You have written text into a .txt file');
Closefile(f); {Closes file F}
end;
// Open existing text file and append some text
procedure OpenTxt;
var
F: Textfile;
begin
AssignFile(f, 'c:ek.txt'); {Assigns the Filename}
Append(f); {Opens the file for editing}
Writeln(f, 'You have written text into a .txt file');
Closefile(f); {Closes file F}
end;
// Open existing text file and show first line
procedure ReadTxt;
var
F: Textfile;
str: string;
begin
AssignFile(f, 'c:ek.txt'); {Assigns the Filename}
Reset(f); {Opens the file for reading}
Readln(f, str);
ShowMessage('1. line of textfile:' + str);
Closefile(f); {Closes file F}
end;
Delphi - .....................................
neoturk: ...Write to-read text files ?...
// Create a new text file and write some text into it
procedure NewTxt;
var
f: Textfile;
begin
AssignFile(f, 'c:ek.txt'); {Assigns the Filename}
ReWrite(f); {Create a new file named ek.txt}
Writeln(f, 'You have written text into a .txt file');
Closefile(f); {Closes file F}
end;
// Open existing text file and append some text
procedure OpenTxt;
var
F: Textfile;
begin
AssignFile(f, 'c:ek.txt'); {Assigns the Filename}
Append(f); {Opens the file for editing}
Writeln(f, 'You have written text into a .txt file');
Closefile(f); {Closes file F}
end;
// Open existing text file and show first line
procedure ReadTxt;
var
F: Textfile;
str: string;
begin
AssignFile(f, 'c:ek.txt'); {Assigns the Filename}
Reset(f); {Opens the file for reading}
Readln(f, str);
ShowMessage('1. line of textfile:' + str);
Closefile(f); {Closes file F}
end;
Delphi - .....................................
neoturk: ...Show the 'open with'-dialog ?...
{
This code displays the application/file "Open With" dialog
Passing the full file path and name as a parameter will cause the
dialog to display the line "Click the program you want to use to open
the file 'filename'".
}
uses
ShellApi;
procedure OpenWith(FileName: string);
begin
ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'),
PChar('shell32.dll,OpenAs_RunDLL ' + FileName), nil, SW_SHOWNORMAL);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
OpenWith(Opendialog1.FileName);
end;
Delphi - .....................................
neoturk: ...Show the 'open with'-dialog ?...
{
This code displays the application/file "Open With" dialog
Passing the full file path and name as a parameter will cause the
dialog to display the line "Click the program you want to use to open
the file 'filename'".
}
uses
ShellApi;
procedure OpenWith(FileName: string);
begin
ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'),
PChar('shell32.dll,OpenAs_RunDLL ' + FileName), nil, SW_SHOWNORMAL);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
OpenWith(Opendialog1.FileName);
end;
Delphi - .....................................
neoturk: ...Display the file properties dialog ?...
{ This code shows the standard file properties dialog like in Windows Explorer }
uses
shellapi;
// Thanks to Peter Below (TeamB) for this code
procedure PropertiesDialog(FileName: string);
var
sei: TShellExecuteInfo;
begin
FillChar(sei, SizeOf(sei), 0);
sei.cbSize := SizeOf(sei);
sei.lpFile := PChar(FileName);
sei.lpVerb := 'properties';
sei.fMask := SEE_MASK_INVOKEIDLIST;
ShellExecuteEx(@sei);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
PropertiesDialog(Opendialog1.FileName);
end;
Delphi - .....................................
neoturk: ...Display the file properties dialog ?...
{ This code shows the standard file properties dialog like in Windows Explorer }
uses
shellapi;
// Thanks to Peter Below (TeamB) for this code
procedure PropertiesDialog(FileName: string);
var
sei: TShellExecuteInfo;
begin
FillChar(sei, SizeOf(sei), 0);
sei.cbSize := SizeOf(sei);
sei.lpFile := PChar(FileName);
sei.lpVerb := 'properties';
sei.fMask := SEE_MASK_INVOKEIDLIST;
ShellExecuteEx(@sei);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
PropertiesDialog(Opendialog1.FileName);
end;
Delphi - .....................................
neoturk: ...Find the size of a file ?...
function Get_File_Size1(sFileToExamine: string; bInKBytes: Boolean): string;
{
for some reason both methods of finding file size return
a filesize that is slightly larger than what Windows File
Explorer reports
}
var
FileHandle: THandle;
FileSize: LongWord;
d1: Double;
i1: Int64;
begin
//a- Get file size
FileHandle := CreateFile(PChar(sFileToExamine),
GENERIC_READ,
0, {exclusive}
nil, {security}
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
FileSize := GetFileSize(FileHandle, nil);
Result := IntToStr(FileSize);
CloseHandle(FileHandle);
//a- optionally report back in Kbytes
if bInKbytes = True then
begin
if Length(Result) > 3 then
begin
Insert('.', Result, Length(Result) - 2);
d1 := StrToFloat(Result);
Result := IntToStr(round(d1)) + 'KB';
end
else
Result := '1KB';
end;
end;
{******************************************************************************
Thanks to Advanced Delphi Systems here's another method which works just as
well returning the same results
*******************************************************************************}
function Get_File_Size2(sFileToExamine: string; bInKBytes: Boolean): string;
var
SearchRec: TSearchRec;
sgPath: string;
inRetval, I1: Integer;
begin
sgPath := ExpandFileName(sFileToExamine);
try
inRetval := FindFirst(ExpandFileName(sFileToExamine), faAnyFile, SearchRec);
if inRetval = 0 then
I1 := SearchRec.Size
else
I1 := -1;
finally
SysUtils.FindClose(SearchRec);
end;
Result := IntToStr(I1);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
label1.Caption := Get_File_Size(Opendialog1.FileName, True);
end;
{*******************************************************************************}
function Get_File_Size3(const FileName: string): TULargeInteger;
// by nico
var
Find: THandle;
Data: TWin32FindData;
begin
Result.QuadPart := -1;
Find := FindFirstFile(PChar(FileName), Data);
if (Find <> INVALID_HANDLE_VALUE) then
begin
Result.LowPart := Data.nFileSizeLow;
Result.HighPart := Data.nFileSizeHigh;
Windows.FindClose(Find);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if (OpenDialog1.Execute) then
ShowMessage(IntToStr(Get_File_Size3(OpenDialog1.FileName).QuadPart));
end;
{*******************************************************************************}
function Get_File_Size4(const S: string): Int64;
var
FD: TWin32FindData;
FH: THandle;
begin
FH := FindFirstFile(PChar(S), FD);
if FH = INVALID_HANDLE_VALUE then Result := 0
else
try
Result := FD.nFileSizeHigh;
Result := Result shl 32;
Result := Result + FD.nFileSizeLow;
finally
CloseHandle(FH);
end;
end;
Delphi - .....................................
neoturk: ...Find the size of a file ?...
function Get_File_Size1(sFileToExamine: string; bInKBytes: Boolean): string;
{
for some reason both methods of finding file size return
a filesize that is slightly larger than what Windows File
Explorer reports
}
var
FileHandle: THandle;
FileSize: LongWord;
d1: Double;
i1: Int64;
begin
//a- Get file size
FileHandle := CreateFile(PChar(sFileToExamine),
GENERIC_READ,
0, {exclusive}
nil, {security}
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
FileSize := GetFileSize(FileHandle, nil);
Result := IntToStr(FileSize);
CloseHandle(FileHandle);
//a- optionally report back in Kbytes
if bInKbytes = True then
begin
if Length(Result) > 3 then
begin
Insert('.', Result, Length(Result) - 2);
d1 := StrToFloat(Result);
Result := IntToStr(round(d1)) + 'KB';
end
else
Result := '1KB';
end;
end;
{******************************************************************************
Thanks to Advanced Delphi Systems here's another method which works just as
well returning the same results
*******************************************************************************}
function Get_File_Size2(sFileToExamine: string; bInKBytes: Boolean): string;
var
SearchRec: TSearchRec;
sgPath: string;
inRetval, I1: Integer;
begin
sgPath := ExpandFileName(sFileToExamine);
try
inRetval := FindFirst(ExpandFileName(sFileToExamine), faAnyFile, SearchRec);
if inRetval = 0 then
I1 := SearchRec.Size
else
I1 := -1;
finally
SysUtils.FindClose(SearchRec);
end;
Result := IntToStr(I1);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
label1.Caption := Get_File_Size(Opendialog1.FileName, True);
end;
{*******************************************************************************}
function Get_File_Size3(const FileName: string): TULargeInteger;
// by nico
var
Find: THandle;
Data: TWin32FindData;
begin
Result.QuadPart := -1;
Find := FindFirstFile(PChar(FileName), Data);
if (Find <> INVALID_HANDLE_VALUE) then
begin
Result.LowPart := Data.nFileSizeLow;
Result.HighPart := Data.nFileSizeHigh;
Windows.FindClose(Find);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if (OpenDialog1.Execute) then
ShowMessage(IntToStr(Get_File_Size3(OpenDialog1.FileName).QuadPart));
end;
{*******************************************************************************}
function Get_File_Size4(const S: string): Int64;
var
FD: TWin32FindData;
FH: THandle;
begin
FH := FindFirstFile(PChar(S), FD);
if FH = INVALID_HANDLE_VALUE then Result := 0
else
try
Result := FD.nFileSizeHigh;
Result := Result shl 32;
Result := Result + FD.nFileSizeLow;
finally
CloseHandle(FH);
end;
end;
Delphi - .....................................
neoturk: ...Use ini files [* ini] ?...
{
An INI file stores information in logical groupings, called “sections.”
Within each section, actual data values are stored in named keys.
[Section_Name]
Key_Name1=Value1
Key_Name2=Value2
}
uses
IniFiles;
// Write values to a INI file
procedure TForm1.Button1Click(Sender: TObject);
var
ini: TIniFile;
begin
// Create INI Object and open or create file test.ini
ini := TIniFile.Create('c:MyIni.ini');
try
// Write a string value to the INI file.
ini.WriteString('Section_Name', 'Key_Name', 'String Value');
// Write a integer value to the INI file.
ini.WriteInteger('Section_Name', 'Key_Name', 2002);
// Write a boolean value to the INI file.
ini.WriteBool('Section_Name', 'Key_Name', True);
finally
ini.Free;
end;
end;
// Read values from an INI file
procedure TForm1.Button2Click(Sender: TObject);
var
ini: TIniFile;
res: string;
begin
// Create INI Object and open or create file test.ini
ini := TIniFile.Create('c:MyIni.ini');
try
res := ini.ReadString('Section_Name', 'Key_Name', 'default value');
MessageDlg('Value of Section: ' + res, mtInformation, [mbOK], 0);
finally
ini.Free;
end;
end;
// Read all sections
procedure TForm1.Button3Click(Sender: TObject);
var
ini: TIniFile;
begin
ListBox1.Clear;
ini := TIniFile.Create('MyIni.ini');
try
ini.ReadSections(listBox1.Items);
finally
ini.Free;
end;
end;
// Read a section
procedure TForm1.Button4Click(Sender: TObject);
var
ini: TIniFile;
begin
ini: = TIniFile.Create('WIN.INI');
try
ini.ReadSection('Desktop', ListBox1.Items);
finally
ini.Free;
end;
end;
// Read section values
procedure TForm1.Button5Click(Sender: TObject);
var
ini: TIniFile;
begin
ini := TIniFile.Create('WIN.INI');
try
ini.ReadSectionValues('Desktop', ListBox1.Items);
finally
ini.Free;
end;
end;
// Erase a section
procedure TForm1.Button6Click(Sender: TObject);
var
ini: TIniFile;
begin
ini := TIniFile.Create('MyIni.ini');
try
ini.EraseSection('My_Section');
finally
ini.Free;
end;
end;
Delphi - .....................................
neoturk: ...Use ini files [* ini] ?...
{
An INI file stores information in logical groupings, called “sections.”
Within each section, actual data values are stored in named keys.
[Section_Name]
Key_Name1=Value1
Key_Name2=Value2
}
uses
IniFiles;
// Write values to a INI file
procedure TForm1.Button1Click(Sender: TObject);
var
ini: TIniFile;
begin
// Create INI Object and open or create file test.ini
ini := TIniFile.Create('c:MyIni.ini');
try
// Write a string value to the INI file.
ini.WriteString('Section_Name', 'Key_Name', 'String Value');
// Write a integer value to the INI file.
ini.WriteInteger('Section_Name', 'Key_Name', 2002);
// Write a boolean value to the INI file.
ini.WriteBool('Section_Name', 'Key_Name', True);
finally
ini.Free;
end;
end;
// Read values from an INI file
procedure TForm1.Button2Click(Sender: TObject);
var
ini: TIniFile;
res: string;
begin
// Create INI Object and open or create file test.ini
ini := TIniFile.Create('c:MyIni.ini');
try
res := ini.ReadString('Section_Name', 'Key_Name', 'default value');
MessageDlg('Value of Section: ' + res, mtInformation, [mbOK], 0);
finally
ini.Free;
end;
end;
// Read all sections
procedure TForm1.Button3Click(Sender: TObject);
var
ini: TIniFile;
begin
ListBox1.Clear;
ini := TIniFile.Create('MyIni.ini');
try
ini.ReadSections(listBox1.Items);
finally
ini.Free;
end;
end;
// Read a section
procedure TForm1.Button4Click(Sender: TObject);
var
ini: TIniFile;
begin
ini: = TIniFile.Create('WIN.INI');
try
ini.ReadSection('Desktop', ListBox1.Items);
finally
ini.Free;
end;
end;
// Read section values
procedure TForm1.Button5Click(Sender: TObject);
var
ini: TIniFile;
begin
ini := TIniFile.Create('WIN.INI');
try
ini.ReadSectionValues('Desktop', ListBox1.Items);
finally
ini.Free;
end;
end;
// Erase a section
procedure TForm1.Button6Click(Sender: TObject);
var
ini: TIniFile;
begin
ini := TIniFile.Create('MyIni.ini');
try
ini.EraseSection('My_Section');
finally
ini.Free;
end;
end;
Delphi - .....................................
neoturk: ...Search for files recursively ?...
procedure GetAllFiles(mask: string);
var
search: TSearchRec;
directory: string;
begin
directory := ExtractFilePath(mask);
// find all files
if FindFirst(mask, $23, search) = 0 then
begin
repeat
// add the files to the listbox
Form1.ListBox1.Items.Add(directory + search.Name);
Inc(Count);
until FindNext(search) <> 0;
end;
// Subdirectories/ Unterverzeichnisse
if FindFirst(directory + '*.*', faDirectory, search) = 0 then
begin
repeat
if ((search.Attr and faDirectory) = faDirectory) and (search.Name[1] <> '.') then
GetAllFiles(directory + search.Name + '' + ExtractFileName(mask));
until FindNext(search) <> 0;
FindClose(search);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
directory: string;
mask: string;
begin
Count := 0;
Listbox1.Items.Clear;
directory := 'C:temp';
mask := '*.*';
Screen.Cursor := crHourGlass;
try
GetAllFiles(directory + mask);
finally
Screen.Cursor := crDefault;
end;
ShowMessage(IntToStr(Count) + ' Files found');
end;
{**************************************}
{ Code from P. Below: }
// recursively scanning all drives
{ excerpt from form declaration, form has a listbox1 for the
results, a label1 for progress, a button2 to start the scan,
an edit1 to get the search mask from, a button3 to stop
the scan. }
private
{ Private declarations }
FScanAborted: Boolean;
public
{ Public declarations }
function ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
implementation
function TForm1.ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
function ScanDirectory(var path: string): Boolean;
var
SRec: TSearchRec;
pathlen: Integer;
res: Integer;
begin
label1.Caption := path;
pathlen := Length(path);
{ first pass, files }
res := FindFirst(path + filemask, faAnyfile, SRec);
if res = 0 then
try
while res = 0 do
begin
hitlist.Add(path + SRec.Name);
res := FindNext(SRec);
end;
finally
FindClose(SRec)
end;
Application.ProcessMessages;
Result := not (FScanAborted or Application.Terminated);
if not Result then Exit;
{second pass, directories}
res := FindFirst(path + '*.*', faDirectory, SRec);
if res = 0 then
try
while (res = 0) and Result do
begin
if ((Srec.Attr and faDirectory) = faDirectory) and
(Srec.Name <> '.') and
(Srec.Name <> '..') then
begin
path := path + SRec.Name + '';
Result := ScanDirectory(path);
SetLength(path, pathlen);
end;
res := FindNext(SRec);
end;
finally
FindClose(SRec)
end;
end;
begin
FScanAborted := False;
Screen.Cursor := crHourglass;
try
Result := ScanDirectory(root);
finally
Screen.Cursor := crDefault
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
ch: Char;
root: string;
begin
root := 'C:';
for ch := 'A' to 'Z' do
begin
root[1] := ch;
case GetDriveType(PChar(root)) of
DRIVE_FIXED, DRIVE_REMOTE:
if not ScanDrive(root, edit1.Text, listbox1.Items) then
Break;
end;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin // aborts scan
FScanAborted := True;
end;
Delphi - .....................................
neoturk: ...Search for files recursively ?...
procedure GetAllFiles(mask: string);
var
search: TSearchRec;
directory: string;
begin
directory := ExtractFilePath(mask);
// find all files
if FindFirst(mask, $23, search) = 0 then
begin
repeat
// add the files to the listbox
Form1.ListBox1.Items.Add(directory + search.Name);
Inc(Count);
until FindNext(search) <> 0;
end;
// Subdirectories/ Unterverzeichnisse
if FindFirst(directory + '*.*', faDirectory, search) = 0 then
begin
repeat
if ((search.Attr and faDirectory) = faDirectory) and (search.Name[1] <> '.') then
GetAllFiles(directory + search.Name + '' + ExtractFileName(mask));
until FindNext(search) <> 0;
FindClose(search);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
directory: string;
mask: string;
begin
Count := 0;
Listbox1.Items.Clear;
directory := 'C:temp';
mask := '*.*';
Screen.Cursor := crHourGlass;
try
GetAllFiles(directory + mask);
finally
Screen.Cursor := crDefault;
end;
ShowMessage(IntToStr(Count) + ' Files found');
end;
{**************************************}
{ Code from P. Below: }
// recursively scanning all drives
{ excerpt from form declaration, form has a listbox1 for the
results, a label1 for progress, a button2 to start the scan,
an edit1 to get the search mask from, a button3 to stop
the scan. }
private
{ Private declarations }
FScanAborted: Boolean;
public
{ Public declarations }
function ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
implementation
function TForm1.ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
function ScanDirectory(var path: string): Boolean;
var
SRec: TSearchRec;
pathlen: Integer;
res: Integer;
begin
label1.Caption := path;
pathlen := Length(path);
{ first pass, files }
res := FindFirst(path + filemask, faAnyfile, SRec);
if res = 0 then
try
while res = 0 do
begin
hitlist.Add(path + SRec.Name);
res := FindNext(SRec);
end;
finally
FindClose(SRec)
end;
Application.ProcessMessages;
Result := not (FScanAborted or Application.Terminated);
if not Result then Exit;
{second pass, directories}
res := FindFirst(path + '*.*', faDirectory, SRec);
if res = 0 then
try
while (res = 0) and Result do
begin
if ((Srec.Attr and faDirectory) = faDirectory) and
(Srec.Name <> '.') and
(Srec.Name <> '..') then
begin
path := path + SRec.Name + '';
Result := ScanDirectory(path);
SetLength(path, pathlen);
end;
res := FindNext(SRec);
end;
finally
FindClose(SRec)
end;
end;
begin
FScanAborted := False;
Screen.Cursor := crHourglass;
try
Result := ScanDirectory(root);
finally
Screen.Cursor := crDefault
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
ch: Char;
root: string;
begin
root := 'C:';
for ch := 'A' to 'Z' do
begin
root[1] := ch;
case GetDriveType(PChar(root)) of
DRIVE_FIXED, DRIVE_REMOTE:
if not ScanDrive(root, edit1.Text, listbox1.Items) then
Break;
end;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin // aborts scan
FScanAborted := True;
end;
Delphi - .....................................
neoturk: ...Copy - move - delete whole directory ?...
uses
ShellApi;
function CopyDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_COPY;
fFlags := FOF_FILESONLY;
pFrom := PChar(fromDir + #0);
pTo := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;
function MoveDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_MOVE;
fFlags := FOF_FILESONLY;
pFrom := PChar(fromDir + #0);
pTo := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;
function DelDir(dir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_DELETE;
fFlags := FOF_SILENT or FOF_NOCONFIRMATION;
pFrom := PChar(dir + #0);
end;
Result := (0 = ShFileOperation(fos));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if cCopyDir('d:download', 'e:') = True then
ShowMessage('Directory copied.');
end;
Delphi - .....................................
neoturk: ...Copy - move - delete whole directory ?...
uses
ShellApi;
function CopyDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_COPY;
fFlags := FOF_FILESONLY;
pFrom := PChar(fromDir + #0);
pTo := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;
function MoveDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_MOVE;
fFlags := FOF_FILESONLY;
pFrom := PChar(fromDir + #0);
pTo := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;
function DelDir(dir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_DELETE;
fFlags := FOF_SILENT or FOF_NOCONFIRMATION;
pFrom := PChar(dir + #0);
end;
Result := (0 = ShFileOperation(fos));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if cCopyDir('d:download', 'e:') = True then
ShowMessage('Directory copied.');
end;
Delphi - .....................................
neoturk: ...Extract icons from a file ?...
uses
shellApi;
{...}
procedure TForm1.Button1Click(Sender: TObject);
const
ExtrFileName = 'C:WINNTsystem32moricons.dll';
var
icon: TIcon;
NumberOfIcons, i: Integer;
begin
icon := TIcon.Create;
try
// Get the number of Icons
NumberOfIcons := ExtractIcon(Handle, PChar(ExtrFileName), UINT(-1));
ShowMessage(Format('%d Icons', [NumberOfIcons]));
// Extract the first 5 icons
for i := 1 to 5 do
begin
// Extract an icon
icon.Handle := ExtractIcon(Handle, PChar(ExtrFileName), i);
// Draw the icon on your form
DrawIcon(Form1.Canvas.Handle, 10, i * 40, icon.Handle);
end;
finally
icon.Free;
end;
end;
// Note: If you are not using Delphi 4 you can remove the UINT.
Delphi - .....................................
neoturk: ...Extract icons from a file ?...
uses
shellApi;
{...}
procedure TForm1.Button1Click(Sender: TObject);
const
ExtrFileName = 'C:WINNTsystem32moricons.dll';
var
icon: TIcon;
NumberOfIcons, i: Integer;
begin
icon := TIcon.Create;
try
// Get the number of Icons
NumberOfIcons := ExtractIcon(Handle, PChar(ExtrFileName), UINT(-1));
ShowMessage(Format('%d Icons', [NumberOfIcons]));
// Extract the first 5 icons
for i := 1 to 5 do
begin
// Extract an icon
icon.Handle := ExtractIcon(Handle, PChar(ExtrFileName), i);
// Draw the icon on your form
DrawIcon(Form1.Canvas.Handle, 10, i * 40, icon.Handle);
end;
finally
icon.Free;
end;
end;
// Note: If you are not using Delphi 4 you can remove the UINT.
Delphi - .....................................
neoturk: ...Get directory size ?..
function GetDirSize(dir: string; subdir: Boolean): Longint;
var
rec: TSearchRec;
found: Integer;
begin
Result := 0;
if dir[Length(dir)] <> '' then dir := dir + '';
found := FindFirst(dir + '*.*', faAnyFile, rec);
while found = 0 do
begin
Inc(Result, rec.Size);
if (rec.Attr and faDirectory > 0) and (rec.Name[1] <> '.') and (subdir = True) then
Inc(Result, GetDirSize(dir + rec.Name, True));
found := FindNext(rec);
end;
FindClose(rec);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := FloatToStr(GetDirSize('e:download', False) / Sqr(1024)) + ' MBytes';
label2.Caption := FloatToStr(GetDirSize('e:download', True) / Sqr(1024)) + ' MBytes';
end;
Delphi - .....................................
neoturk: ...Get directory size ?..
function GetDirSize(dir: string; subdir: Boolean): Longint;
var
rec: TSearchRec;
found: Integer;
begin
Result := 0;
if dir[Length(dir)] <> '' then dir := dir + '';
found := FindFirst(dir + '*.*', faAnyFile, rec);
while found = 0 do
begin
Inc(Result, rec.Size);
if (rec.Attr and faDirectory > 0) and (rec.Name[1] <> '.') and (subdir = True) then
Inc(Result, GetDirSize(dir + rec.Name, True));
found := FindNext(rec);
end;
FindClose(rec);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := FloatToStr(GetDirSize('e:download', False) / Sqr(1024)) + ' MBytes';
label2.Caption := FloatToStr(GetDirSize('e:download', True) / Sqr(1024)) + ' MBytes';
end;
Delphi - .....................................
neoturk: ...Get a file's date ?...
function GetFileDateTime(const FileName: TFileName): TDateTime;
var
FStruct: TOFSTRUCT;
wndFile: Integer;
begin
wndFile := OpenFile(PChar(FileName), FStruct, OF_SHARE_DENY_NONE);
Result := FileDateToDateTime(FileGetDate(wndFile));
CloseHandle(wndFile);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
label1.Caption := DateTimeToStr(GetFileDateTime(Opendialog1.FileName));
end;
Delphi - .....................................
neoturk: ...Get a file's date ?...
function GetFileDateTime(const FileName: TFileName): TDateTime;
var
FStruct: TOFSTRUCT;
wndFile: Integer;
begin
wndFile := OpenFile(PChar(FileName), FStruct, OF_SHARE_DENY_NONE);
Result := FileDateToDateTime(FileGetDate(wndFile));
CloseHandle(wndFile);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
label1.Caption := DateTimeToStr(GetFileDateTime(Opendialog1.FileName));
end;
Delphi - .....................................
neoturk: ...Get your program's directory ?...
{
To get your program's directory:
Das eigene Programm Verzeichnis/(den Anwendungspfad) ermitteln:
}
procedure TForm1.Button1Click(Sender: TObject);
var
sExePath: string;
begin
sExePath := ExtractFilePath(Application.ExeName)
ShowMessage(sExePath);
end;
{
To get your program's Exe-Name:
Und den Exe-Name:
}
procedure TForm1.Button2Click(Sender: TObject);
var
sExeName: string;
begin
sExeName := ExtractFileName(Application.ExeName);
ShowMessage(sExeName);
end;
{
Instead of Application.ExeName you can also use Paramstr(0)
Anstatt Application.ExeName kann man auch Paramstr(0) einsetzen
}
{
If you are working on a DLL and are interested in the filename of the
DLL rather than the filename of the application, then you can use this function:
}
function GetModuleName: string;
var
szFileName: array[0..MAX_PATH] of Char;
begin
FillChar(szFileName, SizeOf(szFileName), #0);
GetModuleFileName(hInstance, szFileName, MAX_PATH);
Result := szFileName;
end;
Delphi - .....................................
neoturk: ...Get your program's directory ?...
{
To get your program's directory:
Das eigene Programm Verzeichnis/(den Anwendungspfad) ermitteln:
}
procedure TForm1.Button1Click(Sender: TObject);
var
sExePath: string;
begin
sExePath := ExtractFilePath(Application.ExeName)
ShowMessage(sExePath);
end;
{
To get your program's Exe-Name:
Und den Exe-Name:
}
procedure TForm1.Button2Click(Sender: TObject);
var
sExeName: string;
begin
sExeName := ExtractFileName(Application.ExeName);
ShowMessage(sExeName);
end;
{
Instead of Application.ExeName you can also use Paramstr(0)
Anstatt Application.ExeName kann man auch Paramstr(0) einsetzen
}
{
If you are working on a DLL and are interested in the filename of the
DLL rather than the filename of the application, then you can use this function:
}
function GetModuleName: string;
var
szFileName: array[0..MAX_PATH] of Char;
begin
FillChar(szFileName, SizeOf(szFileName), #0);
GetModuleFileName(hInstance, szFileName, MAX_PATH);
Result := szFileName;
end;
Delphi - .....................................
neoturk: ...Get-set the current directory ?...
// GetCurrentDir returns the fully qualified name of the current directory.
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetCurrentDir;
end;
// The SetCurrentDir function sets the current directory:
procedure TForm1.Button1Click(Sender: TObject);
begin
SetCurrentDir('c:windows');
end;
Delphi - .....................................
neoturk: ...Get-set the current directory ?...
// GetCurrentDir returns the fully qualified name of the current directory.
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetCurrentDir;
end;
// The SetCurrentDir function sets the current directory:
procedure TForm1.Button1Click(Sender: TObject);
begin
SetCurrentDir('c:windows');
end;
Delphi - .....................................
neoturk: ...Define binary exe type ?...
{1.}
function GetEXEType(FileName: string): string;
var
BinaryType: DWORD;
begin
if GetBinaryType(PChar(FileName), Binarytype) then
case BinaryType of
SCS_32BIT_BINARY: Result := 'Win32 executable';
SCS_DOS_BINARY: Result := 'DOS executable';
SCS_WOW_BINARY: Result := 'Win16 executable';
SCS_PIF_BINARY: Result := 'PIF file';
SCS_POSIX_BINARY: Result := 'POSIX executable';
SCS_OS216_BINARY: Result := 'OS/2 16 bit executable'
else
Result := 'unknown executable'
end
else
Result := 'File is not an executable';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetEXEType('c:windowsnotepad.exe');
end;
{
Windows NT/2000: Requires Windows NT 3.5 or later.
Windows 95/98: Unsupported.
}
{********************************************************************}
{2.}
type
TExeType = (etUnknown, etDOS, etWinNE {16-bit}, etWinPE {32-bit});
function GetExeType(const FileName: string): TExeType;
{ func to return the type of executable or dll (DOS, 16-bit, 32-bit). }
(**************************************************************
Usage:
with OpenDialog1 do
if Execute then
begin
Label1.Caption := FileName;
Label2.Caption := ExeStrings[GetExetype(FileName)];
end;
- or -
case GetExeType(OpenDialog1.FileName) of
etUnknown: Label3.Caption := 'Unknown file type';
etDOS : Label3.Caption := 'DOS executable';
etWinNE : {16-bit} Label3.Caption := 'Windows 16-bit executable';
etWinPE : {32-bit} Label3.Caption := 'Windows 32-bit executable';
end;
***************************************************************)
var
Signature,
WinHdrOffset: Word;
fexe: TFileStream;
begin
Result := etUnknown;
try
fexe := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
try
fexe.ReadBuffer(Signature, SizeOf(Signature));
if Signature = $5A4D { 'MZ' } then
begin
Result := etDOS;
fexe.Seek($18, soFromBeginning);
fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
if WinHdrOffset >= $40 then
begin
fexe.Seek($3C, soFromBeginning);
fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
fexe.Seek(WinHdrOffset, soFrombeginning);
fexe.ReadBuffer(Signature, SizeOf(Signature));
if Signature = $454E { 'NE' } then
Result := etWinNE
else
if Signature = $4550 { 'PE' } then
Result := etWinPE;
end;
end;
finally
fexe.Free;
end;
except
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
case GetExeType(OpenDialog1.FileName) of
etUnknown: Label_ExeType.Caption := 'Unknown file type';
etDOS : Label_ExeType.Caption := 'DOS executable';
etWinNE : Label_ExeType.Caption := 'Windows 16-bit executable';
etWinPE : Label_ExeType.Caption := 'Windows 32-bit executable';
end;
end;
Delphi - .....................................
neoturk: ...Define binary exe type ?...
{1.}
function GetEXEType(FileName: string): string;
var
BinaryType: DWORD;
begin
if GetBinaryType(PChar(FileName), Binarytype) then
case BinaryType of
SCS_32BIT_BINARY: Result := 'Win32 executable';
SCS_DOS_BINARY: Result := 'DOS executable';
SCS_WOW_BINARY: Result := 'Win16 executable';
SCS_PIF_BINARY: Result := 'PIF file';
SCS_POSIX_BINARY: Result := 'POSIX executable';
SCS_OS216_BINARY: Result := 'OS/2 16 bit executable'
else
Result := 'unknown executable'
end
else
Result := 'File is not an executable';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetEXEType('c:windowsnotepad.exe');
end;
{
Windows NT/2000: Requires Windows NT 3.5 or later.
Windows 95/98: Unsupported.
}
{********************************************************************}
{2.}
type
TExeType = (etUnknown, etDOS, etWinNE {16-bit}, etWinPE {32-bit});
function GetExeType(const FileName: string): TExeType;
{ func to return the type of executable or dll (DOS, 16-bit, 32-bit). }
(**************************************************************
Usage:
with OpenDialog1 do
if Execute then
begin
Label1.Caption := FileName;
Label2.Caption := ExeStrings[GetExetype(FileName)];
end;
- or -
case GetExeType(OpenDialog1.FileName) of
etUnknown: Label3.Caption := 'Unknown file type';
etDOS : Label3.Caption := 'DOS executable';
etWinNE : {16-bit} Label3.Caption := 'Windows 16-bit executable';
etWinPE : {32-bit} Label3.Caption := 'Windows 32-bit executable';
end;
***************************************************************)
var
Signature,
WinHdrOffset: Word;
fexe: TFileStream;
begin
Result := etUnknown;
try
fexe := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
try
fexe.ReadBuffer(Signature, SizeOf(Signature));
if Signature = $5A4D { 'MZ' } then
begin
Result := etDOS;
fexe.Seek($18, soFromBeginning);
fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
if WinHdrOffset >= $40 then
begin
fexe.Seek($3C, soFromBeginning);
fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
fexe.Seek(WinHdrOffset, soFrombeginning);
fexe.ReadBuffer(Signature, SizeOf(Signature));
if Signature = $454E { 'NE' } then
Result := etWinNE
else
if Signature = $4550 { 'PE' } then
Result := etWinPE;
end;
end;
finally
fexe.Free;
end;
except
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
case GetExeType(OpenDialog1.FileName) of
etUnknown: Label_ExeType.Caption := 'Unknown file type';
etDOS : Label_ExeType.Caption := 'DOS executable';
etWinNE : Label_ExeType.Caption := 'Windows 16-bit executable';
etWinPE : Label_ExeType.Caption := 'Windows 32-bit executable';
end;
end;
Delphi - .....................................
neoturk: ...Execute another program ?...
uses
ShellApi;
{ Start notepad }
ShellExecute(Handle, 'open', 'notepad.exe', '', nil, SW_SHOW);
WinExec('C:Windowsnotepad.exe', SW_SHOW);
{ Start notepad and load a file }
ShellExecute(Handle, 'open', 'notepad', 'c:MyFile.txt', nil, SW_SHOW);
{ Open a txt file }
ShellExecute(Handle, 'open', 'c:Readme.txt', nil, nil, SW_SHOW);
{ Calling "Dir" from the DOS-Prompt and redirect the output to a file }
{1. With Winexec }
procedure ExecuteShellCommand(cmdline: string; hidden: Boolean);
const
flags: array [Boolean] of Integer = (SW_SHOWNORMAL, SW_HIDE);
var
cmdbuffer: array [0..MAX_PATH] of Char;
begin
GetEnvironmentVariable('COMSPEC', cmdBUffer, SizeOf(cmdBuffer));
StrCat(cmdbuffer, ' /C ');
StrPCopy(StrEnd(cmdbuffer), cmdline);
WinExec(cmdbuffer, flags[hidden]);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ExecuteShellCommand('dir C: > c:tempdirlist.txt', True);
end;
{2. With Shellexecute }
procedure ExecuteShellCommand(cmdline: string; hidden: Boolean);
const
flags: array[Boolean] of Integer = (SW_SHOWNORMAL, SW_HIDE);
var
cmdbuffer: array[0..MAX_PATH] of Char;
begin
GetEnvironmentVariable('COMSPEC', cmdBUffer, SizeOf(cmdBuffer));
ShellExecute(0,'open',cmdbuffer, PChar('/c' + cmdline), nil, flags[hidden]);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ExecuteShellCommand('copy file1.txt file2.txt', True);
end;
Delphi - .....................................
neoturk: ...Execute another program ?...
uses
ShellApi;
{ Start notepad }
ShellExecute(Handle, 'open', 'notepad.exe', '', nil, SW_SHOW);
WinExec('C:Windowsnotepad.exe', SW_SHOW);
{ Start notepad and load a file }
ShellExecute(Handle, 'open', 'notepad', 'c:MyFile.txt', nil, SW_SHOW);
{ Open a txt file }
ShellExecute(Handle, 'open', 'c:Readme.txt', nil, nil, SW_SHOW);
{ Calling "Dir" from the DOS-Prompt and redirect the output to a file }
{1. With Winexec }
procedure ExecuteShellCommand(cmdline: string; hidden: Boolean);
const
flags: array [Boolean] of Integer = (SW_SHOWNORMAL, SW_HIDE);
var
cmdbuffer: array [0..MAX_PATH] of Char;
begin
GetEnvironmentVariable('COMSPEC', cmdBUffer, SizeOf(cmdBuffer));
StrCat(cmdbuffer, ' /C ');
StrPCopy(StrEnd(cmdbuffer), cmdline);
WinExec(cmdbuffer, flags[hidden]);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ExecuteShellCommand('dir C: > c:tempdirlist.txt', True);
end;
{2. With Shellexecute }
procedure ExecuteShellCommand(cmdline: string; hidden: Boolean);
const
flags: array[Boolean] of Integer = (SW_SHOWNORMAL, SW_HIDE);
var
cmdbuffer: array[0..MAX_PATH] of Char;
begin
GetEnvironmentVariable('COMSPEC', cmdBUffer, SizeOf(cmdBuffer));
ShellExecute(0,'open',cmdbuffer, PChar('/c' + cmdline), nil, flags[hidden]);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ExecuteShellCommand('copy file1.txt file2.txt', True);
end;
Delphi - .....................................
neoturk: ...Check if a file has an ascii format ?...
function isAscii(NomeFile: string): Boolean;
const
SETT = 2048;
var
i: Integer;
F: file;
a: Boolean;
TotSize, IncSize, ReadSize: Integer;
c: array[0..Sett] of Byte;
begin
if FileExists(NomeFile) then
begin
{$I-}
AssignFile(F, NomeFile);
Reset(F, 1);
TotSize := FileSize(F);
IncSize := 0;
a := True;
while (IncSize < TotSize) and (a = True) do
begin
ReadSize := SETT;
if IncSize + ReadSize > TotSize then ReadSize := TotSize - IncSize;
IncSize := IncSize + ReadSize;
BlockRead(F, c, ReadSize);
// Iterate
for i := 0 to ReadSize - 1 do
if (c[i] < 32) and (not (c[i] in [9, 10, 13, 26])) then a := False;
end; { while }
CloseFile(F);
{$I+}
if IOResult <> 0 then Result := False
else
Result := a;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
if isAscii(OpenDialog1.FileName) then
ShowMessage('ASCII File');
end;
Delphi - .....................................
neoturk: ...Check if a file has an ascii format ?...
function isAscii(NomeFile: string): Boolean;
const
SETT = 2048;
var
i: Integer;
F: file;
a: Boolean;
TotSize, IncSize, ReadSize: Integer;
c: array[0..Sett] of Byte;
begin
if FileExists(NomeFile) then
begin
{$I-}
AssignFile(F, NomeFile);
Reset(F, 1);
TotSize := FileSize(F);
IncSize := 0;
a := True;
while (IncSize < TotSize) and (a = True) do
begin
ReadSize := SETT;
if IncSize + ReadSize > TotSize then ReadSize := TotSize - IncSize;
IncSize := IncSize + ReadSize;
BlockRead(F, c, ReadSize);
// Iterate
for i := 0 to ReadSize - 1 do
if (c[i] < 32) and (not (c[i] in [9, 10, 13, 26])) then a := False;
end; { while }
CloseFile(F);
{$I+}
if IOResult <> 0 then Result := False
else
Result := a;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
if isAscii(OpenDialog1.FileName) then
ShowMessage('ASCII File');
end;
Delphi - .....................................
neoturk: ...Display a long path as c: pathfile txt ?...
{
Set the label autosize property to false and set the property width
to the max. displayed length
}
uses
FileCtrl;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
label1.Caption := MinimizeName(Opendialog1.FileName,
label1.Canvas, label1.Width);
end;
Delphi - .....................................
neoturk: ...Display a long path as c: pathfile txt ?...
{
Set the label autosize property to false and set the property width
to the max. displayed length
}
uses
FileCtrl;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
label1.Caption := MinimizeName(Opendialog1.FileName,
label1.Canvas, label1.Width);
end;
Delphi - .....................................
neoturk: ...Search for text in textfiles ?...
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Edit1: TEdit;
SpeedButton1: TSpeedButton;
procedure SpeedButton1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
// Aus einem alten c't-Heft von C nach Delphi übersetzt
// Deklarationsteil
procedure Ts_init(P: PChar; m: Integer);
function Ts_Search(Text, p: PChar; m: Integer; Start: Longint): Longint;
// Globale Variablen
// *****************
var
shift: array[0..255] of Byte; // Shifttabelle für Turbosearch
Look_At: Integer; // Look_At-Position für Turbosearch
implementation
{$R *.DFM}
procedure Ts_init(P: PChar; m: Integer);
var
i: Integer;
begin
// *** Suchmuster analysieren ****
{1.} for i := 0 to 255 do shift[i] := m + 1;
{2.} for i := 0 to m - 1 do Shift[Ord(p[i])] := m - i;
Look_at := 0;
{3.} while (look_At < m - 1) do
begin
if (p[m - 1] = p[m - (look_at + 2)]) then Exit
else
Inc(Look_at, 1);
end;
// *** Beschreibung ****
// 1. Sprungtabelle Shift[0..255] wird mit der max. Sprungweite (Musterlänge+1)
// initialisiert.
// 2. Für jedes Zeichen im Muster wird seine Position (von hinten gezählt) in
// der Shift-Tabelle eingetragen.
// Für das Muster "Hans" würden folgende Shiftpositionen ermittelt werde:
// Für H = ASCII-Wert = 72d ,dass von hinten gezählt an der 4. Stelle ist,
// wird Shift[72] := 4 eingetragen.
// Für a = 97d = Shift[97] := 3;
// Für n = 110d = Shift[110] := 2;
// Für s = 115d = Shift[115] := 1;
// Da das Muster von Vorn nach Hinten durchsucht wird, sind doppelt auf-
// tretende Zeichen kein Problem. Die Shift-Werte werden überschrieben und
// mit der kleinsten Sprungweite automatisch aktualisiert.
// 3. Untersucht wo (position von hinten) das Letzte Zeichen im Muster
// nochmals vorkommt und Speichert diese in der Variable Look_AT.
// Die Maximale Srungweite beim Suchen kann also 2*Musterlänge sein wenn
// das letzte Zeichen nur einmal im Muster vorhanden ist.
end;
function Ts_Search(Text, p: PChar; m: Integer; Start: Longint): Longint;
var
I: Longint;
T: PChar;
begin
T := Text + Start; // Zeiger auf Startposition im Text setzen
Result := -1;
repeat
i := m - 1;
// Letztes Zeichen des Suchmusters im Text suchen.
while (t[i] <> p[i]) do t := t + shift[Ord(t[m])];
i := i - 1; // Vergleichszeiger auf vorletztes Zeichen setzen
if i < 0 then i := 0; // wenn nach nur einem Zeichen gesucht wird,
// kann i = -1 werden.
// restliche Zeichen des Musters vergleichen
while (t[i] = p[i]) do
begin
if i = 0 then Result := t - Text;
i := i - 1;
end;
// Muster nicht gefunden -> Sprung um max. 2*m
if Result = -1 then t := t + Look_AT + shift[Ord(t[m + look_at])];
until Result <> -1; // Repeat
end;
// Such-Procedure auslösen (hier beim drücken eines Speedbuttons auf FORM1)
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
tt: string;
L: Integer;
L2, sp, a: Longint;
F: file; // File-Alias
Size: Integer; // Textlänge
Buffer: PChar; // Text-Memory-Buffer
begin
tt := Edit1.Text; // Suchmuster
L := Length(TT); // Suchmusterlänge
ts_init(PChar(TT), L); // Sprungtabelle für Suchmuster initialisieren
try
AssignFile(F, 'test.txt');
Reset(F, 1); // File öffnen
Size := FileSize(F); // Filegrösse ermitteln
GetMem(Buffer, Size + L + 1); // Memory reservieren in der Grösse von
// TextFilelänge+Musterlänge+1
try
BlockRead(F, Buffer^, Size); // Filedaten in den Buffer füllen
StrCat(Buffer, PChar(TT)); // Suchmuster ans Ende des Textes anhängen
// damit der Suchalgorythmus keine Fileende-
// Kontrolle machen muss.
// Turbo-Search
SP := 0; // Startpunkt der Suche im Text
A := 0; // Anzahl-gefunden-Zähler
while SP < Size do
begin
L2 := Ts_Search(Buffer, PChar(TT), L, SP); // L = Musterlänge
// SP= Startposition im Text
SP := L2 + L; // StartPosition auf Letzte gefundene Position+Musterlänge
Inc(a); // Anzahl gefunden Zähler
end;
// Am Schluss nicht vergessen Buffer freigeben und Inputfile schliessen
finally
FreeMem(Buffer); // Memory freigeben.
end;
finally
CloseFile(F); // Datei schliessen.
end;
end;
end.
