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;
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;
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;
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;
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;
uses Filectrl; {....}
procedure TForm1.Button1Click(Sender: TObject);
var Dir: String;
begin
SelectDirectory('Wybór katalogu', '', Dir); ShowMessage(Dir);
end;
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 ...
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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 }
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;
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.
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;
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;
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;
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;
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;
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;
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;
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;