Получить количество файлов в корзине и их общий размер

Опубликовал newfork, . Категория Директории и файлы. Оставить комментарий

type

PSHQueryRBInfo = ^TSHQueryRBInfo;

TSHQueryRBInfo = packed record

cbSize: DWORD;

// Size of the structure, in bytes.

// This member must be filled in prior to calling the function.

i64Size: Int64;

// Total size of all the objects in the specified Recycle Bin, in bytes.

i64NumItems: Int64;

// Total number of items in the specified Recycle Bin.

end;

const

shell32 = 'shell32.dll';

function SHQueryRecycleBin(szRootPath: PChar; SHQueryRBInfo: PSHQueryRBInfo): HResult;

stdcall; external shell32 Name 'SHQueryRecycleBinA';

function GetDllVersion(FileName: string): Integer;

var

InfoSize, Wnd: DWORD;

VerBuf: Pointer;

FI: PVSFixedFileInfo;

VerSize: DWORD;

begin

Result := 0;

InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);

if InfoSize 0 then

begin

GetMem(VerBuf, InfoSize);

try

if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then

if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then

Result := FI.dwFileVersionMS;

finally

FreeMem(VerBuf);

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

DllVersion: integer;

SHQueryRBInfo: TSHQueryRBInfo;

r: HResult;

begin

DllVersion := GetDllVersion(PChar(shell32));

if DllVersion >= $00040048 then

begin

FillChar(SHQueryRBInfo, SizeOf(TSHQueryRBInfo), #0);

SHQueryRBInfo.cbSize := SizeOf(TSHQueryRBInfo);

R := SHQueryRecycleBin(nil, @SHQueryRBInfo);

if r = s_OK then

begin

label1.Caption := Format('Size:%d Items:%d',

[SHQueryRBInfo.i64Size, SHQueryRBInfo.i64NumItems]);

end

else

label1.Caption := Format('Err:%x', [r]);

end;

end;

{

The SHQueryRecycleBin API used in this method is

only available on systems with the latest shell32.dll installed with IE4 /

Active Desktop.

}

[cc lang="delphi"] 

Переслать файл в Корзину

Опубликовал newfork, . Категория Директории и файлы. Оставить комментарий

Сначала нужно в директиве uses подключить модуль ShellAPI, чтобы мы смогли воспользоваться API-функцией SHFileOperation(). А затем уже можно использовать такой вот процедурой:

procedure SendToPomoyka(FileName: string);

var

SHF: TSHFileOpStruct;

begin

with SHF do

begin

Wnd := Application.Handle;

wFunc := FO_DELETE;

pFrom := PChar(FileName);

fFlags := FOF_SILENT or FOF_ALLOWUNDO;

end;

SHFileOperation(SHF);

end;

Очистить корзину

Опубликовал newfork, . Категория Директории и файлы. Оставить комментарий

procedure EmptyRecycleBin;

const

SHERB_NOCONFIRMATION = $00000001;

SHERB_NOPROGRESSUI = $00000002;

SHERB_NOSOUND = $00000004;

type

TSHEmptyRecycleBin = function(Wnd: HWND;

pszRootPath: PChar;

dwFlags: DWORD): HRESULT; stdcall;

var

SHEmptyRecycleBin: TSHEmptyRecycleBin;

LibHandle: THandle;

begin { EmptyRecycleBin }

LibHandle := LoadLibrary(PChar('Shell32.dll'));

if LibHandle 0 then @SHEmptyRecycleBin :=

GetProcAddress(LibHandle, 'SHEmptyRecycleBinA')

else

begin

MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);

Exit;

end;

if @SHEmptyRecycleBin nil then

SHEmptyRecycleBin(Application.Handle,

nil,

SHERB_NOCONFIRMATION or SHERB_NOPROGRESSUI or SHERB_NOSOUND);

FreeLibrary(LibHandle); @SHEmptyRecycleBin := nil;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

EmptyRecycleBin;

end;

{

Minimum operating systems: Windows XP/2000, Windows NT 4.0 with Internet Explorer 4.0,

Windows 98, Windows 95 with Internet Explorer 4.0

(shell32.dll version 4.71 or later)

}

Копирование директорий и удаление директорий в корзину

Опубликовал newfork, . Категория Директории и файлы. Оставить комментарий

unit MainFrm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Buttons;

type

TMainForm = class(TForm)

GroupBox1: TGroupBox;

spbtnGetFromDir: TSpeedButton;

spbtnGetToDir: TSpeedButton;

