Парсинг ников пользователей для форумов

Напарсить где-нибудь ников пользователей еще проще, чем напарсить аватаров. Для этого достаточно зайти на форум или сайт, на котором есть поиск пользователей. Желательно, чтобы там был выбор по полу. Вот, например, на сайте НайтПати зарегистрированы тысячи ночных тусовщиков из разных городов России. Идем на страницу поиска юзеров http://msk.nightparty.ru/users.php.

Изучаем get-запрос скрипта поиска, смотрим, что передается, смотрим идентификатор России и города Москвы. Смотрим идентификатор пола. Смотрим, как организована пагинация. В принципе, больше ничего и не надо.

Потом составляем какое-нибудь регулярное выражение для нахождения ников на конкретном сайте.

Рисуем формочку:
Кроме двух кнопок больше ничего и не надо. Вторая кнопка тоже исключительно для самых нетерпеливых, которым лень подождать, когда появится сообщение "Все сделано".

Привожу полностью рабочий код всего юнита целиком:

unit UserFinderU;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, Urlmon;

const
  GirlUserListFileName = 'g_users.txt';
  BoyUserListFileName = 'b_users.txt';
  GirlSearchURL = 'http://msk.nightparty.ru/users.php?action=dosearch&country_id=103&city_id=1043&user_sex=2&page=[PageNum]';
  BoySearchURL = 'http://msk.nightparty.ru/users.php?action=dosearch&country_id=103&city_id=1043&user_sex=1&page=[PageNum]';
  FindUserRegExp = 'style="padding-left:8px;"><a href="http://(?:.*?)\.at\.nightparty\.ru/"><b>(.*?)</b>';

function DownloadFile(SourceFile, DestFile: string): Boolean;

type
  TForm1 = class(TForm)
    btnStart: TButton;
    btnStop: TButton;
    cbGender: TComboBox;
    Label1: TLabel;
    procedure btnStartClick(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  vStop : boolean;

implementation

uses
  VBScript_RegExp_55_TLB;

{$R *.dfm}

procedure TForm1.btnStartClick(Sender: TObject);
var
  i, j, t,
  PageNum   : integer;
  FName,
  SearchURL,
  LinkStr,
  sFileName,
  currBody
            : string;
  NextPage  : boolean;
  SLBody    : TStringList;
  RE        : TRegExp;
  mc            : MatchCollection;
  sm            : SubMatches;
  mm            : Match;
  f           : TextFile;
  UsersList   : TStringList;
begin
  if cbGender.ItemIndex = 0 then
    begin
      FName := GirlUserListFileName;
      SearchURL := GirlSearchURL;
    end;
  if cbGender.ItemIndex = 1 then
    begin
      FName := BoyUserListFileName;
      SearchURL := BoySearchURL;
    end;

  PageNum := 0;
  NextPage := true;
  UsersList := TStringList.Create;

  //======================

  vStop := false;
  while NextPage and not vStop do
    begin
      LinkStr := StringReplace(SearchURL,'[PageNum]',IntToStr(PageNum),[rfIgnoreCase]);
      try
        SLBody:=TStringList.Create;
        RE := TRegExp.Create(Self);

        sFileName:=ExtractFilePath(Application.ExeName) + 'cache.txt';
        currBody:='';
        if DownloadFile(LinkStr,sFileName) then
          SLBody.LoadFromFile(sFileName);
        currBody:=SLBody.Text;
        DeleteFile(sFileName);

        // ищутся пользователи
        RE.Pattern := FindUserRegExp;
        RE.Global := true;
        RE.IgnoreCase := true;
        RE.Multiline := true;

        mc := RE.Execute(currBody) as MatchCollection;
        for j := 0 to mc.Count-1 do
          begin
            mm := mc[j] as Match;
            sm := mm.SubMatches as SubMatches;
            UsersList.Add(sm.Item[0]);
          end;
        if mc.Count = 0 then NextPage := false;

      finally
        SLBody.Free;
        mm := nil;
        sm := nil;
        mc := nil;
        RE.Free;
      end;
      inc(PageNum);

      for t := 0 to 10 do
        begin
          Sleep(100);
          Application.ProcessMessages;
        end;
    end;

  UsersList.SaveToFile(ExtractFilePath(Application.ExeName)+FName);

  UsersList.Clear;
  UsersList.Free;
  ShowMessage('Все сделано.');
end;

procedure TForm1.btnStopClick(Sender: TObject);
begin
  vStop := true;
end;

function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
   try
     Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0,
       nil) = 0;
   except
     Result := False;
   end;
end;

end.

Далее запускаем программу и занимаемся другими делами (например, продолжаем программировать свой другой-супер-мега-проект-который-принесет-кучу-БАБЛА %D ). Паузу между запросами я поставила по секунде, так что минут 15 уйдет на полное сканирование всех страниц с пользователями одного пола. Итак, через некоторое время мы получим файлики с мужскими и женскими никами, тех и других тысяч по 12. Можем использовать их для своих чистых дел). Чтобы лишний раз не грузить всуе упомянутый мной сайт, можете взять готовые списки у меня. Обращайтесь на почту, указанную в профиле.

=====

Немного о блоге. Приятно видеть, что количество подписчиков растет. Постараюсь в ближайшее время привести его в более удобочитаемый вид. Например, прятать часть поста под кат, чтобы главная страница не разъезжалась до таких размеров, до каких она сейчас разъехалась. Даже такое элементарное действие стандартными средствами блоггера не сделать. Но я уже нашла способ, так что остается только опробовать его на практике.

=====

Если вы пришли на блог с поисковика в надежде скачать базу ников, то вам нужно в другое место :)

Статьи схожей тематики: