Procedury plików i katalogów

1.   Sprawdzenie czy katalog jest pusty

Zwraca True jeżeli katalog jest pusty

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;

//Przykład:
procedure TForm1.Button1Click(Sender: TObject);
begin
if DirectoryIsEmpty('C:\test') then   Label1.Caption := 'pusty'
else   Label1.Caption := 'nie jest pusty';
end;

2. Wykonanie innego programu

uses ShellApi; a niżej sposoby:
//Uruchomienie programu notepad.exe
ShellExecute(Handle, 'open', 'notepad.exe', '', nil, SW_SHOW);
WinExec('C:\Windows\notepad.exe', SW_SHOW);

//Uruchomienie z otwarciem pliku:
ShellExecute(Handle, 'open', 'notepad', 'c:\MyFile.txt', nil, SW_SHOW);

//Otwarcie pliku:
ShellExecute(Handle, 'open', 'c:\Readme.txt', nil, nil, SW_SHOW);

{ Wywołanie katalogu i otwarcie pliku }
{1. za pomocą 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:\temp\dirlist.txt', True);
end;

{2. z pomocą 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;

3.   Zwraca ścieżkę i nazwę wykonywanego programu

Zwraca ścieżkę:
procedure TForm1.Button1Click(Sender: TObject);
var sExePath: string;
begin
sExePath := ExtractFilePath(Application.ExeName) ShowMessage(sExePath);
end;

// Zwraca nazwę pliku wykonywalnego:
procedure TForm1.Button2Click(Sender: TObject);
var sExeName: string;
begin
sExeName := ExtractFileName(Application.ExeName);   ShowMessage(sExeName);
end;

//Jeżeli potrzeba danych o bibliotece DLL to skorzystaj z tej funkcji:
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;

4.   Pokaż katalog w TTreeview

procedure TForm1.GetDirectories(Tree: TTreeView; Directory: string; Item: TTreeNode; IncludeFiles: Boolean);
var SearchRec: TSearchRec;   ItemTemp: TTreeNode;
begin
Tree.Items.BeginUpdate;
if Directory[Length(Directory)] < > '\' then Directory := Directory + '\';
if FindFirst(Directory + '*.*', faDirectory, SearchRec) = 0 then begin
repeat
if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] < > '.') then begin
if (SearchRec.Attr and faDirectory > 0) then
Item := Tree.Items.AddChild(Item, SearchRec.Name);
ItemTemp := Item.Parent;
GetDirectories(Tree, Directory + SearchRec.Name, Item, IncludeFiles);
Item := ItemTemp;
end   else if IncludeFiles then
if SearchRec.Name[1] < > '.' then   Tree.Items.AddChild(Item, SearchRec.Name);
until FindNext(SearchRec) < > 0;   FindClose(SearchRec);
end; Tree.Items.EndUpdate;
end;

procedure TForm1.Button1Click(Sender: TObject);
var Node: TTreeNode; Path: string; Dir: string;
begin
Dir := 'c:\temp';   Screen.Cursor := crHourGlass;   TreeView1.Items.BeginUpdate;
try   TreeView1.Items.Clear;   GetDirectories(TreeView1, Dir, nil, True);
finally   Screen.Cursor := crDefault;   TreeView1.Items.EndUpdate;
end;   end;

5.   Pokaż rozmiar katalogu

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;

6.   Okno wyboru katalogu

uses   Filectrl; {....}

procedure TForm1.Button1Click(Sender: TObject);
var   Dir: String;
begin
SelectDirectory('Wybór katalogu', '', Dir); ShowMessage(Dir);
end;

7.   Zmiana nazwy, niszczenie i przenoszenie katalogu, pliku

Tworzenie katalogu:   CreateDir('c:\path');
Usuwanie katalogu:   RemoveDir('c:\path') lub RmDir('c:\path')
Zmiana nazwy :   ChDir('c:\path')
Aktualny katalog :   GetCurrentDir
Jeżeli katalog istnieje :   if DirectoryExists('c:\path') then ...

