Переименование каталога

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

uses

ShellApi;

procedure RenameDir(DirFrom, DirTo: string);

var

shellinfo: TSHFileOpStruct;

begin

with shellinfo do

begin

Wnd := 0;

wFunc := FO_RENAME;

pFrom := PChar(DirFrom);

pTo := PChar(DirTo);

fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or

FOF_SILENT or FOF_NOCONFIRMATION;

end;

SHFileOperation(shellinfo);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

RenameDir(‘C:\Dir1’, ‘C:\Dir2’);

end;

{/codecitation}

Перевод списка файлов и каталогов из TStringList в TreeView с построением дерева каталогов

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

Автор: Радионов Алексей

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

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

>> Перевод списка файлов/каталогов из TStringList в

TreeView с построением «дерева каталогов»

Иногда бывает нужно построить «дерево каталогов» по

заданному списку файлов и папок (причем физически

эти файлы и каталоги могут не существовать).

Представляемый здесь код занимается именно этим.

Зависимости: sysutils, classes, comctrls

Автор: Радионов Алексей (Alx2), alx@argo.mv.ru, ICQ:113442587, Ульяновск

Copyright: Alx2

Дата: 3 июля 2002 г.

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

procedure FillTreeViewWithFiles(TreeView1: TTreeView; Strs: TStringList);

var

CachedStrs: TStringList; // CachedStrs вводится для ускорения поиска

// в уже готовом дереве.

procedure AddItem(Lev: Integer; ParentNode: TTreeNode; S: string);

function FindNodeWithText(AParent: TTreeNode; const S: string): TTreeNode;

var

K: Integer;

fStr: string;

tmpNode: TTreeNode;

begin

Result := nil;

fStr := S IntToStr(Integer(AParent));

K := CachedStrs.IndexOf(fStr);

if K > -1 then

Result := Pointer(CachedStrs.Objects[K])

else

begin

if AParent nil then

tmpNode := AParent.getFirstChild

else

tmpNode := TreeView1.Items.GetFirstNode;

while tmpNode nil do

begin

if tmpNode.Text = S then

begin

Result := tmpNode;

CachedStrs.AddObject(fStr, Pointer(tmpNode));

break;

end;

tmpNode := tmpNode.getNextSibling;

end;

end

end;

var

prefix: string;

ID: Integer;

aNode: TTreeNode;

begin

if S = » then

Exit;

ID := Pos(‘\’, S);

prefix := »;

if ID > 0 then

prefix := Copy(S, 1, ID — 1)

else

begin

prefix := S;

S := »;

end;

aNode := FindNodeWithText(ParentNode, prefix);

if aNode = nil then

begin

aNode := TreeView1.Items.AddChild(ParentNode, prefix);

end;

AddItem(Lev 1, aNode, Copy(S, ID 1, Length(S)));

end;

var

K: Integer;

begin

CachedStrs := TStringList.Create;

CachedStrs.Duplicates := dupIgnore;

CachedStrs.Sorted := True;

try

TreeView1.Items.BeginUpdate;

TreeView1.SortType := stNone;

for K := 0 to Strs.Count — 1 do

AddItem(0, nil, Strs[K]);

finally

TreeView1.Items.EndUpdate;

CachedStrs.Free;

end;

end;

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

// Построим, например, «дерево каталогов» по трем файлам:

procedure TForm1.Button1Click(Sender: TObject);

var

Strs: TStringList;

begin

Strs := TStringList.Create;

try

Strs.Add(‘D:\Program Files\Borland\Delphi6\Source\Vcl\Printers.dcu’);

Strs.Add(‘D:\Program Files\Borland\Delphi6\Source\Vcl\WinHelp.dcu’);

Strs.Add(‘C:\WINNTS\system\BORLNDMM.DLL’);

FillTreeViewWithFiles(TreeView1, Strs);

finally

Strs.Free;

end;

end;

{/codecitation}

Очистить Мои документы

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

Без лишних слов понятно насколько заманчива эта идея, так, как же её осуществить?

Мы изучим самый легкий способ: удаление всех файлов из папки «Мои документы» без учёта вложенных файлов. Для этого вынесем компонент класса ТFileListBox — это список файлов (находится на закладке Win3.1 палитры компонентов). Затем, с той же закладки, выносим компонент класса TDirectoryListBox — это список каталогов. Задаём ему свойство FileList, указывающее на список файлов (на компонент FileListBox1). Далее можно по созданию окна или по таймеру (если ваша программа многоразового использования) пишем такой код:

procedure TForm1.Timer1Timer(Sender: TObject);

var

i: integer;

begin

DirectoryListBox1.Directory := ‘C:\Мои документы’;

for i := 0 to FileListBox1.Items.Count-1 do

DeleteFile(‘C:\Мои документы\’ FileListBox1.Items[i]);

end;

{/codecitation}

Определение суммарного размера файлов в папке, включая вложенные

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

Автор: Dimka Maslov

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

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

>> Определение суммарного размера файлов в папке, включая вложенные

Процедура и функция для определения суммарноо размера файлов в папке с учётом вложенных папок.

Первая процедура вычисляет размер файлов сканируя указанную т вложенные папки.

Имеется возможность определения промежуточного результата при помощи функции

обратного вызова (callback function).

Аргументы процедуры:

Dir — папка, в которой необходимо вычислить размер файлов

IncludeSubDirs — логическая переменная, определяющая необходимость сканирования вложеныых папок

Result — переменная типа Int64, в которую записывается результат.

Перед передачей в процедуру значение переменной должно быть обнулено.

CallbackProc — адрес процедуры обратного вызова, имеющий тип TGetDirSizeCallbackProc —

процедура, принимающая два параметра: определяемое пользователем число типа Integer

и размер файлов, определённый на момент вызова процедуры.

CallbackTag — определяемое пользователм число, передаваемое в процедуру обратного вызова.

Применение последних двух примеров см. Пример использования.

Вторая функция просто возвращает размер файлов, принимая только два параметра Dir и IncludeSubDirs

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

Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург

Copyright: Dimka Maslov

Дата: 13 сентября 2002 г.

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

type

TGetDirSizeCallback = procedure(Tag: Integer; CurrentSize: Int64);

procedure GetDirSize(Dir: string; IncludeSubDirs: Boolean; var Result: Int64;

CallbackProc: TGetDirSizeCallback = nil; CallbackTag: Integer = 0); overload;

var

SearchRec: TSearchRec;

FindResult: Integer;

begin

Dir := IncludeTrailingBackslash(Dir);

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

try

while FindResult = 0 do

with SearchRec do

begin

if (Attr and faDirectory) 0 then

begin

if IncludeSubDirs and (Name ‘.’) and (Name ‘..’) then

GetDirSize(Dir Name, IncludeSubDirs, Result, CallbackProc,

CallbackTag);

end

else

begin

Result := Result Cardinal(Size);

if Assigned(CallbackProc) then

CallbackProc(CallbackTag, Result);

end;

FindResult := FindNext(SearchRec);

end;

finally

FindClose(SearchRec);

end;

end;

function GetDirSize(Dir: string; IncludeSubDirs: Boolean = True): Int64;

overload;

begin

GetDirSize(Dir, IncludeSubDirs, Result, nil, 0);

end;

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

procedure TForm1.Button1Click(Sender: TObject);

var

S: Int64;

begin

S := 0;

GetDirSize(‘с:\WINDOWS’, True, S, @TForm1.GetDirCallback, Integer(Self));

Label1.Caption := IntToStr(S);

end;

procedure TForm1.GetDirCallback(CurrentSize: Int64);

begin

Label1.Caption := IntToStr(CurrentSize);

Label1.Repaint;

end;

{/codecitation}

Копирование содержимого директории, вместе с поддиректориями

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

Автор: VID

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

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

>> Копирование содержимого директории, вместе с поддиректориями.

Фукция копирует СОДЕРЖИМОЕ директории SourceDir в директорию TargetDir.

Копируются все файлы, подкаталоги, и файлы находящиеся в этих подкаталогах.

Аргумент StopIfNotAllCopied: если значение этого аргумента = True,

то при первой же ошибке копирования файла или папки, работы функции

прекратится а функуция вернёт False. В случае если этот аргумент = False,

то ошибки копирования учитываться не будут.

Аргумент OverWriteFiles: если True, то существующие файлы будут переписаны.

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

Автор: VID, snap@iwt.ru, ICQ:132234868, Махачкала

Copyright: VID

Дата: 31 января 2003 г.

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

function FullDirectoryCopy(SourceDir, TargetDir: string; StopIfNotAllCopied,

OverWriteFiles: Boolean): Boolean;

