Конференция "Начинающим" » не работает задуманно процедура [D7, XP]
 
  • Dima21 (30.03.19 04:37) [0]
    Добрый день Мастера 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;
    //&#239;&#238;&#235;&#243;&#247;&#229;&#237;&#232;&#229; &#241;&#239;&#232;&#241;&#234;&#224; &#226;&#241;&#229;&#245; &#244;&#224;&#233;&#235;&#238;&#226; &#226;&#234;&#235;&#254;&#247;&#224;&#255; &#239;&#238;&#235;&#237;&#251;&#233; &#224;&#228;&#240;&#229;&#241;

     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; //&#234;&#238;&#237;&#229;&#246;/////////////////////////////////////////////////////////////////////

    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;
    не нравится отступать в коде

    дело не в отступе.


    > надоело причесывать, копипастнул тупо )

    тупое копипасте не может породить нетупое )
 
Конференция "Начинающим" » не работает задуманно процедура [D7, XP]
Есть новые Нет новых   [98603   +20][b:0.001][p:0.007]