не работает задуманно процедура [D7, XP]
Dima21 (30.03.19 04:37)
Добрый день Мастера Delphi!
Не могу понять почему не работает задуманно процедура, которая выводит в CheckListBox1 список файлов и одновременно удаляет из адреса (полного пути к файлам) путь и имя указанной папки. Например:
путь и имя указанной папки: E:\Копия !!!\
список файлов до процедуры: E:\Копия !!!\1\Точечный рисунок1.bmp
надо чтобы было в списке: 1\Точечный рисунок1.bmp
вот код который я использую:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, CheckLst;
type
TForm1 = class(TForm)
btn1: TButton;
CheckListBox1: TCheckListBox;
btn2: TButton;
procedure btn1Click(Sender: TObject);
procedure btn2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
var i,j:Integer;
procedure SpisokSokrat;//сократить список до неполных адресов
var cou:integer;
s:string;
begin
cou:=Length('E:\Копия !!!\');
Unit1.Form1.CheckListBox1.Items.BeginUpdate;
for i:=Unit1.Form1.CheckListBox1.Count-1 downto 0 do begin
j:=Unit1.Form1.CheckListBox1.Items.IndexOf(Unit1.Form1.CheckListBox1.Items[i]);
if j>=0 then begin Application.ProcessMessages;
s:= Unit1.Form1.CheckListBox1.Items.Strings[i];
Delete(s,1,cou);
Unit1.Form1.CheckListBox1.Items.Strings[i]:=s;
end;//if j>=0 then begin Application.ProcessMessages;
end;//for i:=CheckListBox1.Count-1 downto 0 do begin
Unit1.Form1.CheckListBox1.Items.EndUpdate;
end;//конец/////////////////////////////////////////////////////////////////////
//получение списка всех файлов включая полный адрес
procedure ListFilesInDirectory(Dir: string; Strings: TStrings);
var
rSearchRec: TSearchRec;
begin
if ((Dir = '') or (not Assigned(Strings))) then
Exit;
Dir := IncludeTrailingPathDelimiter(Dir);
if FindFirst(Dir + '\*.*', faAnyFile, rSearchRec) = 0 then
try
repeat
if ((rSearchRec.Name <> '.') and (rSearchRec.Name <> '..')) then
if (rSearchRec.Attr and faDirectory) <> 0 then begin
Application.ProcessMessages;
ListFilesInDirectory(Dir+rSearchRec.Name, Strings);
end
else begin
Application.ProcessMessages;
Strings.Add(Dir+rSearchRec.Name);
end;
until FindNext(rSearchRec) <> 0;
finally
FindClose(rSearchRec);
end;
end;//конец/////////////////////////////////////////////////////////////////////
//получение списка всех файлов с сокращенным адресом
procedure ListFilesInDirectoryMenus(Dir: string; Strings: TStrings);
var
rSearchRec: TSearchRec;
cou:Integer;
s:string;
begin
if ((Dir = '') or (not Assigned(Strings))) then
Exit;
Dir := IncludeTrailingPathDelimiter(Dir);
if FindFirst(Dir + '\*.*', faAnyFile, rSearchRec) = 0 then
try
repeat
if ((rSearchRec.Name <> '.') and (rSearchRec.Name <> '..')) then
if (rSearchRec.Attr and faDirectory) <> 0 then begin
Application.ProcessMessages;
ListFilesInDirectory(Dir+rSearchRec.Name, Strings);
end
else begin
Application.ProcessMessages;
cou:=Length(Dir+'\');
s:=(Dir+rSearchRec.Name);
Delete(s,1,cou);
Strings.Add(s);
end;
until FindNext(rSearchRec) <> 0;
finally
FindClose(rSearchRec);
end;
end;//конец/////////////////////////////////////////////////////////////////////
procedure TForm1.btn1Click(Sender: TObject);//работает
begin
ListFilesInDirectory('E:\Копия !!!\', CheckListBox1.Items);
SpisokSokrat;//сокращает список до неполных адресов
end;
procedure TForm1.btn2Click(Sender: TObject);//не работает
begin
ListFilesInDirectoryMenus('E:\Копия !!!\', CheckListBox1.Items)
end;
end.
Моя объедененная процедура ListFilesInDirectoryMenus почему-то выводит список с полными адресами, а не с сокращенными. И даже переменная cou почему-то не считается (я выводил ее в список вместе с переменной s).
Может кто знает почему не работает ListFilesInDirectoryMenus ?
Буду благодарен за помощь или подсказку. Заранее спасибо!
dmk © (30.03.19 11:34) [1]
Сделайте код как ConsoleApp. Так проверить сложно.
Научитесь пользоваться пошаговой отладкой (F7, F8) и смотрите что происходит в переменных.
-> 'E:\Копия !!!\' <- Пользуйтесь константами. Набивая в нескольких местах одно и то же можно ошибиться.
manaka © (30.03.19 15:34) [2]
> Моя объедененная процедура ListFilesInDirectoryMenus почему-
> то выводит список с полными адресами
на первый взгляд:
> procedure TForm1.btn2Click(Sender: TObject);//не работает
> begin
> ListFilesInDirectoryMenus('E:\Копия !!!\', CheckListBox1.
> Items)
> end;
> procedure ListFilesInDirectoryMenus(Dir: string; Strings:
> TStrings);
> ...
> s:=(Dir+rSearchRec.Name);
> Strings.Add(s); \\ может таки Strings.Add(rSearchRec.Name) ???
Пардон, если глупость пишу, глянула текст и бросилось в глаза
manaka © (30.03.19 15:36) [3]
Вижу, где ошиблась. Еще раз пардон.
Германн © (31.03.19 02:30) [4]
> Dir := IncludeTrailingPathDelimiter(Dir);
> if FindFirst(Dir + '\*.*', faAnyFile, rSearchRec) = 0 then
И нафига дважды добавлять слэш?
manaka © (31.03.19 10:39) [5]
> cou:=Length(Dir+'\');
> s:=(Dir+rSearchRec.Name);
> Delete(s,1,cou);
тоже непонятно зачем
Плохиш © (31.03.19 16:08) [6]
> Unit1.Form1.CheckListBox1.Items.BeginUpdate;
дальше читать не стал.
Dima21 (01.04.19 05:07) [7]
При нажатии кнопки btn1 сначала добавляютя в CheckListBox1 файлы с полным адресом (с помощью процедурыListFilesInDirectory), а потом все записи в CheckListBox1 с помощью процедуры SpisokSokrat сокращаются (выводятся без указанной папки) --- и все это работает как надо (даже с заменой пути к папке на переменную с путем к папке).
А вот при нажатии кнопки btn2 используется объедененная процедура ListFilesInDirectoryMenus (выполняющая тоже самое что и при нажатиии на btn1) --- и это не работает как надо (а надо что-бы за один заход выполнялось то, что выполняется при нажатии кнопки btn1 - это должно экономить время т.к. объем запесей велик).
manaka © (01.04.19 10:41) [8]
если работает
> //получение списка всех файлов включая полный адрес
> procedure ListFilesInDirectory(Dir: string; Strings: TStrings);
>
замени в ней
Strings.Add(Dir+rSearchRec.Name);
на
Strings.Add(rSearchRec.Name);
и будет тебе счастье
наверное
ВладОшин © (01.04.19 22:14) [9]
type
TListBox = class(StdCtrls.TListBox)
public
FSuperCut: integer;
procedure SuperAdd(S: string);
end;
TForm1 = class(TForm)
lb1: TListBox;
btn1: TButton;
procedure btn1Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btn1Click(Sender: TObject);
var
Dir: string;
//ïîëó÷åíèå ñïèñêà âñåõ ôàéëîâ âêëþ÷àÿ ïîëíûé àäðåñ
procedure ListFilesInDirectory(Dir: string; LB: TListBox);
var
rSearchRec: TSearchRec;
begin
if ((Dir = '') or (not Assigned(LB))) then
Exit;
Dir := IncludeTrailingPathDelimiter(Dir);
if FindFirst(Dir + '\*.*', faAnyFile, rSearchRec) = 0 then
try
repeat
if ((rSearchRec.Name = '.') or (rSearchRec.Name = '..')) then
Continue;
if (rSearchRec.Attr and faDirectory) <> 0 then
begin
Application.ProcessMessages;
ListFilesInDirectory(Dir + rSearchRec.Name, LB);
end
else
begin
Application.ProcessMessages;
lb1.SuperAdd(Dir + rSearchRec.Name);
end;
until FindNext(rSearchRec) <> 0;
finally
FindClose(rSearchRec);
end;
end; //êîíåö/////////////////////////////////////////////////////////////////////
begin
Dir := 'C:\delphi_work\!!!SHARED_UNIT!!!';
lb1.FSuperCut := Length(Dir);
ListFilesInDirectory( Dir, lb1);
end;
{ TListBox }
procedure TListBox.SuperAdd(S: string);
begin
Items.Add(Copy(S, FSuperCut, Length(s) - FSuperCut));
end;
ВладОшин © (02.04.19 09:59) [10]
еще интереснее аля так
type
TListBox = class(StdCtrls.TListBox)
public
FCutThisOnAdd: string;
procedure SuperAdd(S: string);
end;
.......
procedure TListBox.SuperAdd(S: string);
begin
stringreplace(s, FCutThisOnAdd,'',[rfReplaceAll])
Items.Add(s);
end;
или даже перекрыть Add, а не писать SuperAdd
т.е. заданный шаблон FCutThisOnAdd автоматом отрезается при добавлении, в т.ч. из середины/конца и т.п.
А если не задан - то обычное добавление будет
ухты © (02.04.19 17:05) [11]
> SuperAdd
на все 100 )
KilkennyCat © (03.04.19 01:15) [12]
repeat
if ((rSearchRec.Name = '.') or (rSearchRec.Name = '..')) then
???
Continue;
if (rSearchRec.Attr and faDirectory) <> 0 then
begin
Application.ProcessMessages;
ListFilesInDirectory(Dir + rSearchRec.Name, LB);
end
else
begin
Application.ProcessMessages;
ВладОшин © (03.04.19 08:55) [13]
> if ((rSearchRec.Name = '.') or (rSearchRec.Name = '..'))
> then
> ???
> Continue;
не нравится отступать в коде
if ((rSearchRec.Name <> '.') and (rSearchRec.Name <> '..')) then
if
эквивалентно
if ((rSearchRec.Name = '.') or (rSearchRec.Name = '..')) then
продолжить со следующим i
и далее с таким же отступом можно писать, не отступая вправо еще раз
Даешь только левые идеи!))))))))))
>> Application.ProcessMessages;
надоело причесывать, копипастнул тупо )
KilkennyCat © (03.04.19 20:20) [14]
> > then
> > ???
> > Continue;
не нравится отступать в коде
дело не в отступе.
> надоело причесывать, копипастнул тупо )
тупое копипасте не может породить нетупое )
Dima21 (04.04.19 10:07) [15]
Добрый день Мастера Delphi.
запись номер 9 не работает - выдает список с полными адресами (а №10 мне не подойдет) вот код:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, CheckLst;
type
TListBox = class(StdCtrls.TListBox)
public
FSuperCut:integer;
procedure SuperAdd(S: string);
end;
TForm1 = class(TForm)
ListBox1: TListBox;
btn3: TButton;
procedure FormCreate(Sender: TObject);
procedure btn3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
var FSuperCut:Integer;
MyFolder:string;
procedure TListBox.SuperAdd(S: string);
begin
//Delete(s,1,FSuperCut);
//Items.Add(S);//-пробовал даже так и результа нет
Items.Add(Copy(S, FSuperCut, Length(s) - FSuperCut));
end;
procedure ListFilesInDirectory(Dir: string; LB: TListBox);
var
rSearchRec: TSearchRec;
begin
if ((Dir = '') or (not Assigned(LB))) then
Exit;
Dir := IncludeTrailingPathDelimiter(Dir);
if FindFirst(Dir + '\*.*', faAnyFile, rSearchRec) = 0 then
try
repeat
if ((rSearchRec.Name = '.') or (rSearchRec.Name = '..')) then
Continue;
if (rSearchRec.Attr and faDirectory) <> 0 then
begin
Application.ProcessMessages;
ListFilesInDirectory(Dir + rSearchRec.Name, LB);
end
else
begin
Application.ProcessMessages;
Unit1.Form1.ListBox1.SuperAdd(Dir + rSearchRec.Name);
end;
until FindNext(rSearchRec) <> 0;
finally
FindClose(rSearchRec);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
MyFolder:='E:\Копия !!!\';
end;
procedure TForm1.btn3Click(Sender: TObject);
begin
FSuperCut := Length(MyFolder);
ListFilesInDirectory3(MyFolder, ListBox1);
end;
end.
В чём дело не пойму - может я что-то накасячил?
Плохиш © (04.04.19 10:49) [16]
> procedure TListBox.SuperAdd(S: string);
> begin
> //Delete(s,1,FSuperCut);
> //Items.Add(S);//-пробовал даже так и результа нет
>
> Items.Add(Copy(S, FSuperCut, Length(s) - FSuperCut));
>
> end;
>
ваш FSuperCut равен нулю, как вы и установили.
ВладОшин © (04.04.19 12:39) [17]
А где тут запись №9?
еще раз копипастну
type
TListBox = class(StdCtrls.TListBox)
private
FMyFolder: string;
FLenMyFolder: Integer;
procedure SetMyFolder(const Value: string);
public
procedure MyAdd(S: string);
property MyFolder: string read FMyFolder write SetMyFolder;
end;
TForm1 = class(TForm)
btn3: TButton;
ListBox1: TListBox;
procedure btn3Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure ListFilesInDirectory(Dir: string; LB: TListBox);
var
rSearchRec: TSearchRec;
i: Integer;
begin
if ((Dir = '') or (not Assigned(LB))) then
Exit;
Dir := IncludeTrailingPathDelimiter(Dir);
if FindFirst(Dir + '\*.*', faAnyFile, rSearchRec) = 0 then
try
i := 0;
repeat
if ((rSearchRec.Name = '.') or (rSearchRec.Name = '..')) then
Continue;
if (rSearchRec.Attr and faDirectory) = 0 then
LB.MyAdd(Dir + rSearchRec.Name) else
ListFilesInDirectory(Dir + rSearchRec.Name, LB);
inc(i);
if i mod 10 = 0 then
Application.ProcessMessages;
until FindNext(rSearchRec) <> 0;
finally
FindClose(rSearchRec);
end;
end;
procedure TForm1.btn3Click(Sender: TObject);
begin
ListBox1.MyFolder := 'D:\UltraVNC\';
ListFilesInDirectory(ListBox1.MyFolder, ListBox1) ;
end;
{ TListBox }
procedure TListBox.SetMyFolder(const Value: string);
begin
FMyFolder := Value;
FLenMyFolder := Length(Value);
end;
procedure TListBox.MyAdd(S: string);
begin
Items.Add(Copy(S, FLenMyFolder, Length(s) - FLenMyFolder));
end;
Плохиш © (04.04.19 13:18) [18]
чёт я добрый сегодня
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
FLenMyFolder: Integer;
procedure ListFilesInDirectory(Dir: string; LB: TListBox);
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.ListFilesInDirectory(Dir: string; LB: TListBox);
var
rSearchRec: TSearchRec;
i: Integer;
str: String;
begin
if ((Dir = '') or (not Assigned(LB))) then
Exit;
Dir := IncludeTrailingPathDelimiter(Dir);
if FindFirst(Dir + '\*.*', faAnyFile, rSearchRec) = 0 then
try
i := 0;
repeat
if ((rSearchRec.Name = '.') or (rSearchRec.Name = '..')) then
Continue;
if (rSearchRec.Attr and faDirectory) = 0 then
begin
str := Dir + rSearchRec.Name;
LB.AddItem(copy(str, FLenMyFolder + 1, Length(str) - FLenMyFolder), nil);
end
else
ListFilesInDirectory(Dir + rSearchRec.Name, LB);
inc(i);
if i mod 10 = 0 then
Application.ProcessMessages;
until FindNext(rSearchRec) <> 0;
finally
FindClose(rSearchRec);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
myFolder: String;
begin
myFolder := 'd:\temp\';
FLenMyFolder := Length(myFolder);
ListFilesInDirectory(myFolder, ListBox1);
end;
end.
PS. Какое убожество этот редактор в Delphi 10.3 :-(( А в тёмном режиме вообще вырвиглаз...
kilkennycat © (29.08.19 20:08) [19]
> Плохиш © (04.04.19 13:18) [18]
>
> PS. Какое убожество этот редактор в Delphi 10.3
ST Visual Develop посмотри, и тебе сразу понравится делфевский )
Разрешается использование тегов форматирования текста:
<b>жирный</b> <i>наклонный</i>
<u>подчеркнутый</u>,
а для выделения текста программ, используйте <code> ... </code>
и не забывайте закрывать теги! </b></i></u></code> :)
Наверх 
Чтобы не потерять эту дискуссию, сделайте закладку