function HTTPEncode(const AStr: string): string;
const
NoConversion = ['A'..'Z', 'a'..'z', '*', '@', '.', '_', '-'];
var
Sp, Rp: PChar;
begin
SetLength(Result, Length(AStr) * 3);
Sp := PChar(AStr);
Rp := PChar(Result);
while Sp^ <> #0 do
begin
if Sp^ in NoConversion then
Rp^ := Sp^
else if Sp^ = ' ' then
Rp^ := '+'
else
begin
FormatBuf(Rp^, 3, '%%%.2x', 6, [Ord(Sp^)]);
Inc(Rp, 2);
end;
Inc(Rp);
Inc(Sp);
end;
SetLength(Result, Rp - PChar(Result));
end;


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

{ **** UBPFD *********** by kladovka.net.ru ****
>> URL декодирование строки

Функция выполняет URL декодирование строки, заменяя все
подстроки вида '%HH', где 'HH' - шестнадцатеричные
цифры, на соответствующие символы.

Зависимости: Windows
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 27 мая 2002 г.
********************************************** }

function UrlDecode(Str: string): string;

function HexToChar(W: word): Char;
asm
cmp ah, 030h
jl @@error
cmp ah, 039h
jg @@10
sub ah, 30h
jmp @@30
@@10:
cmp ah, 041h
jl @@error
cmp ah, 046h
jg @@20
sub ah, 041h
add ah, 00Ah
jmp @@30
@@20:
cmp ah, 061h
jl @@error
cmp al, 066h
jg @@error
sub ah, 061h
add ah, 00Ah
@@30:
cmp al, 030h
jl @@error
cmp al, 039h
jg @@40
sub al, 030h
jmp @@60
@@40:
cmp al, 041h
jl @@error
cmp al, 046h
jg @@50
sub al, 041h
add al, 00Ah
jmp @@60
@@50:
cmp al, 061h
jl @@error
cmp al, 066h
jg @@error
sub al, 061h
add al, 00Ah
@@60:
shl al, 4
or al, ah
ret
@@error:
xor al, al
end;

function GetCh(P: PChar; var Ch: Char): Char;
begin
Ch:=P^;
Result:=Ch;
end;

var
P: PChar;
Ch: Char;
begin
Result:='';
P:=@Str[1];
while GetCh(P, Ch) <> #0 do begin
case Ch of
'+': Result:=Result+' ';
'%': begin
Inc(P);
Result:=Result+HexToChar(PWord(P)^);
Inc(P);
end;
else Result:=Result+Ch;
end;
Inc(P);
end;
end;

{ **** UBPFD *********** by kladovka.net.ru ****
>> URL кодирование строки

Функция производит так назваемое URL кодирование строк для
использования в http запросах. Т.е. все алфавитно-цифровые
символы и знак подчёикивания '_' остаются неизменными,
пробел заменяется на '+', а все остальные символы на знак
процента '%' с двумя шестнадцатеричными цифрами.

Зависимости: Windows
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 27 мая 2002 г.
********************************************** }

function UrlEncode(Str: string): string;

function CharToHex(Ch: Char): Integer;
asm
and eax, 0FFh
mov ah, al
shr al, 4
and ah, 00fh
cmp al, 00ah
jl @@10
sub al, 00ah
add al, 041h
jmp @@20
@@10:
add al, 030h
@@20:
cmp ah, 00ah
jl @@30
sub ah, 00ah
add ah, 041h
jmp @@40
@@30:
add ah, 030h
@@40:
shl eax, 8
mov al, '%'
end;

var
i, Len: Integer;
Ch: Char;
N: Integer; P: PChar;
begin
Result:='';
Len:=Length(Str);
P:=PChar(@N);
for i:=1 to Len do begin
Ch:=Str[i];
if Ch in ['0'..'9', 'A'..'Z', 'a'..'z', '_'] then Result:=Result+Ch else begin
if Ch = ' ' then Result:=Result+'+' else begin
N:=CharToHex(Ch);
Result:=Result+P;
end;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
S: string;
begin
S:=UrlEncode('Мастера Delphi');
ShellExecute(Handle, 'open',
PChar('http://www.yandex.ru/yandsearch?text='+S), '', '', SW_SHOWNORMAL);
end;