edtFromDir: TEdit;

edtToDir: TEdit;

Button1: TButton;

GroupBox2: TGroupBox;

edtRecycleDir: TEdit;

spbtnRecycleBin: TSpeedButton;

btnRecycleDir: TButton;

btnClose: TButton;

procedure spbtnGetFromDirClick(Sender: TObject);

procedure spbtnGetToDirClick(Sender: TObject);

procedure btnCopyDirectoryClick(Sender: TObject);

procedure spbtnRecycleBinClick(Sender: TObject);

procedure btnRecycleDirClick(Sender: TObject);

procedure btnCloseClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

MainForm: TMainForm;

implementation

uses ShellAPI, FileCtrl;

{$R *.DFM}

function GetDirectory: string;

begin

if not SelectDirectory(Result, [sdAllowCreate, sdPerformCreate, sdPrompt], 0)

then

Result := EmptyStr;

end;

procedure CopyDirectoryTree(AHandle: THandle; const AFromDirectory,

AToDirectory: string);

var

SHFileOpStruct: TSHFileOpStruct;

FromDir: PChar;

ToDir: PChar;

begin

GetMem(FromDir, Length(AFromDirectory) 2);

try

GetMem(ToDir, Length(AToDirectory) 2);

try

FillChar(FromDir^, Length(AFromDirectory) 2, 0);

FillChar(ToDir^, Length(AToDirectory) 2, 0);

StrCopy(FromDir, PChar(AFromDirectory));

StrCopy(ToDir, PChar(AToDirectory));

with SHFileOpStruct do

begin

Wnd := AHandle; // Assign the window handle

wFunc := FO_COPY; // Specify a file copy

pFrom := FromDir;

pTo := ToDir;

fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;

fAnyOperationsAborted := False;

hNameMappings := nil;

lpszProgressTitle := nil;

if SHFileOperation(SHFileOpStruct) 0 then

RaiseLastWin32Error;

end;

finally

FreeMem(ToDir, Length(AToDirectory) 2);

end;

finally

FreeMem(FromDir, Length(AFromDirectory) 2);

end;

end;

procedure ToRecycle(AHandle: THandle; const ADirName: string);

var

SHFileOpStruct: TSHFileOpStruct;

DirName: PChar;

BufferSize: Cardinal;

begin

BufferSize := Length(ADirName) 1 1;

GetMem(DirName, BufferSize);

try

FillChar(DirName^, BufferSize, 0);

StrCopy(DirName, PChar(ADirName));

with SHFileOpStruct do

begin

Wnd := AHandle;

wFunc := FO_DELETE;

pFrom := DirName;

pTo := nil;

fFlags := FOF_ALLOWUNDO;

fAnyOperationsAborted := False;

hNameMappings := nil;

lpszProgressTitle := nil;

end;

if SHFileOperation(SHFileOpStruct) 0 then

RaiseLastWin32Error;

finally

FreeMem(DirName, BufferSize);

end;

end;

procedure TMainForm.spbtnGetFromDirClick(Sender: TObject);

begin

edtFromDir.Text := GetDirectory;

end;

procedure TMainForm.spbtnGetToDirClick(Sender: TObject);

begin

edtToDir.Text := GetDirectory;

end;

procedure TMainForm.btnCopyDirectoryClick(Sender: TObject);

begin

CopyDirectoryTree(Handle, edtFromDir.Text, edtToDir.Text);

end;

procedure TMainForm.spbtnRecycleBinClick(Sender: TObject);

begin

edtRecycleDir.Text := GetDirectory;

end;

procedure TMainForm.btnRecycleDirClick(Sender: TObject);

begin

ToRecycle(0, edtRecycleDir.Text);

end;

procedure TMainForm.btnCloseClick(Sender: TObject);

begin

Close;

end;

end.

Как удалить файлы из корзины

Опубликовал newfork, . Категория Директории и файлы. Оставить комментарий

program del;

uses

ShellApi;

//function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;

var

T: TSHFileOpStruct;

P: string;

begin

P := 'C:\Windows\System\EL_CONTROL.CPL';

with T do

begin

Wnd := 0;

wFunc := FO_DELETE;

pFrom := Pchar(P);

fFlags := FOF_ALLOWUNDO

end;

SHFileOperation(T);

end.

Восстановление

Есть некоторые причуды, и Вы должны помнить о следующем:

