[ главная ]   [ рейтинг статей ]   [ справочник радиолюбителя ]   [ новости мира ИТ ]



Ответов: 0
25-02-12 07:01







   Web - программирование
PHP


ASP






XML



CSS

SSI





   Программирование под ОС











   Web - технологии








   Базы Данных









   Графика






Данные




Программирование под ОС / Pascal - Delphi /

Работа с 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




Комментарии

ydidmgtoubl
28-07-2011   
aVaud8 , [url=http://iyfsxsomqwcp.com/]iyfsxsomqwcp[/url], [link=http://upoojdiacfph.com/]upoojdiacfph[/link], http://cjzxbtomzbyt.com/

astsqsxxy
27-07-2011   
ZCsATA <a href="http://syydgzemumej.com/">syydgzemumej</a>

yjinhnxnqw
26-07-2011   
tyaI7p , [url=http://zzcczxpvgbqd.com/]zzcczxpvgbqd[/url], [link=http://exzphifkichv.com/]exzphifkichv[/link], http://rbpmcyisagxh.com/

Molly
25-07-2011   
I think you hit a bullseye there fleals!

 Ваш комментарий к данному материалу будет интересен нам и нашим читателям!



Последние статьи: Программирование под ОС / Pascal - Delphi /

Работа со шрифтами на Win API
06-06-2010   

Сегодня поговорим о шрифтах, и о том, каким образом работать с ними на Win API. Нам потребуется переменная типа HFONT. Изменить стиль шрифта можно у любого компонента, я покажу это на примере кнопки... подробнее

Кол. просмотров: общее - 4892 сегодня - 0

Работа с таймером на Win API
06-06-2010   

Таймер - вещь в хозяйстве очень полезная. Если некое действие нужно повторять с определенной периодичностью, то таймер, это как раз то, что нужно... подробнее

Кол. просмотров: общее - 4905 сегодня - 0

Работа с мультимедийным таймером на Win API
06-06-2010   

Мы уже знакомы с системным таймером, сегодня познакомимся с мультимедийным, основное отличие которого, более высокая скорость (точность) работы... подробнее

Кол. просмотров: общее - 5052 сегодня - 0

Создание CheckBoxов средствами Win API
06-06-2010   

Сегодня наша программа научится работать с CheckBoxами. CheckBox можно представить как флаг, который можно установить или сбросить, и в зависимости от его состояния выполнять определенные действия... подробнее

Кол. просмотров: общее - 5287 сегодня - 0

Создание группы RadioButton средствами Win API
06-06-2010   

В прошлый раз мы сделали несколько радио-кнопок, которые автоматически объединялись в одну группу. Сейчас рассмотрим, как создавать несколько независимых групп радио-кнопок... подробнее

Кол. просмотров: общее - 4932 сегодня - 1



  WWW.COMPROG.RU - 2009-2012 | Designed and Powered by Zaipov Renat | Projects