const
MAX_ADAPTER_NAME = 255;
type
PIP_ADAPTER_INDEX_MAP = ^IP_ADAPTER_INDEX_MAP;
IP_ADAPTER_INDEX_MAP = record
Index: DWORD;
Name: array [0..MAX_ADAPTER_NAME-1] of WideChar;
end;

PIP_INTERFACE_INFO = ^IP_INTERFACE_INFO;
IP_INTERFACE_INFO = record
NumAdapters: Longint;
Adapter: array [0..0] of IP_ADAPTER_INDEX_MAP;
end;

function GetIfEntry(pIfRow: PMibIfRow): DWORD; stdcall external 'iphlpapi.dll';
function GetNumberOfInterfaces(var pdwIntf: DWORD): DWORD; stdcall; external 'iphlpapi.dll';
function GetInterfaceInfo(pIfTable: PIP_INTERFACE_INFO; var dwOutBufLen:DWORD): DWORD;
stdcall; external 'iphlpapi.dll';
function GetAdapterIndex(AdapterName: PWideChar; var IfIndex: DWORD): DWORD;
stdcall; external 'iphlpapi.dll';

procedure TMainForm.Button1Click(Sender: TObject);
var
I, pdwIntf, dwOutBufLen, IfIndex: DWORD;
lpInfo: PIP_INTERFACE_INFO;
mirIfDescr: TMibIfRow;
begin
//if GetNumberOfInterfaces(pdwIntf) = NO_ERROR then
//begin
GetInterfaceInfo(nil, dwOutBufLen);
GetMem(lpInfo, dwOutBufLen);
try
if GetInterfaceInfo(lpInfo, dwOutBufLen) = NO_ERROR then
begin
for I := 0 to lpInfo^.NumAdapters - 1 do
begin
Memo1.Lines.Add('AdapterName: ' + lpInfo^.Adapter[I].Name);
if GetAdapterIndex(lpInfo^.Adapter[I].Name, IfIndex) = NO_ERROR then
Memo1.Lines.Add('AdapterIndex: ' + IntToStr(IfIndex))
else
RaiseLastOSError;
ZeroMemory(@mirIfDescr, SizeOf(TMibIfRow));
mirIfDescr.dwIndex := IfIndex;
if GetIfEntry(@mirIfDescr) = NO_ERROR then
Memo1.Lines.Add('AdapterDescription: ' + mirIfDescr.bDescr)
else
RaiseLastOSError;
end;
end
else
RaiseLastOSError;
finally
FreeMem(lpInfo);
end;
end
//else
//RaiseLastOSError;
end;

{ Add a button and memo }

implementation

{$R *.dfm}

uses
Urlmon;

procedure TForm1.Button1Click(Sender : TObject);
var
ca : iinterface;
rls : Integer;
stat : iBindStatusCallBack;
rr : Cardinal;
tag : _tagBindInfo;
exGuid : tguid;
noIp : Pointer;
res : HResult;
begin
// Make a 0.0.0.0 ip giud
exGuid.D1 := rr;
exGuid.D2 := word('0');
exGuid.D3 := word('.');
// Set Tag options
with tag do
begin
// set "0." ip guid
iid := exGuid;
// set needed size
cbSize := sizeOf('www.big-x.cjb.net');
// Add ip hiding ( not tested, but should work )
securityAttributes.lpSecurityDescriptor := noIp;
securityAttributes.nLength := length('0.0.0.0');
securityAttributes.bInheritHandle := True;
end;{
Extra: res := stat.GetBindInfo(rr, tag);}
//Start downloading webpage
try
urlmon.URLDownloadToFile(ca, 'www.big-x.cjb.net', 'filename.htm', 1, stat);
except
ShowMessage('Could not download the webpage!');
end;
//Load the webpage source to a memo
memo1.Lines.LoadFromFile('filename.htm');
end;

<form method=GET action=http://localhost/cgi-bin/mget?>
<input type=text name=name1 value="имя" size="40" maxlength="20"><br>
<input type=text name=name2 value="фамилия" size="40" maxlength="20"><br>
<input type=submit>
</form>

<input type=text name=name1 value="имя" size="40" maxlength="20"><br>
<input type=text name=name2 value="фамилия" size="40" maxlength="20"><br>

var
s: String;
begin
s := IdHTTP1.Get('http://localhost/cgi-bin/mget?name1=Vasya&name2=Pupkin')