var

SR: TSearchRec;

I: Integer;

begin

Result := False;

SourceDir := IncludeTrailingBackslash(SourceDir);

TargetDir := IncludeTrailingBackslash(TargetDir);

if not DirectoryExists(SourceDir) then

Exit;

if not ForceDirectories(TargetDir) then

Exit;

I := FindFirst(SourceDir ‘*’, faAnyFile, SR);

try

while I = 0 do

begin

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

begin

if SR.Attr = faDirectory then

Result := FullDirectoryCopy(SourceDir SR.Name, TargetDir SR.NAME,

StopIfNotAllCopied, OverWriteFiles)

else if not (not OverWriteFiles and FileExists(TargetDir SR.Name))

then

Result := CopyFile(Pchar(SourceDir SR.Name), Pchar(TargetDir

SR.Name), False)

else

Result := True;

if not Result and StopIfNotAllCopied then

exit;

end;

I := FindNext(SR);

end;

finally

SysUtils.FindClose(SR);

end;

end;

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

FullDirectoryCopy(‘C:\a’, ‘D:\b’);

// Скопирует содержимое директории C:\a (не не саму директорию) в директорию D:\b

{/codecitation}

Класс для рекурсивного обхода дерева каталогов

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

Автор: Святослав

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

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

>> Класс (компонент) для рекурсивного обхода дерева каталогов

(всего диска или заданной папки). На каждый файл и директорию

вызывается соответствующий event.

TTreeWalker.TargetPath — путь для обхода.

TTreeWalker.OnNewDir — event вызывается при обнаружении каждой поддиректории

TTreeWalker.OnNewFile — файла.

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

Автор: Святослав, lisin@asicdesign.ru, ICQ:138752432, Saint Petersburg

Copyright: (C) NetBreaker666[AWD]@Svjatoslav_Lisin — т.е. я сам

Дата: 11 августа 2002 г.

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

unit TreeWalker;

//Просто рекурсивный обход. Я думаю комментарии не требуются.

interface

uses

Windows, Messages, SysUtils, Classes;

type

PNewDir = procedure(Sender: TObject; Dir: string) of object;

PNewFile = procedure(Sender: TObject; F: TSearchRec) of object;

type

TTreeWalker = class(TComponent)

private

{ Private declarations }

TargetPathV: string;

OnNewFileV: PNewFile;

OnNewDirV: PNewDir;

procedure SetTargetPath(const S: string);

function GetTargetPath: string;

procedure SetOnFile(const ONF: PNewFile);

function GetOnFile: PNewFile;

procedure SetOnDir(const OND: PNewDir);

function GetOnDir: PNewDir;

procedure Recurs(S: string; D: Integer);

protected

{ Protected declarations }

public

{ Public declarations }

procedure Process;

published

{ Published declarations }

property TargetPath: string read GetTargetPath write SetTargetPath;

property OnNewFile: PNewFile read GetOnFile write SetOnFile;

property OnNewDir: PNewDir read GetOnDir write SetOnDir;

end;

procedure Register;

implementation

procedure TTreeWalker.SetTargetPath(const S: string);

begin

TargetPathV := S;

if TargetPathV[Length(TargetPathV)] ‘\’ then

TargetPathV := TargetPathV ‘\’;

end;

function TTreeWalker.GetTargetPath: string;

begin

Result := TargetPathV;

end;

procedure TTreeWalker.SetOnFile(const ONF: PNewFile);

begin

OnNewFileV := ONF;

end;

function TTreeWalker.GetOnFile: PNewFile;

begin

Result := OnNewFileV;

end;

procedure TTreeWalker.SetOnDir(const OND: PNewDIr);

begin

OnNewDirV := OND;

end;

function TTreeWalker.GetOnDir: PNewDir;

begin

Result := OnNewDirV;

end;

procedure TTreeWalker.Process;

begin

Recurs(TargetPathV, 0);

end;

procedure TTreeWalker.Recurs(S: string; D: Integer);

var

F: TSearchRec;

R: Integer;

begin

if D > 512 then

Exit;

if @OnNewDirV nil then

OnNewDirV(self, S);

R := FindFirst(S ‘*.*’, faAnyFile, F);

while R = 0 do

begin

if @OnNewFileV nil then

OnNewFileV(self, F);

if (F.Attr and faDirectory 0)

