Мастера DELPHI, Delphi programming community Рейтинг@Mail.ru Титульная страница Поиск, карта сайта Написать письмо 
| Новости |
Новости сайта
Поиск |
Поиск по лучшим сайтам о Delphi
FAQ |
Огромная база часто задаваемых вопросов и, конечно же, ответы к ним ;)
Статьи |
Подборка статей на самые разные темы. Все о DELPHI
Книги |
Новинки книжного рынка
Новости VCL
Обзор свежих компонент со всего мира, по-русски!
|
| Форумы
Здесь вы можете задать свой вопрос и наверняка получите ответ
| ЧАТ |
Место для общения :)
Орешник
Коллекция курьезных вопросов из форумов
Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / rsdn.org

 
Чтобы не потерять эту дискуссию, сделайте закладку « предыдущая ветвь | форум | следующая ветвь »

не работает задуманно процедура [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 посмотри, и тебе сразу понравится делфевский )


версия для печати

Написать ответ

Ваше имя (регистрация  E-mail 







Разрешается использование тегов форматирования текста:
<b>жирный</b> <i>наклонный</i> <u>подчеркнутый</u>,
а для выделения текста программ, используйте <code> ... </code>
и не забывайте закрывать теги! </b></i></u></code> :)


Наверх

  Рейтинг@Mail.ru     Титульная страница Поиск, карта сайта Написать письмо