<form method=POST action=http://localhost/cgi-bin/mget?>
<input type=text name=name1 value="имя" size="40" maxlength="20"><br>
<input type=text name=name2 value="фамилия" size="40" maxlength="20"><br>
<input type=submit>
</form>

var
tL: TStringList;
s: String;
begin
tL := TStringList.Create;
tL.Add('name1=Vasya');
tL.Add('name2=Pupkin');
try
s := IdHTTP1.Post('http://localhost/cgi-bin/mget',tL);
finally
tL.Free;
end;

LONG lineDrop(HCALL hCall, LPCSTR lpsUserUserInfo, DWORD dwSize );

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;

function GetNTDomainName: string;
var hReg: TRegistry;
begin
hReg := TRegistry.Create;
hReg.RootKey := HKEY_LOCAL_MACHINE;
hReg.OpenKey('SOFTWAREMicrosoftWindows NTCurrentVersion
Winlogon', false );
Result := hReg.ReadString( 'DefaultDomainName' );
hReg.CloseKey;
hReg.Destroy;
end;

uses Windows;

function GetComputerNetName: string;
var
buffer: array[0..255] of char;
size: dword;
begin
size := 256;
if GetComputerName(buffer, size) then
Result := buffer
else
Result := ''
end;

uses wininet;
...
function GetUrlSize(const URL:string):integer;//результат в байтах
var
hSession,hFile:hInternet;
dwBuffer:array[1..20] of char;
dwBufferLen,dwIndex:DWORD;
begin
Result:=0;
hSession:=InternetOpen('GetUrlSize',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;
dwBufferLen:=20;
if HttpQueryInfo(hFile,HTTP_QUERY_CONTENT_LENGTH,@dwBuffer,dwBufferLen,dwIndex) then Result:=StrToInt(StrPas(@dwBuffer));
if Assigned(hFile) then InternetCloseHandle(hFile);
InternetCloseHandle(hsession);
end;
end;

uses
WinInet;

const
MODEM = 1;
LAN = 2;
PROXY = 4;
BUSY = 8;

function GetConnectionKind(var strKind: string): Boolean;
var
flags: DWORD;
begin
strKind := '';
Result := InternetGetConnectedState(@flags, 0);
if Result then
begin
if (flags and MODEM) = MODEM then strKind := 'Modem';
if (flags and LAN) = LAN then strKind := 'LAN';
if (flags and PROXY) = PROXY then strKind := 'Proxy';
if (flags and BUSY) = BUSY then strKind := 'Modem Busy';
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
strKind: string;
begin
if GetConnectionKind(strKind) then
ShowMessage(strKind);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_NETWORK) and $01 = $01 then
ShowMessage('Computer is attached to a network!')
else
ShowMessage('Computer is not attached to a network!');
end;

unit Unit1;



interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ActiveX, SHDocVw, MSHTML_TLB, StdCtrls;

type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

function GetHTMLCode(WB: IWebbrowser2; ACode: TStrings): Boolean;
var
Range: IHTMLTxtRange;
begin
Range := ((WB.Document as IHTMLDocument2).body as
IHTMLBodyElement).createTextRange;
ACode.Text := ACode.Text + Range.text;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
ShellWindow: IShellWindows;
WB: IWebbrowser2;
spDisp: IDispatch;
IDoc1: IHTMLDocument2;
k: Integer;
begin
ShellWindow := CoShellWindows.Create;
for k := 0 to ShellWindow.Count do
begin
spDisp := ShellWindow.Item(k);
if spDisp = nil then Continue;
spDisp.QueryInterface(IWebBrowser2, WB);
if WB <> nil then
begin
WB.Document.QueryInterface(IHTMLDocument2, iDoc1);
if iDoc1 <> nil then
begin
WB := ShellWindow.Item(k) as IWebbrowser2;
begin
Memo1.Lines.Add('****************************************');
Memo1.Lines.Add(WB.LocationURL);
Memo1.Lines.Add('****************************************');
GetHTMLCode(WB, Memo1.Lines);
end;
end;
end;
end;
end;

end.

var
Computer: array[1..500] of string[25];
ComputerCount: Integer;

procedure FindAllComputers(Workgroup: string);
var
EnumHandle: THandle;
WorkgroupRS: TNetResource;
Buf: array[1..500] of TNetResource;
BufSize: Integer;
Entries: Integer;
Result: Integer;
begin
ComputerCount := 0;
Workgroup := Workgroup + #0;
FillChar(WorkgroupRS, SizeOf(WorkgroupRS), 0);
with WorkgroupRS do
begin
dwScope := 2;
dwType := 3;
dwDisplayType := 1;
dwUsage := 2;
lpRemoteName := @Workgroup[1];
end;
WNetOpenEnum(RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
0,
@WorkgroupRS,
EnumHandle);
repeat
Entries := 1;
BufSize := SizeOf(Buf);
Result :=
WNetEnumResource(EnumHandle,
Entries,
@Buf,
BufSize);
if (Result = NO_ERROR) and (Entries = 1) then
begin
Inc(ComputerCount);
Computer[ComputerCount] := StrPas(Buf[1].lpRemoteName);
end;
until (Entries <> 1) or (Result <> NO_ERROR);
WNetCloseEnum(EnumHandle);
end; { Find All Computers }

// Пример получения имени пользователя и домена под которым работает
// текущий поток или процесс
type
PTOKEN_USER = ^TOKEN_USER;
_TOKEN_USER = record
User : TSidAndAttributes;
end;
TOKEN_USER = _TOKEN_USER;

function GetCurrentUserAndDomain (
szUser : PChar; var chUser: DWORD; szDomain :PChar; var chDomain : DWORD
):Boolean;
var
hToken : THandle;
cbBuf : Cardinal;
ptiUser : PTOKEN_USER;
snu : SID_NAME_USE;
begin
Result:=false;
// Получаем маркер доступа текущего потока нашего процесса
if not OpenThreadToken(GetCurrentThread(),TOKEN_QUERY,true,hToken)
then begin
if GetLastError()< > ERROR_NO_TOKEN then exit;
// В случее ошибки - получаем маркер доступа нашего процесса.
if not OpenProcessToken(GetCurrentProcess(),TOKEN_QUERY,hToken)
then exit;
end;

// Вывываем GetTokenInformation для получения размера буфера
if not GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf)
then if GetLastError()< > ERROR_INSUFFICIENT_BUFFER
then begin
CloseHandle(hToken);
exit;
end;