and (F.Name ‘.’) and (F.Name ‘..’) then

Recurs(S F.Name ‘\’, D 1);

R := FindNext(F);

end;

FindClose(F);

end;

procedure Register;

begin

RegisterComponents(‘NetBreakers’, [TTreeWalker]);

end;

end.

{/codecitation}

Как создать все поддиректории за один проход

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

Пример использует информационное поле (label) и кнопку на форме. Когда пользователь кликает по кнопке, то все поддиректории, содержащиеся в пути создаются (если они ещё не созданы). Результат записывается в текстовое поле:

uses FileCtrl;

procedure TForm1.Button1Click(Sender: TObject);

var

Dir: string;

begin

Dir := ‘C:\APPS\SALES\LOCAL’;

ForceDirectories(Dir);

if DirectoryExists(Dir) then

Label1.Caption := Dir ‘ was created’

end;

{/codecitation}

Как скопировать директорию с файлами

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

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)); //директория, которую мы хотим скопировать

FillChar(Fo, sizeof(Fo), #0);

Fo.Wnd := Application.Handle;

Fo.wFunc := FO_COPY;

Fo.pFrom := @Buffer;

Fo.pTo := PChar(ToFolder); //куда будет скопирована директория

Fo.fFlags := 0;

if ((SHFileOperation(Fo) 0) or (Fo.fAnyOperationsAborted false)) then

ShowMessage(‘File copy process cancelled’)

end;

end.

{/codecitation}

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

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

Автор: Андрей Сорокин

WEB-сайт: http://anso.da.ru

Для использования этого объекта необходима библиотека TRegExpr

{$B-}

unit DirScan;

interface

uses

RegExpr, SysUtils, Classes;

type

PDirectoryScannerItem = ^TDirectoryScannerItem;

TDirectoryScannerItem = packed record

name : string;

Size : integer;

LastWriteTime : TDateTime;

end;

TOnDirScanFileProceed = procedure (Sender : TObject; const ABaseFolder : string;

const ASearchRecord : TSearchRec; var ACancel : boolean) of object;

TOnDirScanStartFolderScanning = procedure (Sender : TObject; const AFolder : string) of object;

TOnDirScanTimeSlice = procedure (Sender : TObject; var ACancel : boolean) of object;

TCustomDirectoryScanner = class

private

fRegExprMask : string;

fRecursive : boolean;

fCount : integer;

fOnFileProceed : TOnDirScanFileProceed;

fOnStartFolderScanning : TOnDirScanStartFolderScanning;

fOnTimeSlice : TOnDirScanTimeSlice;

fMaskRegExpr : TRegExpr;

function BuildFileListInt (const AFolder : string) : boolean;

public

constructor Create;

destructor Destroy; override;

property Recursive : boolean read fRecursive write fRecursive;

property RegExprMask : string read fRegExprMask write fRegExprMask;

// regular expresion for file names masks (like ‘(\.html?|\.xml)’ etc)

function BuildFileList (AFolder : string) : boolean;

// Build list of all files in folder AFolder.

// If ASubFolder = true then recursivly scans subfolders.

// Returns false if there was file error and user

// decided to terminate process.

property Count : integer read fCount;

// matched in last BuildFileList files count

// Events

property OnFileProceed : TOnDirScanFileProceed read fOnFileProceed write fOnFileProceed;

// for each file matched

property OnStartFolderScanning : TOnDirScanStartFolderScanning read fOnStartFolderScanning

write fOnStartFolderScanning;

// before scanning each directory (starting with root)

property OnTimeSlice : TOnDirScanTimeSlice read fOnTimeSlice write fOnTimeSlice;

// for progress bur an so on (called in each internal iteration)

end;

TDirectoryScanner = class (TCustomDirectoryScanner)

// simple descendant — after BuildFileList call make list of files

// (You can access list thru Item property)

private

fList : TList;

function GetItem (AIdx : integer) : PDirectoryScannerItem;

procedure KillItem (AIdx : integer);

procedure FileProceeding (Sender : TObject; const ABaseFolder : string;

const ASearchRecord : TSearchRec; var ACancel : boolean);

procedure TimeSlice (Sender : TObject; var ACancel : boolean);

public

constructor Create;

destructor Destroy; override;

property Item [AIdx : integer] : PDirectoryScannerItem read GetItem;

end;

implementation

uses

Windows, Controls, TFUS;

constructor TCustomDirectoryScanner.Create;

begin

inherited;

fRecursive := true;

fOnFileProceed := nil;

fOnStartFolderScanning := nil;

fOnTimeSlice := nil;

fMaskRegExpr := nil;

fRegExprMask := »;

end; { of constructor TDirectoryScanner.Create}

destructor TCustomDirectoryScanner.Destroy;

begin

fMaskRegExpr.Free;

inherited;

end; { of destructor TCustomDirectoryScanner.Destroy}

function TCustomDirectoryScanner.BuildFileList (AFolder : string) : boolean;

begin

if (length (AFolder) > 0) and (AFolder [length (AFolder)] = ‘\’)

then AFolder := copy (AFolder, 1, length (AFolder) — 1);

fMaskRegExpr := TRegExpr.Create;

fMaskRegExpr.Expression := RegExprMask;

fCount := 0;

Result := BuildFileListInt (AFolder);

end; { function BuildFileList}

function TCustomDirectoryScanner.BuildFileListInt (const AFolder : string) : boolean;

var

sr : SysUtils.TSearchRec;

Canceled : boolean;

begin

Result := true;

if Assigned (OnStartFolderScanning)

then OnStartFolderScanning (Self, AFolder ‘\’);

if SysUtils.FindFirst (AFolder ‘\’ ‘*.*’, faAnyFile, sr) = 0 then try

repeat

try

if (sr.Attr and SysUtils.faDirectory) = SysUtils.faDirectory then begin

if Recursive and (sr.name ‘.’) and (sr.name ‘..’)

then Result := BuildFileListInt (AFolder ‘\’ sr.name);

end

else begin

if fMaskRegExpr.Exec (sr.name) then begin

Canceled := false;

if Assigned (OnFileProceed)

then OnFileProceed (Self, AFolder, sr, Canceled);

if Canceled

then Result := false;

inc (fCount);

end;

end;

except on E:Exception do begin

case MsgBox (‘Replacing error’,

‘Can»t replace file contetn due to error:’#$d#$a#$d#$a

E.message #$d#$a#$d#$a ‘Continue processing ?’,

mb_YesNo or mb_IconQuestion) of

mrYes : Result := false;

>else ; // must be No

end;

end;

end;

Canceled := false;

if Assigned (OnTimeSlice)

then OnTimeSlice (Self, Canceled);

if Canceled

then Result := false;

until not Result or (SysUtils.FindNext (sr) 0);

finally SysUtils.FindClose (sr);

end;

if not Result

then EXIT;

end; { function BuildFileListInt}

constructor TDirectoryScanner.Create;

begin

inherited;

fList := TList.Create;

OnFileProceed := FileProceeding;

fOnTimeSlice := TimeSlice;

end; { of constructor TDirectoryScanner.Create}

destructor TDirectoryScanner.Destroy;

var

i : integer;

begin

for i := fList.Count — 1 downto 0 do

KillItem (i);

fList.Free;

inherited;

end; { of destructor TDirectoryScanner.Destroy}

procedure TDirectoryScanner.KillItem (AIdx : integer);

var

p : PDirectoryScannerItem;

begin

p := PDirectoryScannerItem (fList.Items [AIdx]);

Dispose (p);

fList.Delete (AIdx);

end; { of procedure TDirectoryScanner.KillItem}

function TDirectoryScanner.GetItem (AIdx : integer) : PDirectoryScannerItem;

begin

Result := PDirectoryScannerItem (fList.Items [AIdx]);

end; { of function TDirectoryScanner.GetItem}

procedure TDirectoryScanner.FileProceeding (Sender : TObject; const ABaseFolder : string;

const ASearchRecord : TSearchRec; var ACancel : boolean);

var

p : PDirectoryScannerItem;

begin

p := New (PDirectoryScannerItem);

p.name := ABaseFolder ‘\’ ASearchRecord.name;

fList.Add (p);

end; { of procedure TDirectoryScanner.FileProceeding}

procedure TDirectoryScanner.TimeSlice (Sender : TObject; var ACancel : boolean);

begin

if Count mod 100 = 0

then Sleep (0);

end; { of procedure TDirectoryScanner.TimeSlice}

end.

{/codecitation}

Как подсчитать занимаемое директорией место

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

Источник: http://www.proext.com

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

DirSize(Dir Separator SearchRec.Name);

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;

{/codecitation}