Дайте полный путь для каждого файла. Не доверяйте текущей директории, даже если Вы ее изменили непосредственно перед вызовом функции. Функция WinAPI SHFileOperation не достаточно «умная» для использования текущей директории при отсутствии информации о предыдущей директории (для осуществления функции восстановления). Так, даже если используете флаг FOF_ALLOWUNDO, это не восстановит удаленные файлы из корзины, поскольку функция ничего не знает о предыдущем месторасположении файлов, и, таким образом, не сможет их восстановить файлы из корзины в их оригинальное месторасположение. Она просто удалит файлы из текущей директории.

Microsoft скорректировала документацию о члене pFrom. Новая редакция сообщает о подробностях работы в пакетном режиме: необходимо разделить имя каждого файла символом NULL (#0) и добавить к концу списка двойной символ NULL. Терминатор из двух символов NULL необходим в любом случае: работаете вы с одним файлом, или же используете пакетный режим. Иногда это работает и без терминатора, но чаще нет. Это связано с тем, что функции при работе с памятью считывает данные из памяти, располагающейся до терминатора, а поскольку длина строки может не совпадать с распределенной памятью, то данные, находящиеся после терминатора, просто не обрабатываются.

Пример правильного кодирования:

var

FileList: string;

FOS: TShFileOpStruct;

begin

FileList := 'c:\delete.me'#0'c:\windows\temp.$$$'#0#0;

{ если Вы используете имена файлов в строковых переменных: }

FileList := Filename1 #0 Filename2 #0#0;

FOS.pFrom := PChar(FileList);

end;

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

Опубликовал newfork, . Категория Директории и файлы. Оставить комментарий

Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию Delphi FindFirst, код для установки и удаления метки тома использует вызов DOS-прерывания 21h и функции 16h и 13h соответственно. Поскольку функция 16h не поддерживается Windows, она должна вызываться через DPMI-прерывание 31h, функцию 300h.

{ *** НАЧАЛО КОДА МОДУЛЯ VOLLABEL *** }

unit VolLabel;

interface

uses Classes, SysUtils, WinProcs;

type

EInterruptError = class(Exception);

EDPMIError = class(EInterruptError);

Str11 = string[11];

procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);

function GetVolumeLabel(Drive: Char): Str11;

procedure DeleteVolumeLabel(Drv: Char);

implementation

type

PRealModeRegs = ^TRealModeRegs;

TRealModeRegs = record

case Integer of

0: (

EDI, ESI, EBP, EXX, EBX, EDX, ECX, EAX: Longint;

Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word);

1: (

DI, DIH, SI, SIH, BP, BPH, XX, XXH: Word;

case Integer of

0: (

BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word);

1: (

BL, BH, BLH, BHH, DL, DH, DLH, DHH,

CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte));

end;

PExtendedFCB = ^TExtendedFCB;

TExtendedFCB = record

ExtendedFCBflag: Byte;

Reserved1: array[1..5] of Byte;

Attr: Byte;

DriveID: Byte;

FileName: array[1..8] of Char;

FileExt: array[1..3] of Char;

CurrentBlockNum: Word;

RecordSize: Word;

FileSize: LongInt;

PackedDate: Word;

PackedTime: Word;

Reserved2: array[1..8] of Byte;

CurrentRecNum: Byte;

RandomRecNum: LongInt;

end;

procedure RealModeInt(Int: Byte; var Regs: TRealModeRegs);

{ процедура работает с прерыванием 31h, функцией 0300h для иммитации }

{ прерывания режима реального времени для защищенного режима. }

var

ErrorFlag: Boolean;

begin

asm

mov ErrorFlag, 0 { успешное завершение }

mov ax, 0300h { функция 300h }

mov bl, Int { прерывание режима реального времени, которое необходимо выполнить }

mov bh, 0 { требуется }

mov cx, 0 { помещаем слово в стек для копирования, принимаем ноль }

les di, Regs { es:di = Regs }

int 31h { DPMI-прерывание 31h }

jnc @@End { адрес перехода установлен в error }

@@Error:

mov ErrorFlag, 1 { возвращаем false в error }

@@End:

end;

if ErrorFlag then

raise EDPMIError.Create('Неудача при выполнении DPMI-прерывания');

end;

function DriveLetterToNumber(DriveLet: Char): Byte;

{ функция преобразования символа буквы диска в цифровой эквивалент. }

begin

if DriveLet in ['a'..'z'] then

DriveLet := Chr(Ord(DriveLet) - 32);

if not (DriveLet in ['A'..'Z']) then

raise

