Простенький пример выполнения запроса в Wininet

По просьбе трудящихся выкладываю вот такой простенький исходник программки с помощью, которой можно получить ТИЦ и PR  сайта путем выполнения POST запроса

Скрин примера

unit main;

interface

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

type
  TfrmMain = class(TForm)
    Button1: TButton;
    edtSite: TEdit;
    lblTC_PR: TLabel;
    lblSite: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}
const
  // дефолное название приложение через которое якобы происходит соединение
  DefaultAppName ='Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.2.6) Gecko/20100625 Firefox/3.6.6';

function exam(msData: TMemoryStream):string;
  function DataAvailable(hRequest: pointer; out Size: cardinal): BOOLEAN;
  begin
    Result := WinInet.InternetQueryDataAvailable(hRequest, Size, 0, 0);
  end;
var
  hInternet, hConnect, hRequest: pointer;
  dwBytesRead, i, L: cardinal;
  sTemp: AnsiString; // текст страницы
  sHeader: String;
begin
  Result:='';
  try
    hInternet := InternetOpen(PChar(DefaultAppName),INTERNET_OPEN_TYPE_PRECONFIG, Nil, Nil, 0);
    if Assigned(hInternet) then
    begin
      // Открываем сессию
      //http://ip-whois.net/pr_cy_check.php обратите внимание как записал в коде адрес сайта
      hConnect := InternetConnect(hInternet, PWideChar('ip-whois.net'),INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
      if Assigned(hConnect) then
      begin
        // открываем запрос
        hRequest := HttpOpenRequest(hConnect, PWideChar('POST'),
          PWideChar('/pr_cy_check.php'), HTTP_VERSION, nil, Nil,
          INTERNET_FLAG_KEEP_CONNECTION, 1);

        sHeader:='Accept: */*';
        HttpAddRequestHeaders(hRequest, Pointer(sHeader), Length(sHeader), HTTP_ADDREQ_FLAG_ADD);
        sHeader:= 'Content-Type: application/x-www-form-urlencoded';
        HttpAddRequestHeaders(hRequest, Pointer(sHeader), Length(sHeader), HTTP_ADDREQ_FLAG_ADD);
        sHeader:= 'Accept-Language: ru-ru,ru;q=0.8,en-us;q=0.5,en;q=0.3';
        HttpAddRequestHeaders(hRequest, Pointer(sHeader), Length(sHeader), HTTP_ADDREQ_FLAG_ADD);
        sHeader:= 'Accept-Charset: windows-1251,utf-8;q=0.7,*;q=0.7';
        HttpAddRequestHeaders(hRequest, Pointer(sHeader), Length(sHeader), HTTP_ADDREQ_FLAG_ADD);

        if Assigned(hRequest) then
        begin
          // Отправляем запрос
          i := 1;
          if HttpSendRequest(hRequest, nil, 0, msData.memory, msData.Size) then
          begin
            repeat
              DataAvailable(hRequest, L); // Получаем кол-во принимаемых данных
              if L = 0 then
                break;
              SetLength(sTemp, L + i);
              if not InternetReadFile(hRequest, @sTemp[i], sizeof(L),dwBytesRead) then
                break; // Получаем данные с сервера
              inc(i, dwBytesRead);
            until dwBytesRead = 0;
            sTemp[i] := #0;
            Result:=sTemp;
          end;
        end;
      end;
    end;
  finally
    InternetCloseHandle(hRequest);
    InternetCloseHandle(hConnect);
    InternetCloseHandle(hInternet);
  end;
end;

function TC_PR(aValue:string):string;
var
  i:Integer;
  TC,PR:string;
begin
  i:=AnsiPos('</h2><h3>ТИЦ: ',aValue);
  if i=0 then
  begin
    Result:='Неизвестно!';
    Exit;
  end;
  Delete(aValue,1,i+length('</h2><h3>ТИЦ: ')-1);
  i:=AnsiPos('</h3><h3>PR: ',aValue);
  TC:=Copy(aValue,0,i-1);
  Delete(aValue,1,i+length('</h3><h3>PR: ')-1);
  i:=AnsiPos('</h3><br>',aValue);
  PR:=Copy(aValue,0,i-1);
  Result:='ТИЦ '+TC+' PR '+PR;
end;

procedure TfrmMain.Button1Click(Sender: TObject);
var
  zapros:TStringStream;
  sTemp:string;
begin
  zapros:=TStringStream.Create;
  zapros.WriteString('T1='+edtSite.Text+'&B1=T2=%D3%E7%ED%E0%F2%FC+%D2%C8%D6+%E8+PR');
  sTemp:=exam(zapros);
  if Length(sTemp)>0 then
    lblTC_PR.Caption:=TC_PR(sTemp);

  zapros.Free;
end;

end.

Скачать исходник проекта можно отсюда Download

Конкурс на WebDelphi с неограниченным призовым фондом.

Хочу поздравить всех со вторым днем зимы и сообщить о прекрасном известии.

1 декабря 2010 года (т.е. вчера) начался конкурс по программированию с неограниченным призовым фондом ( все зависит от количества принявших в нем участие людей( 50 рублей за каждого нового конкурсанта), но начальный призовой фонд составляет 1000 рублей ).

Принять участие в конкурсе могут все программисты круг не ограничивается только Delphi (нас ни так много, но мы в тельняшках).

Если вы не профессионал то не беда, программу будут оценивать только по ее функционалу далекие от программирования люди следовательно и у вас есть шанс занять почетное первое место в этом конкурсе.

Правила и требования для участия в конкурсе можете просмотреть на сайте автора конкурса!


Желаю удачи!!!