Автор: newfork

Как определить размер свободного места на диске

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Для получения размера свободного места на дисках, ёмкость которых больше 2Гб, необходимо использовать функцию GetDiskFreeSpaceEx. Ниже приведён небольшой пример использования данной функции:

var

FreeBytesAvailableToCaller: TLargeInteger;

FreeSize: TLargeInteger;

TotalSize: TLargeInteger;

begin

GetDiskFreeSpaceEx(‘c:’,

FreeBytesAvailableToCaller,

Totalsize,

@FreeSize);

end;

Результатом будет значение в байтах.

{/codecitation}

Как вывести сведения о диске (метка тома, серийный номер, файловая система и т.д.)

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Звонок в службу технической поддержки:

— У меня компьютер не работает!

— После чего это произошло?

— Я его включил — загрузился Нортон. Смотрю — у меня слева диск С: и справа диск С:. Я подумал — нафиг мне два диска С:? И стер правый к чертовой матери.

procedure TForm1.Button2Click(Sender: TObject);

var

VolumeName,

FileSystemName : array [0..MAX_PATH-1] of Char;

VolumeSerialNo : DWord;

MaxComponentLength,FileSystemFlags: Cardinal;

begin

GetVolumeInformation(‘C:\’,VolumeName,MAX_PATH,@VolumeSerialNo,

MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH);

Memo1.Lines.Add(‘VolumeName = ‘ VolumeName);

Memo1.Lines.Add(‘SerialNo = $’ IntToHex(VolumeSerialNo,8));

Memo1.Lines.Add(‘CompLen = ‘ IntToStr(MaxComponentLength));

Memo1.Lines.Add(‘Flags = $’ IntToHex(FileSystemFlags,4));

Memo1.Lines.Add(‘FSName = ‘ FileSystemName);

end;

{/codecitation}

Cуществует ли диск в системе

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Serious

WEB-сайт: http://forum.vingrad.ru

function DriveExists(Drive: Byte): boolean;

begin

Result := Boolean(GetLogicalDrives and (1 shl Drive));

end;

procedure TForm1.Button1Click(Sender: TObject);

var

Drive: byte;

begin

for Drive := 0 to 25 do

if DriveExists(Drive) then

ListBox1.Items.Add(Chr(Drive $41));

end;

{/codecitation}

Узнаём стандартные папки Windows

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Если не можете выйти из виндов, есть запасной выход:» Выдерни шнур, выдави стекло…».

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);

var

reg : TRegistry;

ts : TStrings;

i : integer;

begin

reg := TRegistry.Create;

reg.RootKey := HKEY_CURRENT_USER;

reg.LazyWrite := false;

reg.OpenKey(

‘Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders’,

false);

ts := TStringList.Create;

reg.GetValueNames(ts);

for i := 0 to ts.Count -1 do begin

Memo1.Lines.Add(ts.Strings[i]

‘ = ‘

reg.ReadString(ts.Strings[i]));

end;

ts.Free;

reg.CloseKey;

reg.free;

end;

{/codecitation}

Удалить каталог со всем содержимым 4

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

procedure TForm1.deletedirectory(dir: string);

var

sh: SHFILEOPSTRUCT;

st: string;

sr: tsearchrec;

pst: pchar;

begin

if findfirst(dir, faDirectory, sr) = 0 then

begin

//added by me

dir := longtoshortfilename(dir);

//original code

sh.Wnd := Form1.handle;

sh.wFunc := FO_DELETE;

Pst := StrAlloc(Length(dir {sr.Name}) 1);

StrPLCopy(Pst, dir {sr.Name}, Length(dir {sr.Name}) 1);

sh.pFrom := pst;

sh.pTo := nil;

sh.fFlags := FOF_NOCONFIRMATION or FOF_SILENT;

sh.hNameMappings := nil;

sh.lpszProgressTitle := nil;

SHFileOperation(sh);

StrDispose(Pst);

end;

findclose(sr);

end;

{/codecitation}

Удалить каталог со всем содержимым 3

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Для удаления каталогов существует функция RemoveDirectory. Она удаляет каталог, если он пуст. Поэтому перед удалением каталога его нужно очистить. Для этого здесь используется рекурентная функция RemoveAll.

uses

FileCtrl;

procedure RemoveAll(path: string);

var

sr: TSearchRec;

begin

if FindFirst(path ‘\*.*’, faAnyFile, sr) = 0 then

begin

repeat

if sr.Attr and faDirectory = 0 then

begin

DeleteFile(path ‘\’ sr.name);

end

else

begin

if pos(‘.’, sr.name) <= 0 then

RemoveAll(path ‘\’ sr.name);

end;

until

FindNext(sr) 0;

end;

FindClose(sr);

RemoveDirectory(PChar(path));

end;

procedure TForm1.Button1Click(Sender: TObject);

var

dir: string;

begin

if SelectDirectory(‘Удаление каталога’, », dir) then

RemoveAll(dir);

end;

{/codecitation}

Удалить каталог со всем содержимым 2

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

function MyRemoveDir(sDir : string) : Boolean;

var

iIndex: Integer;

SearchRec: TSearchRec;

sFileName: string;

begin

Result := False;

sDir := sDir ‘\*.*’;

iIndex := FindFirst(sDir, faAnyFile, SearchRec);