EConvertError.CreateFmt('Не могу преобразовать %s в числовой эквивалент диска',

[DriveLet]);

Result := Ord(DriveLet) - 64;

end;

procedure PadVolumeLabel(var Name: Str11);

{ процедура заполнения метки тома диска строкой с пробелами }

var

i: integer;

begin

for i := Length(Name) 1 to 11 do

Name := Name ' ';

end;

function GetVolumeLabel(Drive: Char): Str11;

{ функция возвращает метку тома диска }

var

SR: TSearchRec;

DriveLetter: Char;

SearchString: string[7];

P: Byte;

begin

SearchString := Drive ':\*.*';

{ ищем метку тома }

if FindFirst(SearchString, faVolumeID, SR) = 0 then

begin

P := Pos('.', SR.Name);

if P > 0 then

begin { если у него есть точка... }

Result := ' '; { пространство между именами }

Move(SR.Name[1], Result[1], P - 1); { и расширениями }

Move(SR.Name[P 1], Result[9], 3);

end

else

begin

Result := SR.Name; { в противном случае обходимся без пробелов }

PadVolumeLabel(Result);

end;

end

else

Result := '';

end;

procedure DeleteVolumeLabel(Drv: Char);

{ процедура удаления метки тома с данного диска }

var

CurName: Str11;

FCB: TExtendedFCB;

ErrorFlag: WordBool;

begin

ErrorFlag := False;

CurName := GetVolumeLabel(Drv); { получение текущей метки тома }

FillChar(FCB, SizeOf(FCB), 0); { инициализируем FCB нулями }

with FCB do

begin

ExtendedFCBflag := $FF; { всегда }

Attr := faVolumeID; { Аттрибут Volume ID }

DriveID := DriveLetterToNumber(Drv); { Номер диска }

Move(CurName[1], FileName, 8); { необходимо ввести метку тома }

Move(CurName[9], FileExt, 3);

end;

asm

push ds { сохраняем ds }

mov ax, ss { помещаем сегмент FCB (ss) в ds }

mov ds, ax

lea dx, FCB { помещаем смещение FCB в dx }

mov ax, 1300h { функция 13h }

Call DOS3Call { вызываем int 21h }

pop ds { восстанавливаем ds }

cmp al, 00h { проверка на успешность выполнения }

je @@End

@@Error: { устанавливаем флаг ошибки }

mov ErrorFlag, 1

@@End:

end;

if ErrorFlag then

raise EInterruptError.Create('Не могу удалить имя тома');

end;

procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);

{ процедура присваивания метки тома диска. Имейте в виду, что }

{ данная процедура удаляет текущую метку перед установкой новой. }

{ Это необходимое требование для функции установки метки. }

var

Regs: TRealModeRegs;

FCB: PExtendedFCB;

Buf: Longint;

begin

PadVolumeLabel(NewLabel);

if GetVolumeLabel(Drive) '' then { если имеем метку... }

DeleteVolumeLabel(Drive); { удаляем метку }

Buf := GlobalDOSAlloc(SizeOf(PExtendedFCB)); { распределяем реальный буфер }

FCB := Ptr(LoWord(Buf), 0);

FillChar(FCB^, SizeOf(FCB), 0); { инициализируем FCB нулями }

with FCB^ do

begin

ExtendedFCBflag := $FF; { требуется }

Attr := faVolumeID; { Аттрибут Volume ID }

DriveID := DriveLetterToNumber(Drive); { Номер диска }

Move(NewLabel[1], FileName, 8); { устанавливаем новую метку }

Move(NewLabel[9], FileExt, 3);

end;

FillChar(Regs, SizeOf(Regs), 0);

with Regs do

begin { Сегмент FCB }

ds := HiWord(Buf); { отступ = ноль }

dx := 0;

ax := $1600; { Функция 16h }

end;

RealModeInt($21, Regs); { создаем файл }

if (Regs.al 0) then { проверка на успешность выполнения }

raise EInterruptError.Create('Не могу создать метку тома');

end;

end.

{ *** КОНЕЦ КОДА МОДУЛЯ VOLLABEL *** }

Серийный номер тома HDD

Опубликовал newfork, . Категория Директории и файлы. Оставить комментарий

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

Автор: Алексей Коган

И ты, root?

procedure TForm1.Button1Click(Sender: TObject);

var

SerialNum : dword;

a, b : dword;

Buffer : array [0..255] of char;

begin

if GetVolumeInformation(‘c:\’, Buffer, SizeOf(Buffer),

@SerialNum, a, b, nil, 0) then

