Работа с URL в DELPHI

Как получить активный URL из браузера

Приводимая здесь функция показывает, как Ваше приложение может извлечь из браузера (IE или Netscape) URL , как, например, это делает аська.
Совместимость: Delphi 4.x (или выше)
Не забудьте добавить DDEMan в Ваш проект!

Собственно сам исходничек функции:

uses windows, ddeman, ......

function Get_URL(Servicio: string): String;
var
   Cliente_DDE: TDDEClientConv;
   temp:PChar;      //<<-------------------------This is new
begin
    Result := '';
    Cliente_DDE:= TDDEClientConv.Create( nil );
     with Cliente_DDE do
        begin
           SetLink( Servicio,'WWW_GetWindowInfo');
           temp := RequestData('0xFFFFFFFF');
           Result := StrPas(temp);
           StrDispose(temp);  //<<-Предотвращаем утечку памяти
           CloseLink;
        end;
      Cliente_DDE.Free;
end;

procedure TForm1.Button1Click(Sender);
begin
   showmessage(Get_URL('Netscape'));
      или
   showmessage(Get_URL('IExplore'));
end;

Взять часть URL, которая следует после названия сайта

{
  InternetCrackUrl() takes a URL as a parameter and breaks it down into components,
  which are then accessible via the TURLComponents structure.

  InternetCrackUrl() zerlegt eine URL in seine Komponenten, welche dann ьber die
  TURLComponents Struktur zugдnglich sind.
}

uses
   WinInet;

procedure TForm1.Button1Click(Sender: TObject);
var
   aURLC: TURLComponents;
const
   TEST_URL = 'http://www.swissdelphicenter.ch/de/tipsindex.php';
begin
   FillChar(aURLC, SizeOf(TURLComponents), 0);
   with aURLC do
   begin
     lpszScheme := nil;
     dwSchemeLength := INTERNET_MAX_SCHEME_LENGTH;
     lpszHostName := nil;
     dwHostNameLength := INTERNET_MAX_HOST_NAME_LENGTH;
     lpszUserName := nil;
     dwUserNameLength := INTERNET_MAX_USER_NAME_LENGTH;
     lpszPassword := nil;
     dwPasswordLength := INTERNET_MAX_PASSWORD_LENGTH;
     lpszUrlPath := nil;
     dwUrlPathLength := INTERNET_MAX_PATH_LENGTH;
     lpszExtraInfo := nil;
     dwExtraInfoLength := INTERNET_MAX_PATH_LENGTH;
     dwStructSize := SizeOf(aURLC);
   end;
   if InternetCrackUrl(PChar(TEST_URL), Length(TEST_URL), 0, aURLC) then
   begin
     ShowMessage(aURLC.lpszUrlPath);
   end;
end;

Вывести типы URL для Internet Explorer

uses registry;

procedure ShowTypedUrls(Urls: TStrings);
var
   Reg: TRegistry;
   S: TStringList;
   i: Integer;
begin
   Reg := TRegistry.Create;
   try
     Reg.RootKey := HKEY_CURRENT_USER;
     if Reg.OpenKey('SoftwareMicrosoftInternet ExplorerTypedURLs', False) then
     begin
       S := TStringList.Create;
       try
         reg.GetValueNames(S);
         for i := 0 to S.Count - 1 do
         begin
           Urls.Add(reg.ReadString(S.Strings[i]));
         end;
       finally
         S.Free;
       end;
       Reg.CloseKey;
     end;
   finally
     Reg.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowTypedUrls(ListBox1.Items);
end;

Извлечь имя файла из строки URL

function ExtractUrlFileName(const AUrl: string): string;
  var
    i: Integer;
  begin
    i := LastDelimiter('/', AUrl);
   Result := Copy(AUrl, i + 1, Length(AUrl) - (i));
  end;

  procedure TForm1.Button1Click(Sender: TObject);
  var
    s: string;
  begin
    s := ExtractUrlFileName('http://www.delphimania.de/index.php');
    ShowMessage(s);  //index.php
end

Как захватить текущий URL из окна Internet Explorer

Описываем две функции GetText и GetURL:

function GetText(WindowHandle: hwnd):string;
var
  txtLength : integer;
  buffer: string;
begin
  TxtLength := SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0, 0);
  txtlength := txtlength + 1;
  setlength (buffer, txtlength);
  sendmessage (WindowHandle,wm_gettext, txtlength, longint(@buffer[1]));
  result := buffer;
end;

function GetURL:string;
var
  ie,toolbar,combo,
  comboboxex,edit,
  worker,toolbarwindow:hwnd;
begin
  ie := FindWindow(pchar('IEFrame'),nil);
  worker := FindWindowEx(ie,0,'WorkerA',nil);
  toolbar := FindWindowEx(worker,0,'rebarwindow32',nil);
  comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil);
  combo := FindWindowEx(comboboxex,0,'ComboBox',nil);
  edit := FindWindowEx(combo,0,'Edit',nil);
  toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil);
  result := GetText(edit);