while iIndex = 0 do

begin

sFileName := ExtractFileDir(sDir) ‘\’ SearchRec.name;

if SearchRec.Attr = faDirectory then

begin

if (SearchRec.name » ) and (SearchRec.name ‘.’) and

(SearchRec.name ‘..’) then

MyRemoveDir(sFileName);

end

else

begin

if SearchRec.Attr faArchive then

FileSetAttr(sFileName, faArchive);

if not DeleteFile(sFileName) then

ShowMessage(‘Could NOT delete ‘ sFileName);

end;

iIndex := FindNext(SearchRec);

end;

FindClose(SearchRec);

RemoveDir(ExtractFileDir(sDir));

Result := True;

end;

// ***************************** //

// Пример: //

// ***************************** //

if not MyRemoveDir(‘D:\myDir’) then

ShowMessage(‘Can NOT delete dir’);

// Кстати, системные, скрытые и

// read-only файлы тоже будут удалены.

{/codecitation}

Удалить каталог со всем содержимым

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

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(‘Не могу войти в каталог: ‘ 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(‘Не могу удалить файл: ‘ SearchRec.name);

exit;

end;

Found := FindNext(SearchRec);

end;

FindClose(SearchRec);

ChDir(‘..’);

RmDir(Dir);

result := IOResult = 0;

end;

{/codecitation}

Удаление содержимого каталога

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: demon-777

WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Удаление содержимого каталога

Зависимости: Windows, SysUtils, Classes, Masks

Автор: demon-777, demon-777@yandex.ru, Питер

Copyright: Dimka Maslov

Дата: 26 мая 2002 г.

***************************************************** }

procedure DeleteFiles(Path: string);

var

Mask: string;

SearchRec: TSearchRec;

FindResult: Integer;

List: TStringList;

i: Integer;

begin

Mask := ExtractFileName(Path);

if Mask = » then

Mask := ‘*.*’;

Path := ExtractFilePath(Path);

if Path = » then

Path := IncludeTrailingBackslash(GetCurrentDir);

List := TStringList.Create;

try

FindResult := FindFirst(Path ‘*.*’, faAnyFile, SearchRec);

try

while FindResult = 0 do

with SearchRec do

begin

if ((Attr and faDirectory) = 0) and MatchesMask(Name, Mask) then

List.Add(Name);

FindResult := FindNext(SearchRec);

end;

for i := 0 to List.Count — 1 do

DeleteFile(Path List[i]);

finally

FindClose(SearchRec);

end;

finally

List.Free;

end;

end;

{/codecitation}

Удаление непустого каталога вместе с подкаталогами

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Lipskiy

WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Удаление непустого каталога вместе с подкаталогами

Удаление подкаталогов рекурсивное — функция вызывает саму себя.

Описание назначения агрументов:

-DeleteAllFilesAndFolder — если TRUE то функцией будут предприняты

попытки для установки атрибута faArchive любому файлу или папке

перед его(её) удалением;

-StopIfNotAllDeleted — если TRUE то работа функции моментально

прекращается если возникла ошибка удаления хотя бы одного файла или папки;

-RemoveRoot — если TRUE, указывает на необходимость удаления корня.

Зависимости: FileCtrl, SysUtils

Автор: lipskiy, lipskiy@mail.ru, ICQ:51219290, Санкт-Петербург

Copyright: Собственное написание (lipskiy)

Дата: 26 апреля 2002 г.

***************************************************** }

function FullRemoveDir(Dir: string; DeleteAllFilesAndFolders,

StopIfNotAllDeleted, RemoveRoot: boolean): Boolean;

var

i: Integer;

SRec: TSearchRec;

FN: string;

begin

Result := False;

if not DirectoryExists(Dir) then

exit;

Result := True;

// Добавляем слэш в конце и задаем маску — «все файлы и директории»

Dir := IncludeTrailingBackslash(Dir);

i := FindFirst(Dir ‘*’, faAnyFile, SRec);

try

while i = 0 do

begin

// Получаем полный путь к файлу или директорию

FN := Dir SRec.Name;

// Если это директория

if SRec.Attr = faDirectory then

begin

// Рекурсивный вызов этой же функции с ключом удаления корня

if (SRec.Name ») and (SRec.Name ‘.’) and (SRec.Name ‘..’) then

begin

if DeleteAllFilesAndFolders then

FileSetAttr(FN, faArchive);

Result := FullRemoveDir(FN, DeleteAllFilesAndFolders,

StopIfNotAllDeleted, True);

if not Result and StopIfNotAllDeleted then

exit;

end;

end

else // Иначе удаляем файл

begin

if DeleteAllFilesAndFolders then

FileSetAttr(FN, faArchive);

Result := SysUtils.DeleteFile(FN);

if not Result and StopIfNotAllDeleted then

exit;

end;

// Берем следующий файл или директорию

i := FindNext(SRec);

end;

finally

SysUtils.FindClose(SRec);

end;

if not Result then

exit;

if RemoveRoot then // Если необходимо удалить корень — удаляем

if not RemoveDir(Dir) then

Result := false;

end;

Пример использования:

FullRemoveDir(‘C:\a’, true, true, true);

// Полное удаление папки C:\a со всем её содержимым,

// и с последующим удалением самой c:\a

{/codecitation}