//Podobne operacje na pliku:
Zmiana nazwy :   RenameFile('file1.txt', 'file2.xyz')
Niszczenie pliku :   DeleteFile('c:\text.txt')
Przemieszczenie od do :   MoveFile('C:\file1.txt','D:\file1.txt');
Kopiowanie pliku :   CopyFile(Pchar(File1),PChar(File2),bFailIfExists)
Zmiana rozszerzenia w nazwie pliku :   ChangeFileExt('test.txt', 'xls')
Czy plik istnieje :   if FileExists('c:\filename.tst') then ...

8. Zapis / dodanie tekstu do pliku

Dołączenie tekstu do pliku:
function AppendOrWriteTextToFile(FileName : TFilename; WriteText : string): boolean;
var f : Textfile;
begin
Result := False;   AssignFile(f, FileName);
try   if FileExists(FileName) = False then   Rewrite(f)
else  begin   Append(f);   end;
Writeln(f, WriteText);   Result := True;
finally   CloseFile(f);
end;   end;

// Przykład...
procedure TForm1.Close1Click(Sender : TObject);
var dir, log : string;
begin
dir := ExtractFilePath(Application.Exename);
log := 'Last Programm Termination: ' + DateTimeToStr(now);
AppendOrWriteTextToFile(dir + '\logfile.txt', log)
end;

9.   Kopiowanie pliku ze schowka do Streamu i odwrotnie

uses clipbrd;
kopiowanie streamu do schowka:
procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream);
var hMem: THandle; pMem: Pointer;
begin
Assert(Assigned(S));   S.Position := 0;
hMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size);
if hMem < > 0 then begin   pMem := GlobalLock(hMem);
if pMem < > nil then begin   try   S.Read(pMem^, S.Size);   S.Position := 0;
finally   GlobalUnlock(hMem);   end;   Clipboard.Open;
try   Clipboard.SetAsHandle(fmt, hMem);   finally   Clipboard.Close;   end;
end  { If }   else   begin   GlobalFree(hMem);   OutOfMemoryError;
end; end { If } else   OutOfMemoryError;
end;  

kopiowanie streamu ze schowka:
procedure CopyStreamFromClipboard(fmt: Cardinal; S: TStream);
var hMem: THandle; pMem: Pointer;
begin
Assert(Assigned(S));   hMem := Clipboard.GetAsHandle(fmt);
if hMem < > 0 then begin   pMem := GlobalLock(hMem);
if pMem < > nil then begin   try  S.Write(pMem^, GlobalSize(hMem));   S.Position := 0;
finally   GlobalUnlock(hMem);   end;   end  { If }
else   raise Exception.Create('CopyStreamFromClipboard: could not lock global handle ' + 'obtained from clipboard!');
end;  { If }
end;   { CopyStreamFromClipboard }

procedure SaveClipboardFormat(fmt: Word; writer: TWriter);
var fmtname: array[0..128] of Char; ms: TMemoryStream;
begin
Assert(Assigned(writer));
if 0 = GetClipboardFormatName(fmt, fmtname, SizeOf(fmtname)) then   fmtname[0] := #0;
ms := TMemoryStream.Create;  try   CopyStreamFromClipboard(fmt, ms);
if ms.Size > 0 then begin
writer.WriteInteger(fmt);   writer.WriteString(fmtname);   writer.WriteInteger(ms.Size);
writer.Write(ms.Memory^, ms.Size);  end;   { If } finally   ms.Free   end;  { Finally }
end; { SaveClipboardFormat }

procedure LoadClipboardFormat(reader: TReader);
var fmt: Integer; fmtname: string; Size: Integer; ms: TMemoryStream;
begin
Assert(Assigned(reader));   fmt := reader.ReadInteger;   fmtname := reader.ReadString;
Size := reader.ReadInteger;   ms := TMemoryStream.Create;
try   ms.Size := Size;   reader.Read(ms.memory^, Size);
if Length(fmtname) > 0 then fmt := RegisterCLipboardFormat(PChar(fmtname));
if fmt < > 0 then   CopyStreamToClipboard(fmt, ms);
finally   ms.Free;   end;   { Finally }
end;  { LoadClipboardFormat }