end;

Ну а затем пользуемся функцией GetURL, например, можем в поле ввода по нажатию на кнопку выводит текущий URL:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text := GetURL;
end;

Как скачать любой URL используя стандартные настройки сети

Начиная с Internet Explorer 3, Microsoft поддерживает очень полезные API, Wininet. Эти функции позволяют использовать все возможности IE, такие как настройки прокси, кэширование файлов и т.д.
Ниже приведён пример использования этих функций для скачивания файла с нужного URL. Это может быть любой доступный URL, ftp://, http://, gopher://, и т.д.
Более подробную информацию об этих функция можно посмотреть в MSDN - Win32 Internet API Functions.

function DownloadFile(const Url: string): string;
var
  NetHandle: HINTERNET;
  UrlHandle: HINTERNET;
  Buffer: array[0..1024] of char;
  BytesRead: cardinal;
begin
  Result := '';
  NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if Assigned(NetHandle) then
  begin

    UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);

    { UrlHandle правильный? Начинаем загрузку }
    if Assigned(UrlHandle) then
    begin
      FillChar(Buffer, SizeOf(Buffer), 0);
      repeat
        Result := Result + Buffer;
        FillChar(Buffer, SizeOf(Buffer), 0);
        InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
      until
        BytesRead = 0;
      InternetCloseHandle(UrlHandle);
    end
    else
    begin
      { UrlHandle неправильный. Генерируем исключительную ситуацию. }
      raise Exception.CreateFmt('Cannot open URL %s', [Url]);
    end;

    InternetCloseHandle(NetHandle);
  end
  else
    { NetHandle недопустимый. Генерируем исключительную ситуацию }
    raise Exception.Create('Unable to initialize Wininet');
end;

//-------------------------------------------------

implementation

uses
  SysUtils,Windows,ShlObj;

function NetShareAdd(ServerName:PChar; //указатель на имя компьютера, например 'Server'#0, если свой, то можно nil
  Level:Word; //уровень структуры Share_info, здесь 50
  PShareInfo:PChar; //указатель на структуру Share_Info
  ParmErr:DWord) //указатель на ???
  :dword;stdcall;external 'svrapi.dll';//svrapi для Win9X, NetApi32 для NT

function NetShareDel(ServerName:PChar;
  NetName:PChar;
  Reserved:DWord):dword;stdcall;external 'svrapi.dll';

type
  _share_info_50 = record //структура Share уровня 50
  NetName: array [1..13] of char; //Как будет называться диск в сети
  SType: byte; //тип =0 (STYPE_DISKTREE) - шарить диски
  Flags: word; //флаги $0191,$0192,$0193....(доступ из сети)
  Remark: PChar; //указатель на комментарий, видимый из сети
  Path: PChar; //указатель на имя ресурса, например 'c:'#0
  RW_Password: array [1..9] of char; //пароль для полного доступа, если не нужен =#0
  RO_Password: array [1..9] of char; //пароль для доступа на чтение, если не нужен =#0
end;

//----------------------------

function SetShareOnDisk(HostName,LocalPath:string; NetName:TNetName;Remark:string;
  Access:word;RO_Passw,RW_Passw:TPassw):boolean; var ShareInfo:_Share_Info_50;
begin
  Result:=false;
  StrPCopy(@ShareInfo.NetName,NetName);
  ShareInfo.SType:=0;
  ShareInfo.Flags:=Access;
  ShareInfo.Remark:=PChar(Remark);
  ShareInfo.Path:=PChar(LocalPath);
  StrPCopy(@ShareInfo.RO_Password,RO_Passw);
  StrPCopy(@ShareInfo.RW_Password,RW_Passw);
  ShareResult:=NetShareAdd(PChar(HostName), 50,@ShareInfo,$0000002a); //вызываем Share
  if ShareResult <> 0 then //расшарить неудалось
    Exit;
  SHChangeNotify(SHCNE_NETSHARE,SHCNF_PATH,PChar(LocalPath),nil); //сказать шеллу об изменениях
  Result:=true;
end;

//----------------------------

function RemoveShareFromDisk(HostName, NetName, LocalPath: string): boolean;
begin
  Result:=false;
  ShareResult:=NetShareDel(PChar(HostName),PChar(NetName),0); //удалить шару
  if ShareResult <> 0 then
    Exit;
  SHChangeNotify(SHCNE_NETUNSHARE, SHCNF_PATH,PChar(LocalPath),nil); //сказать шеллу об изменениях
  Result:=true;
end;
end.

Открыть URL в новом окне, используя WEBBrowser

{
  Usually when you open a URL in new window in TWebBrowser it opens
  the Internet Explorer. This tip creates a new instance of your
  browser form and opens the new site in your browser.
}

procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
var
  NewWindow: TForm1;
begin
  // a new instance of the form will be created
  // Eine neue Instanz wird erstellt
  NewWindow := TForm1.Create(self);

  NewWindow.Show;
  ppDisp := NewWindow.Webbrowser1.DefaultDispatch;
