Приводимая здесь функция показывает, как Ваше приложение может извлечь из браузера (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);
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);
Данная функция позволяет Вам проверить существование определённого адреса(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;
Сегодня поговорим о шрифтах, и о том, каким образом работать с ними на Win API. Нам потребуется переменная типа HFONT. Изменить стиль шрифта можно у любого компонента, я покажу это на примере кнопки... подробнее
Таймер - вещь в хозяйстве очень полезная. Если некое действие нужно повторять с определенной периодичностью, то таймер, это как раз то, что нужно... подробнее
Мы уже знакомы с системным таймером, сегодня познакомимся с мультимедийным, основное отличие которого, более высокая скорость (точность) работы... подробнее
Сегодня наша программа научится работать с CheckBoxами. CheckBox можно представить как флаг, который можно установить или сбросить, и в зависимости от его состояния выполнять определенные действия... подробнее
В прошлый раз мы сделали несколько радио-кнопок, которые автоматически объединялись в одну группу. Сейчас рассмотрим, как создавать несколько независимых групп радио-кнопок... подробнее
