Последние записи
- TChromium (CEF3), сохранение изображений
- Как в Delphi XE обнулить таймер?
- Изменить цвет шрифта TextBox на форме
- Ресайз PNG без потери прозрачности
- Вывод на печать графического файла
- Взаимодействие через командную строку
- Перенести программу из Delphi в Lazarus
- Определить текущую ОС
- Автоматическая смена языка (раскладки клавиатуры)
- Сравнение языков на массивах. Часть 2
Интенсив по Python: Работа с API и фреймворками 24-26 ИЮНЯ 2022. Знаете Python, но хотите расширить свои навыки?
Slurm подготовили для вас особенный продукт! Оставить заявку по ссылке - https://slurm.club/3MeqNEk
Online-курс Java с оплатой после трудоустройства. Каждый выпускник получает предложение о работе
И зарплату на 30% выше ожидаемой, подробнее на сайте академии, ссылка - ttps://clck.ru/fCrQw
16th
Май
Список URL всего сайта (Delphi)
Posted by obzor under Delphi
Требуется получить все ссылки с сайта из HTML-документа. Никак не получается рекурсия для поиска по всему сайту.
Как-то так:
var
Source: string;
begin
try
Source := IdHTTP1.Get(Edit1.Text);
ListBox1.Clear;
while Pos('href="', Source) <> 0 do begin
Delete(Source, 1, Pos('href="', Source) + Length('href="') - 1);
ListBox1.Items.Add(Copy(Source, 1, Pos('"', Source) - 1));
Application.ProcessMessages;
end;
except
MessageDlg('Произошла ошибка!!!', mtError, [mbOK], 0);
end;
end;
Пару дней назад написал функцию для поиска ссылок. Она находит адреса следующего вида:
<a href="http://site.ru/index.php"> <a href='http://site.ru/index.php'> <a href=http://site.ru/index.php> /index.php ./index.php
К двум последним добавляет домен. http://site.ru
Вот и сам код
PS PosR2L это первая попавшаяся в интернете функция для поиска вхождения символов в строку с конца.
В uses надо подключить StrUtils.
ParsURL(Исходный код страницы, Адрес страницы);
function PosR2L(const FindS, SrcS: string): Integer;
function InvertS(const S: string): string;
var
i, Len: Integer;
begin
Len := Length(S);
SetLength(Result, Len);
for i := 1 to Len do
Result := S[Len - i + 1];
end;
var
ps: Integer;
begin
ps := Pos(InvertS(FindS), InvertS(SrcS));
if ps <> 0 then
Result := Length(SrcS) - Length(FindS) - ps + 2
else
Result := 0;
end;
function ParsURL(Src: string; URLPage: string): string;
var
i, y, r1, r2: integer;
a, url: string;
sl: TStringList;
ur, dm: string;
begin
sl := TStringList.Create;
i := PosEx('/',URLPage,PosEx('://',URLPage)+3);
dm := Copy(URLPage,1,i-1);
i := 1;
ur := Copy(URLPage,1,PosR2L('/',URLPage)-1);
// Вытягиваем все <a ...>...</a>
while PosEx('<a ',Src,i) <> 0 do
begin
i := PosEx('<a ',Src,i)+1;
a := Copy(Src,i-1,PosEx('</a',Src,i)-i+5);
y := PosEx('href',a);
if y = 0 then
Continue;
y := y + 4;
if a[y] <> '=' then
begin
y := PosEx('=',a,y);
if y = 0 then
Continue;
end
else
Inc(y);
if a[y] = ' ' then
inc(y);
if a[y] = '"' then
begin
Inc(y);
url := Copy(a,y,PosEx('"',a,y)-y);
end
else
if a[y] = #39 then
begin
Inc(y);
url := Copy(a,y,PosEx(#39,a,y)-y);
end
else
begin
r1 := PosEx(' ',a,y);
r2 := PosEx('>',a,y);
if (r1 > r2)or(r1 = 0) then
url := Copy(a,y,r2-y)
else
url := Copy(a,y,r1-y);
end;
if url = '' then
Continue;
url := StringReplace(url,#13,'',[rfReplaceAll]);
url := StringReplace(url,#10,'',[rfReplaceAll]);
if Copy(url,1,4) <> 'http' then
if url[1] = '/' then
begin
url := dm + url;
end
else
if (url[1] = '.') then
begin
if url[2] = '/' then
url := ur + Copy(url,2,Length(url))
end else
begin
url := ur + '/' + url;
end;
if url = '' then
Continue;
sl.Add(url);
end;
Result := sl.Text;
sl.Free;
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
http: TIdHTTP;
begin
http := TIdHTTP.Create;
s := http.Get('http://rutracker.org/forum/index.php');
memo1.Text := ParsURL(s,http.URL.URI); //
http.Free;
end;
PPS. Может быть в Delphi есть стандартная функция поиска с конца строки?
Получится примерно так.
Осталось только добавить проверку на повтор ссылок.
sl — Это список с ссылками
Item — Последняя проверенная строка
var
Item: integer;
sl: TStringList;
http: TIdHTTP;
procedure NameProcedure;
var
i : integer;
s: string;
begin
while true do
for i := 0 to sl.count - 1 do
begin
// ЕСли урл проверялся, пропускаем
if i <= item then
Continue;
item := i;
// Копирование адреса страницы
s := sl.strings;
// Загрузка новой страницы
s := http.Get(s);
s := ParsURL(s,http.URL.URI);
sl.add(s);
end;
end;
Случайные статьи
Купить рекламу на сайте за 1000 руб
пишите сюда - alarforum@yandex.ru
Да и по любым другим вопросам пишите на почту
пеллетные котлы
Пеллетный котел Emtas
Наши форумы по программированию:
- Форум Web программирование (веб)
- Delphi форумы
- Форумы C (Си)
- Форум .NET Frameworks (точка нет фреймворки)
- Форум Java (джава)
- Форум низкоуровневое программирование
- Форум VBA (вба)
- Форум OpenGL
- Форум DirectX
- Форум CAD проектирование
- Форум по операционным системам
- Форум Software (Софт)
- Форум Hardware (Компьютерное железо)