Форум программистов [Powered by Invision Power Board]

Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате

Форум программистов > Delphi: Общие вопросы > Найти повторяющиеся строки.

Автор: Elfebet 23.8.2006, 14:30

Заношу в лист бокс пути:
c:\windows\file.txt
c:\windows\system\
c:\windows\system\filenew.txt
c:\windows\temp\1.txt
c:\windows\temp\1.txt
и мне надо найти повторяющиеся символы, вот из этого примера я должне получить результат "c:\windows\". как мне это сделать? подскажите плиз, очень нужно! smile

Автор: Yanis 23.8.2006, 14:45

Если не смущает, то что список будет сортированым, то:

Код

var
  sl: TStringList;
begin
  sl := TStringList.Create;
  sl.Sorted := True;

  sl.Duplicates := dupIgnore;
  sl.Assign(ListBox1.Items);

  ListBox1.Items.Assign(sl);

  FreeAndNil(sl);
end;

Автор: Elfebet 23.8.2006, 14:59

Yanis, твой пример не для моей задачи, в моем случае он вообще ничего не делает!

Автор: dumb 23.8.2006, 15:11

Elfebet, ты свою задачу дюже криво описал. почему должно выбраться "c:\windows", а не "c:\" или "c:\windows\temp", скажем? и сколько строк нужно, чтобы подстрока считалась повторяющейся? - все, что есть в листбоксе?

Автор: Yanis 23.8.2006, 15:16

Цитата(Elfebet @ 23.8.2006, 15:30

)

из этого примера я должне получить результат "c:\windows\".

Вот теперь понял, что требуется по настоящему smile

Автор: Elfebet 23.8.2006, 15:18

c:\windows - должно вернуть потому что оно во всех строчка повторяется, если добавить еще строку к примеру c:\program files, тогда должно вернуть c:\, если ничего не повторяется то естественно ничего не вернуть.

Автор: Yanis 23.8.2006, 15:43

Извиняюсь, что без комментариев.

Код

procedure TForm1.Button2Click(Sender: TObject);

  function AllEquals(const sl: TStrings): Boolean;
  var
    i: Integer;
  begin
    Result := False;
    for i := 0 to sl.Count - 2 do
      begin
        if sl.Strings[i] <> sl.Strings[i+1] then
          Exit;
      end;

    Result := True;
  end;

  procedure DeleteLast(const sl: TStrings);
  var
    i, p: Integer;
  begin
    for i := 0 to sl.Count - 1 do
      begin
        if sl.Strings[i][Length(sl.Strings[i])] = '\' then
          sl.Strings[i] := Copy(sl.Strings[i], 1, Length(sl.Strings[i]) - 1);

        p := LastDelimiter('\', sl.Strings[i]);
        sl.Strings[i] := Copy(sl.Strings[i], 1, p);
      end;
  end;
begin
  while not AllEquals(ListBox1.Items) do
    DeleteLast(ListBox1.Items);
end;

Добавлено @ 15:44
Мой ListBox:

Цитата

C:\Documents and Settings\Yanis123\Cookies\yanis@nnm[1].txt
C:\Documents and Settings\Yanis\Cookies\yanis@spylog[2].txt
C:\Documents and Settings\Yanis\Cookies\yanis@empo[1].txt
C:\Documents and Settings\Yanis\Cookies\[email protected][2].txt
C:\Documents and Settings\Yanis\Cookies\[email protected][2].txt

Результат:

Цитата

C:\Documents and Settings\
C:\Documents and Settings\
C:\Documents and Settings\
C:\Documents and Settings\
C:\Documents and Settings\

Автор: volvo877 23.8.2006, 16:36

Elfebet, если нужен еще вариант:

Код

procedure TForm1.Button1Click(Sender: TObject);
var
  i, p: integer;
  s: string;
begin
  // В Edit2 будет храниться результат...
  edit2.Text := listbox1.Items.Strings[0];
  if edit2.Text[length(edit2.text)] <> '\' then
    edit2.Text := edit2.Text + '\';

  i := 0;
  while (i < listbox1.Items.Count) and (length(edit2.text) > 0) do begin
    s := edit2.Text;
    if (s <> '') and (Pos(s, listbox1.Items.Strings[i]) = 0) then
      while Pos(s, listbox1.Items.Strings[i]) = 0 do begin
        p := length(s) - 1;
        while (p > 0) and (s[p] <> '\') do dec(p);
        delete(s, p + 1, length(s) - p);
        edit2.text := s;

        if s = '' then break;

      end;
    inc(i);
  end;
end;

Автор: Elfebet 23.8.2006, 16:52

Спасибо Вам большое!
volvo877, мне твой вариант больше понравился.
Yanis, не в обиду. smile

Автор: Yanis 23.8.2006, 17:01

Цитата(Elfebet @ 23.8.2006, 17:52

)

Yanis, не в обиду.

Без проблем.

Автор: dumb 4.9.2006, 09:30

наткнулся тут еще на один вариант решения: http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/shlwapi/path/pathcommonprefix.asp