procedure SaveClipboard(S: TStream);
var writer: TWriter; i: Integer;
begin
Assert(Assigned(S));   writer := TWriter.Create(S, 4096);
try   Clipboard.Open;   try   writer.WriteListBegin;
for i := 0 to Clipboard.formatcount - 1 do
SaveClipboardFormat(Clipboard.Formats[i], writer);   writer.WriteListEnd; finally   Clipboard.Close;   end;   { Finally }   finally   writer.Free end;   { Finally }
end;  { SaveClipboard }

procedure LoadClipboard(S: TStream);
var reader: TReader;
begin
Assert(Assigned(S));   reader := TReader.Create(S, 4096);
try   Clipboard.Open;  try   clipboard.Clear;   reader.ReadListBegin;
while not reader.EndOfList do
LoadClipboardFormat(reader);   reader.ReadListEnd;
finally Clipboard.Close; end; { Finally }
finally reader.Free end; { Finally }
end; { LoadClipboard }

// Przykład:{ zapis schowka }
procedure TForm1.Button1Click(Sender: TObject);
var ms: TMemoryStream;
begin
ms := TMemoryStream.Create;   try SaveClipboard(ms);
ms.SaveToFile('c:\temp\ClipBrdSaved.dat');
finally ms.Free; end; { Finally }
end;

{ opróżnij schowek }
procedure TForm1.Button2Click(Sender: TObject);
begin
clipboard.Clear;
end;

{ aktualizuj schowek }
procedure TForm1.Button3Click(Sender: TObject);
var fs: TfileStream;
begin
fs := TFilestream.Create('c:\temp\ClipBrdSaved.dat',   fmopenread or fmsharedenynone);
try LoadClipboard(fs); finally fs.Free; end; { Finally }
end;

10.   Dzielenie i łączenie plików

Przykład dzieli plik na fragmenty określonego rozmiaru (SizeOfFiles) i zapisuje jako FileName.001, FileName.002, FileName.003 a pasek postępu (TProgressBar) pokazuje stan tej operacji.

//dzielenie pliku:
function SplitFile(FileName : TFileName; SizeofFiles : Integer; ProgressBar : TProgressBar) : Boolean;
var i : Word; fs, sStream: TFileStream; SplitFileName: String;
begin
ProgressBar.Position := 0; fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
for i := 1 to Trunc(fs.Size / SizeofFiles) + 1 do begin
SplitFileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
sStream := TFileStream.Create(SplitFileName, fmCreate or fmShareExclusive);
try
if fs.Size - fs.Position < SizeofFiles then
SizeofFiles := fs.Size - fs.Position; sStream.CopyFrom(fs, SizeofFiles);
ProgressBar.Position := Round((fs.Position / fs.Size) * 100);
finally sStream.Free;
end; end; finally fs.Free; end;
end;

// łączenie plików w 1 duży plik(CombinedFileName) - wskazujemy nazwę pierwszego z indeksem 001 (FileName):
function CombineFiles(FileName, CombinedFileName : TFileName) : Boolean;
var i: integer; fs, sStream: TFileStream; filenameOrg: String;
begin
i := 1;   fs := TFileStream.Create(CombinedFileName, fmCreate or fmShareExclusive);
try
  while FileExists(FileName) do begin
sStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
  fs.CopyFrom(sStream, 0);   finally   sStream.Free; end; Inc(i);
FileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
end;   finally   fs.Free;
end;   end;

// przykład:
procedure TForm1.Button1Click(Sender: TObject);
begin
SplitFile('C:\temp\FileToSplit.chm',1000000, ProgressBar1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
CombineFiles('C:\temp\FileToSplit.001','H:\temp\FileToSplit.chm');
end;

11.   Listowanie wszystkich podkatalogów w katalogu


procedure GetSubDirs(const sRootDir: string; slt: TStrings);
var srSearch: TSearchRec; sSearchPath: string; sltSub: TStrings; i: Integer;
begin
sltSub := TStringList.Create; slt.BeginUpdate;
try
sSearchPath := AddDirSeparator(sRootDir);
if FindFirst(sSearchPath + '*', faDirectory, srSearch) = 0 then
repeat
if ((srSearch.Attr and faDirectory) = faDirectory) and (srSearch.Name < > '.') and (srSearch.Name < > '..') then begin
slt.Add(sSearchPath + srSearch.Name);   sltSub.Add(sSearchPath + srSearch.Name);   end;
until (FindNext(srSearch) < > 0);   FindClose(srSearch);
for i := 0 to sltSub.Count - 1 do   GetSubDirs(sltSub.Strings[i], slt);
finally   slt.EndUpdate;   FreeAndNil(sltSub);
end;   end;

12. Jak wstawić dowolny program do pliku EXE?


Piszemy w notatniku potrzebne nam programy takie jak:   ARJ EXEFILE C:\UTIL\ARJ.EXE
i zapisujemy do pliku z rozszerzeniem .RC.
Przy pomocy kompilatora RC-plików Windowsa (Brcc32.exe) otrzymujemy plik .Res (tu test.res) i dalej w tekscie piszemy:

implementation

{$R *.DFM}
{$R test.res}   // to nasz RES-plik
procedure ExtractRes(ResType, ResName, ResNewName : String);
var Res : TResourceStream;
begin
Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType));
Res.SavetoFile(ResNewName); Res.Free;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
//Wstawia do programu ten plik ARJ.EXE
ExtractRes('EXEFILE', 'ARJ', 'ARJ.EXE');
end;