Label1.Caption := IntToStr(SerialNum);

end;

Алексей Коган

FIDOnet 2:5064/7.69

Russia, Stavropol

Должен заметить, что GetVolumeInformation возвращает серийный номер ТОМА, а не винчестера, то есть, если заменить C:\ на D:\, то номерок-то и поменяется…

{/codecitation}

Простейший сканер диска

Опубликовал newfork, . Категория Директории и файлы. Оставить комментарий

Вот пример, который ищет мп3 файлы на жестком диске…

unit Audit1;

interface

uses windos;

var

dest: string;

procedure dorecurse(dir: string);

implementation

{$R *.DFM}

procedure Process(dir: string; Searchrec: tsearchrec);

begin

showmessage(Searchrec.name);

case Searchrec.attr of

$10:

if (searchrec.name '.') and (searchrec.name '..') then

begin

dorecurse(dir '\' searchrec.name);

writeln(dir);

end;

end;

end;

procedure Dorecurse(dir: string);

var

Searchrec: Tsearchrec;

pc: array[0..79] of Char;

begin

StrPCopy(pc, dir '\*.mp3');

FindFirst(pc, FaAnyfile, SearchRec);

Process(dir, SearchRec);

while FindNext(SearchRec) -18 do

begin

Process(dir, SearchRec);

end;

end;

procedure startsearch;

begin

dorecurse(paramstr(1));

end;

begin

startsearch;

end.

Получение информации о диске

Опубликовал newfork, . Категория Директории и файлы, Система. Оставить комментарий

function GetVolumeInfoFVS(const Dir:string;

var FileSystemName,VolumeName:string;var Serial:longint):boolean;

{Получение информации о диске

Dir - каталог или буква требуемого диска

FileSystemName - название файловой системы

VolumeName - метка диска

Serial - серийный номер диска

В случае ошибки функция возвращает false}

var

root:pchar;

res:longbool;

VolumeNameBuffer,FileSystemNameBuffer:pchar;

VolumeNameSize,FileSystemNameSize:DWord;

VolumeSerialNumber,MaximumComponentLength,FileSystemFlags:DWORD;

s:string;

n:integer;

begin

n:=pos(':',Dir);

if n> 0 then s:=copy(Dir,1,n 1) else s:=s ':';

if s[length(s)]=':' then s:=s '\';

root:=pchar(s);

getMem(VolumeNameBuffer,256);

getMem(FileSystemNameBuffer,256);

VolumeNameSize:=255;

FileSystemNameSize:=255;

res:=GetVolumeInformation(Root,VolumeNameBuffer,VolumeNameSize

,@VolumeSerialNumber,

MaximumComponentLength, FileSystemFlags

,FileSystemNameBuffer,FileSystemNameSize);

Result:=res;

VolumeName:=VolumeNameBuffer;

FileSystemName:=FileSystemNameBuffer;

Serial:=VolumeSerialNumber;

freeMem(VolumeNameBuffer,256);

freeMem(FileSystemNameBuffer,256);

end;

Перечислить диски

Опубликовал newfork, . Категория Директории и файлы. Оставить комментарий

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

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

{

Adds all fixed drives into Combobox1.

To enumerate another type of drive,

i.e all CD-ROMs just change the DRIVE_FIXED constant to DRIVE_CDROM.

Fugt all fixen Laufwerke in Combobox1 ein.

Um z.B alle CD-Rom Laufwerke zu ermitteln,

einfach DRIVE_CDROM anstatt die Konstante DRIVE_FIXED nehmen.

}

procedure List_Drives;

const

DRIVE_UNKNOWN = 0;

DRIVE_NO_ROOT_DIR = 1;

DRIVE_REMOVABLE = 2;

DRIVE_FIXED = 3;

DRIVE_REMOTE = 4;

DRIVE_CDROM = 5;

DRIVE_RAMDISK = 6;

var

r: LongWord;

Drives: array[0..128] of char;

pDrive: PChar;

begin

r := GetLogicalDriveStrings(SizeOf(Drives), Drives);

if r = 0 then Exit;

if r > SizeOf(Drives) then

raise Exception.Create(SysErrorMessage(ERROR_OUTOFMEMORY));

pDrive := Drives;

while pDrive^ #0 do

begin

if GetDriveType(pDrive) = DRIVE_FIXED then

Form1.ComboBox1.Items.Add(pDrive);

Inc(pDrive, 4);

end;

end;

{/codecitation}