end;

Проверить существование определённого URL

Данная функция позволяет Вам проверить существование определённого адреса(URL) в интернете. Естественно она может пригодиться веб-мастерам, у которых на сайте много ссылок, и необходимо с определённой периодичнойстью эти ссылки проверять.
URL может быть как с префиксом http:/ так и без него - эта функция добавляет префикс http:// если он отсутствует (необходимо для функции internetOpenUrl которая так же поддерживает FTP:// и gopher://
Эта функция проверяет только два возвращаемых кода '200'(ОК) или '302' (Редирект), но Вы можете заставить проверять функцию и другие коды. Для этого достаточно модифицировать строчку "result := ".

uses wininet;

function CheckUrl(url: string): boolean;
var
  hSession, hfile, hRequest: hInternet;
  dwindex, dwcodelen: dword;
  dwcode: array [1..20] of char;
  res: pchar;
begin
  if pos('http://', lowercase(url)) = 0 then
    url := 'http://'+url;
  Result := false;
  hSession := InternetOpen('InetURL:/1.0', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if assigned(hsession) then
  begin
    hfile := InternetOpenUrl(hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
    dwIndex := 0;
    dwCodeLen := 10;
    HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
    res := pchar(@dwcode);
    result := (res = '200') or (res = '302');
    if assigned(hfile) then
      InternetCloseHandle(hfile);
    InternetCloseHandle(hsession);
  end;
end;

Фильтровать все ссылки в TMemo

// For this tip you need Memo1, ListBox1, Label1, Button1.

procedure TForm1.Button1Click(Sender: TObject);
var
  i, p: Integer;
  s: string;
begin
  ListBox1.Clear;
  for i := 0 to Memo1.Lines.Count - 1 do
  begin
    if Pos('http://', Memo1.Lines.Strings[i]) > 0 then
    begin
      s := '';
      {If the current line contains a "http://", read on until a space is found

       Die aktuelle Zeile wird nach der Zeichenfolge "http://" durchsucht
       und bei Erfolg ab der gefundenen Position ausgelesen, bis ein
       Leerzeichen auftritt...}

      for p := Pos('http://', Memo1.Lines.Strings[i]) to
        Length(Memo1.Lines.Strings[i]) do
        if Memo1.Lines.Strings[i][p] <> ' ' then
          s := s + Memo1.Lines.Strings[i][p]
      else
        break;

       {Remove some characters if address doesn't end with a space

       Falls die gefundene Adresse nicht mit einem Leerzeichen abschlie?t,
       werden hier noch anhangende Textzeichen entfernt...}

      while Pos(s[Length(s)], '..;!")]}?''>') > 0 do
        Delete(s, Length(s), 1);
      // Add the Address to the list...
      //Gefundene Adresse in die Liste aufnehmen...
      ListBox1.Items.Add(s);
    end;
  end;

  // Show the number of Addresses in Label1
  // Die Zahl der gefundenen Adressen in Label1 anzeigen...

  if ListBox1.Items.Count > 0 then
    label1.Caption := IntToStr(ListBox1.Items.Count) +
      ' Adresse(n) gefunden.'
  else
    label1.Caption := 'Keine Adresse gefunden.';
end;

Источник: www.articles.org.ru

Ссылки по теме
Алгоритмы Сортировки. Часть 1
Введение в Delphi 8
Работа с реестром в Delphi
Delphi и ресурсы компьютера
Советы начинающим программировать на Delphi
Структуры и базы данных, методы сортировки
Вся документация Pascal и Delphi

Компьютерная документация от А до Я - Главная

Интересное в сети

10 новых программ

CodeLobster PHP Edition 3.7.2
WinToFlash 0.7.0008
Free Video to Flash Converter 4.7.24
Total Commander v7.55
aTunes 2.0.1
Process Explorer v12.04
Backup42 v3.0
Predator 2.0.1
FastStone Image Viewer 4.1
Process Lasso 3.70.4
FastStone Image Viewer 4.0
Xion Audio Player 1.0.125
Notepad GNU v.2.2.8.7.7
K-Lite Codec Pack 5.3.0 Full

Наши сервисы

Рассылка новостей. Подпишитесь на рассылку сейчас и вы всегда будете в курсе последних событий в мире информационных технологий.

Новостные информеры. Поставьте наши информеры к себе и у вас на сайте появится дополнительный постоянно обновляемый раздел.

Поставить

Добавление статей. Если вы являетесь автором статьи или обзора на тему ИТ присылайте материал нам, мы с удовольствием опубликуем его у себя на сайте.

Прислать

Реклама на сайте. Размещая рекламу у нас, вы получите новых посетителей, которые могут стать вашими клиентами.

Разместить

Это интересно

При цитировании и перепечатке ссылка на www.compdoc.ru обязательна. Карта сайта.

Раздел: Компьютерная документация -> Программирование -> Delphi / Pascal

Работа с URL в DELPHI

Вся документация Pascal и Delphi

Компьютерная документация от А до Я - Главная