13. Kopiowanie metodą Turbo Pascala


type
tcallback=procedure (position,size:longint);   {dla indykacji procesu kopiowania}
procedure fastfilecopy(const infilename, outfilename: string; callback: tcallback);
const bufsize = 3*4*4096;   { 48kbytes daje wspaniały rezultat }
type
pbuffer = ^tbuffer;   tbuffer = array [1..bufsize] of byte;
var size : integer;   buffer : pbuffer;   infile, outfile : file;   sizedone,sizefile: longint;
begin
if (infilename < > outfilename) then begin
buffer := nil;   assignfile(infile, infilename); system.reset(infile, 1);
try
sizefile := filesize(infile);   assignfile(outfile, outfilename); system.rewrite(outfile, 1);
try
sizedone := 0;   new(buffer);
repeat
blockread(infile, buffer^, bufsize, size);   inc(sizedone, size);
callback(sizedone, sizefile);   blockwrite(outfile,buffer^, size)
until size < bufsize;
filesetdate(tfilerec(outfile).handle, filegetdate(tfilerec(infile).handle));
finally
if buffer < > nil then dispose(buffer);   system.close(outfile)
end; finally   system.close(infile);
end;   end else
raise einouterror.create('file cannot be copied into itself');
end;

14. Kopiowanie pliku metodą strumienia TFileStream

procedure filecopy(const sourcefilename, targetfilename: string);
var s,t : tfilestream;
begin
s := tfilestream.create(sourcefilename, fmopenread );
try
t := tfilestream.create(targetfilename, fmopenwrite or fmcreate);
try
t.copyfrom(s, s.size ) ;   filesetdate(t.handle, filegetdate(s.handle));
finally   t.free;   end;
finally   s.free;   end;
end;

15. Kopiowanie pliku metodą lzexpand

uses lzexpand;

procedure copyfile(fromfilename, tofilename : string);
var fromfile, tofile: file;
begin
assignfile(fromfile, fromfilename);   assignfile(tofile, tofilename);   reset(fromfile);
try
rewrite(tofile);
try
if lzcopy(tfilerec(fromfile).handle, tfilerec(tofile).handle) < 0 then
raise   exception.create('error using lzcopy')
finally   closefile(tofile);   end;
finally   closefile(fromfile);   end;
end;

16. Kopiowanie pliku metodą windows

uses shellapi; // !!! ważne

function windowscopyfile(fromfile, todir : string) : boolean;
var f : tshfileopstruct;
begin
f.wnd := 0;   f.wfunc := fo_copy;
fromfile:=fromfile+#0;   f.pfrom:=pchar(fromfile);
todir:=todir+#0;   f.pto:=pchar(todir);
f.fflags := fof_allowundo or fof_noconfirmation;
result:=shfileoperation(f) = 0;
end;

//przykład kopiowania
procedure tform1.button1click(sender: tobject);
begin
if not windowscopyfile('c:\util\arj.exe', getcurrentdir) then
showmessage('Kopiowanie przerwane');
end;

17. Odczyt zajmowanego przez katalog miejsca - w bajtach - inna wersja.

var dirbytes : integer;

