Показываем директории в TTreeView

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

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;

{/codecitation}

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

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

Автор: Xavier Pacheco

{

Copyright © 1999 by Delphi 5 Developer’s Guide — Xavier Pacheco and Steve Teixeira

}

unit MainFrm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls, FileCtrl, Grids, Outline, DirOutln;

type

TMainForm = class(TForm)

dcbDrives: TDriveComboBox;

edtFileMask: TEdit;

lblFileMask: TLabel;

btnSearchForFiles: TButton;

lbFiles: TListBox;

dolDirectories: TDirectoryOutline;

procedure btnSearchForFilesClick(Sender: TObject);

procedure dcbDrivesChange(Sender: TObject);

private

FFileName: string;

function GetDirectoryName(Dir: string): string;

procedure FindFiles(APath: string);

end;

var

MainForm: TMainForm;

implementation

{$R *.DFM}

function TMainForm.GetDirectoryName(Dir: string): string;

{ This function formats the directory name so that it is a valid

directory containing the back-slash (\) as the last character. }

begin

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

Result := Dir ‘\’

else

Result := Dir;

end;

procedure TMainForm.FindFiles(APath: string);

{ This is a procedure which is called recursively so that it finds the

file with a specified mask through the current directory and its

sub-directories. }

var

FSearchRec,

DSearchRec: TSearchRec;

FindResult: integer;

function IsDirNotation(ADirName: string): Boolean;

begin

Result := (ADirName = ‘.’) or (ADirName = ‘..’);

end;

begin

APath := GetDirectoryName(APath); // Obtain a valid directory name

{ Find the first occurrence of the specified file name }

FindResult := FindFirst(APath FFileName, faAnyFile faHidden

faSysFile faReadOnly, FSearchRec);

try

{ Continue to search for the files according to the specified

mask. If found, add the files and their paths to the listbox.}

while FindResult = 0 do

begin

lbFiles.Items.Add(LowerCase(APath FSearchRec.Name));

FindResult := FindNext(FSearchRec);

end;

{ Now search the sub-directories of this current directory. Do this

by using FindFirst to loop through each subdirectory, then call

FindFiles (this function) again. This recursive process will

continue until all sub-directories have been searched. }

FindResult := FindFirst(APath ‘*.*’, faDirectory, DSearchRec);

while FindResult = 0 do

begin

if ((DSearchRec.Attr and faDirectory) = faDirectory) and not

IsDirNotation(DSearchRec.Name) then

FindFiles(APath DSearchRec.Name); // Recursion here

FindResult := FindNext(DSearchRec);

end;

finally

FindClose(FSearchRec);

end;

end;

procedure TMainForm.btnSearchForFilesClick(Sender: TObject);

{ This method starts the searching process. It first changes the cursor

to an hourglass since the process may take awhile. It then clears the

listbox and calls the FindFiles() function which will be called

recursively to search through sub-directories }

begin

Screen.Cursor := crHourGlass;

try

lbFiles.Items.Clear;

FFileName := edtFileMask.Text;

FindFiles(dolDirectories.Directory);

finally

Screen.Cursor := crDefault;

end;

end;

procedure TMainForm.dcbDrivesChange(Sender: TObject);

begin

dolDirectories.Drive := dcbDrives.Drive;

end;

end.

{/codecitation}

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

{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}