if cbBuf = 0 then exit;

// Выделяем память под буфер
GetMem(ptiUser,cbBuf);

// В случае удачного вызова получим указатель на TOKEN_USER
if GetTokenInformation(hToken,TokenUser,ptiUser,cbBuf,cbBuf)
then begin
// Ищем имя пользователя и его домен по его SID
if LookupAccountSid(nil,ptiUser.User.Sid,szUser,chUser,szDomain,chDomain,snu)
then Result:=true;
end;

// Освобождаем ресурсы
CloseHandle(hToken);
FreeMem(ptiUser);
end;

// Использовать функцию можно так :
var
Domain, User : array [0..50] of Char;
chDomain,chUser : Cardinal;
begin
chDomain:=50;
chUser :=50;
if GetCurrentUserAndDomain(User,chuser,Domain,chDomain)
then ...
end;

// Если вам необходимо получить только имя пользователя - используйте GetUserName
// Данный пример можно использовать и для определения - запущен ли процесс
// системой или пользователем. Учетной записи Localsystem соответствует
// имя пользователя - SYSTEM и домен NT AUTORITY (лучше проверить на практике)

function IsValidEmail(const Value: string): boolean;
function CheckAllowed(const s: string): boolean;
var
i: integer;
begin
Result:= false;
for i:= 1 to Length(s) do
begin
{ недопустимый символ в s - значит недопустимый адрес }
if not (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) then
Exit;
end;
Result:= true;
end;
var
i: integer;
namePart, serverPart: string;
begin // начало выполнения IsValidEmail
Result:= false;
i:= Pos('@', Value);
if i = 0 then
Exit;
namePart:= Copy(Value, 1, i - 1);
serverPart:= Copy(Value, i + 1, Length(Value));
// @ не указано имя имя или сервер не указаны; минимально для сервера. "a.com"
if (Length(namePart) = 0) or ((Length(serverPart) < 1)) then
Exit;
i:= Pos('.', serverPart);
// должно иметь точку и как минимум два знака от конца
if (i = 0) or (i > (Length(serverPart) - 1)) then
Exit;
Result:= CheckAllowed(namePart) and CheckAllowed(serverPart);
end;