function tfilebrowser.dirsize(dir:string):integer;
var searchrec : tsearchrec;   separator : string;
begin
if copy(dir,length(dir),1)='' then separator := ''
else
separator := '';
if findfirst(dir+separator+'*.*',faanyfile,searchrec) = 0 then begin
if fileexists(dir+separator+searchrec.name) then begin
dirbytes := dirbytes + searchrec.size;
{memo1.lines.add(dir+separator+searchrec.name);}
end else
if directoryexists(dir+separator+searchrec.name) then begin
if (searchrec.name < > '.') and (searchrec.name < > '..') then begin
dirsize(dir+separator+searchrec.name);
end; end;
while findnext(searchrec) = 0 do begin
if fileexists(dir+separator+searchrec.name) then begin
dirbytes := dirbytes + searchrec.size;
{memo1.lines.add(dir+separator+searchrec.name);}
end else
if directoryexists(dir+separator+searchrec.name) then begin
if (searchrec.name < > '.') and (searchrec.name < > '..') then begin
dirsize(dir+separator+searchrec.name);
end; end; end; end;
findclose(searchrec);
end;

18. Lista plików w TList i sortowanie według daty.


type
psrec=^tsearchrec;
function datecompare(item1, item2: pointer): integer;
begin
if psrec(item1)^.time > psrec(item2)^.time then result:=1
else
if psrec(item1)^.time=psrec(item2)^.time then result:=0
else
result:=-1;
end;

procedure tform1.button1click(sender: tobject);
var i:integer;   srlist:tlist;   sr:tsearchrec;   psr:psrec;
begin
srlist:=tlist.create;
if srlist.count > 1 then srlist.sort(datecompare);
for i:=0 to srlist.count-1 do
memo1.lines.add(psrec(srlist.items[i])^.name+' '+
datetimetostr(filedatetodatetime(psrec(srlist.items[i])^.time)));
srlist.free;
end;

19. Usuwanie katalogu wraz z jego zawartością.

function deletedir(dir : string) : boolean;
var found : integer;   searchrec : tsearchrec;
begin
result:=false;
if ioresult < > 0 then chdir(dir);
if ioresult < > 0 then
begin
showmessage('Nie mogę wejść do katalogu: '+dir);   exit;
end;
found := findfirst('*.*', faanyfile, searchrec);
while found = 0 do
begin
if (searchrec.name < > '.') and (searchrec.name < > '..') then
if (searchrec.attr and fadirectory) < > 0 then
begin
if not deletedir(searchrec.name) then exit;
end else
if not deletefile(searchrec.name) then
begin
showmessage('Nie mogę usunąć pliku: '+searchrec.name);   exit;
end;
found := findnext(searchrec);
end;
findclose(searchrec);   chdir('..');   rmdir(dir);   result:=ioresult=0;
end;

{ usuwanie katalogu z jego zawartością }
function deletedir(dir : string) : boolean;
var found : integer;   searchrec : tsearchrec;
begin
result:=false;
if ioresult < > 0 then chdir(dir);
if ioresult < > 0 then
begin
showmessage('Nie mogę wejść do katalogu: '+dir);   exit;
end;
found := findfirst('*.*', faanyfile, searchrec);
while found = 0 do
begin
if (searchrec.name < > '.') and (searchrec.name < > '..') then
if (searchrec.attr and fadirectory) < > 0 then
begin
if not deletedir(searchrec.name) then exit;
end else
if not deletefile(searchrec.name) then
begin
showmessage('Nie mogę usunąć katalogu: '+searchrec.name);   exit;
end;
found := findnext(searchrec);   end;   findclose(searchrec);   chdir('..');
rmdir(dir);   result:=ioresult=0;
end;

20. Kopiowanie dużych plików do schowka

Oto rozwiązanie, które będzie działać, nawet jeśli rozmiar pliku przekracza 64K:

function _hread(filehandle: word; bufptr: pointer;
bytecount: longint): longint; far;
external 'kernel' index 349;

procedure copyfiletoclipboard(const fname: string);
var   hmem, hfile: thandle;   size: longint;   p: pointer;
begin
hfile := fileopen(fname, fmopenread);
try
size := fileseek(hfile, 0, 2);   fileseek(hfile, 0, 0);
if size > 0 then
begin
hmem := globalalloc(ghnd, size);
if hmem < > 0 then
begin
p := globallock(hmem);
if p < > nil then
begin
_hread(hfile, p, size);   globalunlock(hmem);   clipboard.setashandle(cf_text, hmem);
end   else   globalfree(hmem);   end;
end;
finally   fileclose(hfile);   end;
end;

procedure tform1.speedbutton2click(sender: tobject);
var   fname: string[128];
begin
if opendialog1.execute then
begin
fname := opendialog1.filename;   copyfiletoclipboard(fname);
end;   end;

21. Praca z plikami INI - inaczej.


function readini(asection, astring: string): string;
var   sinifile: tinifile;   spath: string[60];
const   s = 'xyz';   { standardowa linia do wydania błędu odczytu }
begin
getdir(0, spath);   sinifile := tinifile.create(spath + 'name.ini');
result := sinifile.readstring(asection, astring, s);   { [section] string=value}
sinifile.free;
end;

procedure writeini(asection, astring, avalue: string);
var   sinifile: tinifile;   spath: string[60];
begin
getdir(0, spath);   sinifile := tinifile.create(spath + 'name.ini');
sinifile.writestring(asection, astring, avalue); { [section] string=value }
sinifile.free;
end;

{readsection - czyta wszystkie elementy tej sekcji.
taki znak wstawia przed kluczem "="
readsectionvalues - czyta wszystkie linie tej sekcji, tj. punkt=xyz }

22. Obliczenie liczby plików w katalogu.

uses   windows, { ... }

function filecount(const afolder: string): integer;
var   h: thandle;   data: twin32finddata;
begin
result := 0;
h := findfirstfile(pchar(afolder + '*.*'), data);
if h < > invalid_handle_value then
repeat
inc(result, ord(data.dwfileattributes and file_attribute_directory = 0));
until
not findnextfile(h, data);   windows.findclose(h);
end;

23. Kopiowanie katalogu z plikami.

unit filesop;

interface

uses forms, sysutils, shellapi, dialogs;

procedure copyfiles(const fromfolder: string; const tofolder: string);

implementation

procedure copyfiles(const fromfolder: string; const tofolder: string);
var   fo : tshfileopstruct;   buffer : array[0..4096] of char;   p : pchar;
begin
fillchar(buffer, sizeof(buffer), #0);   p := @buffer;
strecopy(p, pchar(fromfolder));   //kopiowany katalog
fillchar(fo, sizeof(fo), #0);
fo.wnd := application.handle;   fo.wfunc := fo_copy;   fo.pfrom := @buffer;
fo.pto := pchar(tofolder);   //tam będzie kopiowany katalog
fo.fflags := 0;
if ((shfileoperation(fo) < > 0) or (fo.fanyoperationsaborted < > false)) then
showmessage('Proces kopiowania pliku anulowano')
end;

end.

24. Skuteczne usuwanie pliku.

Usuwany normalnie plik ktoś inny może go odtworzyć. W tej procedurze plik jest przed zniszczeniem nadpisywany losową kombinacją znaków - odtworzyć można taką sieczkę.

procedure wipefile(filename: string);
var   buffer: array [0..4095] of byte;   max, n: longint;   i: integer;   fs: tfilestream;

procedure randomizebuffer;
var   i: integer;
begin
for i := low(buffer) to high(buffer) do   buffer[i] := random(256);   end;
begin
fs := tfilestream.create(filename, fmopenreadwrite or fmshareexclusive);
try
for i := 1 to 3 do begin
randomizebuffer;   max := fs.size;   fs.position := 0;
while max > 0 do begin
if max > sizeof(buffer) then   n := sizeof(buffer)
else
n := max;   fs.write(buffer, n);   max := max - n;
end;
flushfilebuffers(fs.handle);   end;
finally   fs.free;   end;   deletefile(filename);
end;

25. Okno dialogowe wyboru katalogów.

W module filectrl są dwie metody wyboru katalogu - oto jedna z nich:

uses shlobj

function browsefolderdialog(title: pchar): string;
var   titlename: string;   lpitemid: pitemidlist;   browseinfo: tbrowseinfo;
displayname: array[0..max_path] of char;   temppath: array[0..max_path] of char;
begin
fillchar(browseinfo, sizeof(tbrowseinfo), #0);
browseinfo.hwndowner := getdesktopwindow;   browseinfo.pszdisplayname := @displayname;
titlename := title;   browseinfo.lpsztitle := pchar(titlename);
browseinfo.ulflags := bif_returnonlyfsdirs;   lpitemid := shbrowseforfolder(browseinfo);
if lpitemid < > nil then begin
shgetpathfromidlist(lpitemid, temppath);   result := temppath;
globalfreeptr(lpitemid);
end;   end;

26. Wyszukiwanie plików w katalogach według zadanej maski.

parametr startfolder wskazuje wstępny katalog poszukiwań;
parametr mask określa maskę wyszukiwania (np. '*. pas "),
parametr list określa listę, w których będą rejestrowane wyniki wyszukiwania;
opcjonalny parametr scansubfolders wskazuje na obowiązkową potrzebę szukania w podkatalogach.

procedure findfiles(startfolder, mask: string; list: tstrings; scansubfolders: boolean = true);
var   searchrec: tsearchrec;   findresult: integer;
begin
list.beginupdate;
try
startfolder:=includetrailingbackslash(startfolder);
findresult:=findfirst(startfolder+'*.*', faanyfile, searchrec);
try
while findresult = 0 do with searchrec do begin
if (attr and fadirectory) < > 0 then begin
if scansubfolders and (name < > '.') and (name < > '..') then
findfiles(startfolder+name, mask, list, scansubfolders);
end else begin
if matchesmask(name, mask) then list.add(startfolder+name);
end;
findresult:=findnext(searchrec);
end;
finally   findclose(searchrec);   end;
finally   list.endupdate;   end;
end;

Przykład wykorzystania:
procedure tform1.button1click(sender: tobject);
begin
findfiles('c:program files', '*.exe', memo1.lines, true);
end;

27. Pobranie danych przez StringGrid z pliku tekstowego.

Jest to plik tekstowy z tej treści:
data 210 372 czas 13,00
data 220 345 czas 14,50
A tak należy wykorzystać stringgird aby pobrać ten plik.

var   ... f:text;...

procedure tform1.button1click(sender: tobject);
var   s:string;   s1:string[6];   i:integer;
begin
stringgrid.cells[1,0]:='data';   stringgrid.cells[2,0]:='czas';
i:=0;   assignfile(f,'inform.txt');   reset(f);
repeat
inc(i);   readln(f,s);   delete(s,1,5);   s1:=s;   stringgrid.cells[1,i]:=s1;
delete(s,1,13);   stringgrid.cells[2,i]:=s;   stringgrid.cells[0,i]:=inttostr(i);
until eof(f);
closefile(f);
end;

const   dt = 'data';   tm = 'czas';
var   f: textfile;   s, s1: string;   i, j: integer;
begin
if fileexists('test.txt') then
begin
assignfile(f, 'test.txt');   reset(f);   j:=1;
while not eof(f) do
begin
readln(f, s);   s:=s+' ';   i:=pos(dt, s);
if i = 0 then begin closefile(f);   exit   end;   // nieprawidłowy ciąg
delete(s, 1, i+length(dt));
while s[1] = ' ' do
delete(s,1,1);   i:=pos(tm, s);   stringgrid1.cells[1, j]:=copy(s, 1, i-1);
i:=pos(tm, s);   delete(s, 1, i+length(tm));
while s[1]=' ' do
delete(s, 1, 1);   stringgrid1.cells[2, j]:=s;   inc(j)   end;
closefile(f)
end;

28. Dostęp do tymczasowego katalogu Windows.

function sysdir:string;
var   buf:array[0..max_path] of char;
begin
getsystemdirectory(@buf, max_path+1);   result := buf;
end;

function tempdir:string;
var   buf:array[0..max_path] of char;
begin
gettemppath(max_path+1, @buf);   result := buf;
end;

29. Lista aktywnych programów (plików EXE).

uses psapi, tlhelp32;

procedure createwin9xprocesslist(list: tstringlist);
var   hsnapshot: thandle;   procinfo: tprocessentry32;
begin
if list = nil then   exit;
hsnapshot := createtoolhelp32snapshot(th32cs_snapprocess, 0);
if (hsnapshot < > thandle(-1)) then
begin
procinfo.dwsize := sizeof(procinfo);
if (process32first(hsnapshot, procinfo)) then
begin
list.add(procinfo.szexefile);
while (process32next(hsnapshot, procinfo)) do
list.add(procinfo.szexefile);   end;
closehandle(hsnapshot);
end;   end;

procedure createwinntprocesslist(list: tstringlist);
var   pidarray: array [0..1023] of dword;   cb: dword;   i: integer;   proccount: integer;
hmod: hmodule;   hprocess: thandle;   modulename: array [0..300] of char;
begin
if list = nil then   exit;
enumprocesses(@pidarray, sizeof(pidarray), cb);   proccount := cb div sizeof(dword);
for i := 0 to proccount - 1 do
begin
hprocess := openprocess(process_query_information or process_vm_read, false, pidarray[i]);
if (hprocess < > 0) then
begin
enumprocessmodules(hprocess, @hmod, sizeof(hmod), cb);
getmodulefilenameex(hprocess, hmod, modulename, sizeof(modulename));
list.add(modulename);   closehandle(hprocess);
end;   end;
end;

procedure getprocesslist(var list: tstringlist);
var   ovi: tosversioninfo;
begin
if list = nil then   exit;
ovi.dwosversioninfosize := sizeof(tosversioninfo);   getversionex(ovi);
case ovi.dwplatformid of
ver_platform_win32_windows: createwin9xprocesslist(list);
ver_platform_win32_nt: createwinntprocesslist(list);
end   end;

function exe_running(filename: string; bfullpath: boolean): boolean;
var   i: integer;   myproclist: tstringlist;
begin
myproclist := tstringlist.create;
try
getprocesslist(myproclist);   result := false;
if myproclist = nil then exit;
for i := 0 to myproclist.count - 1 do
begin
if not bfullpath then begin
if comparetext(extractfilename(myproclist.strings[i]), filename) = 0 then   result := true
end else
if comparetext(myproclist.strings[i], filename) = 0 then   result := true;
if result then break;   end;
finally   myproclist.free;   end;
end;

//przykład 1 - czy taki plik EXE jest aktywny?
procedure tform1.button1click(sender: tobject);
begin
if exe_running('notepad.exe', false) then
showmessage('plik exe jest aktywny')
else
showmessage('plik exe nie jest aktywny');
end;

// przykład 2 - lista aktywnych plikow EXE
procedure tform1.button3click(sender: tobject);
var   i: integer;   myproclist: tstringlist;
begin
myproclist := tstringlist.create;
try
getprocesslist(myproclist);   if myproclist = nil then exit;
for i := 0 to myproclist.count - 1 do   listbox1.items.add(myproclist.strings[i]);
finally   myproclist.free;   end;
end;

30. Jak zamknąć program znając tylko nazwę pliku Exe?

np : killtask('notepad.exe') lub killtask('iexplore.exe'); }

uses tlhelp32, windows, sysutils;

function killtask(exefilename: string): integer;
const   process_terminate=$0001;
var   continueloop: bool;   fsnapshothandle: thandle;   fprocessentry32: tprocessentry32;
begin
result := 0;
fsnapshothandle := createtoolhelp32snapshot (th32cs_snapprocess, 0);
fprocessentry32.dwsize := sizeof(fprocessentry32);
continueloop := process32first(fsnapshothandle, fprocessentry32);

while integer(continueloop) < > 0 do
begin
if ((uppercase(extractfilename(fprocessentry32.szexefile)) = uppercase(exefilename))
or (uppercase(fprocessentry32.szexefile) = uppercase(exefilename))) then
result := integer(terminateprocess(openprocess(process_terminate, bool(0),
fprocessentry32.th32processid), 0));
continueloop := process32next(fsnapshothandle, fprocessentry32);
end;
closehandle(fsnapshothandle);
end;

31. Wyciąg ikony z plików EXE / DLL- inna wersja

var   myicon: ticon;
begin
myicon := ticon. create;
try
myicon.handle := extracticon(hinstance, 'myprog.exe', 0)
{tu np, można zapisać ikonę do pliku, dodac do Image lub ListView lub coś innego}
finally   myicon.free;   end;
end;