Формулы передачи данных для начинающих

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Юзер — супорту:

— A чего это я постоянно слетаю с ваших модемов?!

— Летаешь — значит растешь!

Данным примером я попытаюсь дать ответы на следующие вопросы:

Каково различие между KBps и Kbps? В чём заключается отличие битов, байтов и бодов? Как определить скорость передачи данных? Как выяснить, насколько долго будет загружаться файл с определённой скоростью? Как посчитать время, оставшее до окончания загрузки?

Для начала хотельсы навести порядок с некоторой неразберихой по поводу KBps и Kbps (буква b в нижнем регистре). KBps это обозначение для килобайт в секунду, в то время как Kbps обозначает килобиты в секунду. 1 килобайт (KB) = 8 килобитам (Kb).

Когда речь идёт о скорости передачи, то применяется Kbps. Таким образом модем со скорость передачи 33.6K (33600 bps) передаёт данные со скоростью 4.2 KBps (4.2 килобайта в секунду). Как мы видим, разница между KB и Kb довольно ощутима. В этом кроется причина того, что некоторые пользователи модемов по своему незнанию не могут понять, почему данные передаются так медленно. На самом деле данные объёмом 33.6K передаются не за 1 секунду, а за 8, соответственно за одну секунду будет передано 33.6 Kb / 8 = 4.2.

Так же хотелось бы дать некоторые разъяснения по поводу слова «бод» (baud). Обычно для модема «боды» расшифровываются как бит в секунду. На самом деле это не так. Бод (Baud) означает частоту звука в телефонной линии. Т. е. в зависимости от модема, который Вы используете, количество бит, которые могут быть переданы зависит от частоты звука, необходимой для обеспечения нужной скорости передачи.

Обратите внимание: Приведённый ниже пример, использует компонент NetMasters TNMHTTP. Однако, если Вы «прикипели» к какому-то другому компоненту TCP/IP, то переделать пример под этот компонент не составит большого труда.

Используемые обозначения:

bps

байт, переданных за 1 секунду

KBps (KB/Sec)

bps / 1024

Kbps (Kb/Sec)

KBps x 8

Краткий алгоритм приведённого ниже примера:

Сохраняем в переменной время начала загрузки: nStartTime := GetTickCount;

Сохраняем в переменной размер файла (KB): nFileSize := «File Size»;

Начало передачи данных.

Обновляем количество переданных байт: Inc(nBytesTransferred, nNewBytes);

Получаем оставшееся время: nTimeElapsed := (GetTickCount — nStartTime) / 1000;

Вычисляем bps: nBps := BytesTransferred / nTimeElapsed;

Вычисляем KBps: nKBps := nBps / 1024;

Используемые данные:

Общее время скачивания (секунд) := nFileSize / nKBps;

bps := FloatToStr(nBps);

KB/Sec (KBps) := FloatToStr(nKBps);

Осталось секунд := FloatToStr(((nFileSize — BytesTransferred) / 1024) / KBps);

Рабочий пример:

unit Main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Gauges, Psock, NMHttp;

type

TfMain = class(TForm)

Label1: TLabel;

eURL: TEdit;

bGet: TButton;

lbMessages: TListBox;

gbDetails: TGroupBox;

lEstimate: TLabel;

lKBps: TLabel;

lReceived: TLabel;

lRemaining: TLabel;

gProgress: TGauge;

NMHTTP1: TNMHTTP;

lbps: TLabel;

bCancel: TButton;

procedure NMHTTP1PacketRecvd(Sender: TObject);

procedure bGetClick(Sender: TObject);

procedure bCancelClick(Sender: TObject);

procedure NMHTTP1Connect(Sender: TObject);

procedure NMHTTP1ConnectionFailed(Sender: TObject);

procedure NMHTTP1Disconnect(Sender: TObject);

procedure NMHTTP1Failure(Cmd: CmdType);

procedure NMHTTP1HostResolved(Sender: TComponent);

procedure NMHTTP1InvalidHost(var Handled: Boolean);

procedure NMHTTP1Status(Sender: TComponent; Status: string);

procedure NMHTTP1Success(Cmd: CmdType);

private

{ Private declarations }

function ss2nn(Seconds: Integer): string;

public

{ Public declarations }

end;

var

fMain: TfMain;

nFileSize: Double;

nStartTime: DWord;

implementation

{$R *.DFM}

{Цель этой функции состоит в том, чтобы определить,

сколько минут и секунд там находятся в данном количестве секунд}

function TfMain.ss2nn(Seconds: Integer): string;

var

nMin, nSec: Integer;

begin

{Проверяем, меньше чем 1/Min}

if Seconds < 60 then

Result := ‘0 minutes ‘ IntToStr(Seconds) ‘ seconds’

else

begin

{Определяем минуты}

nMin := Seconds div 60;

{Определяем секунды}

nSec := Seconds — (nMin * 60);

{Возвращаем результат}

Result := IntToStr(nMin) ‘ minutes ‘ IntToStr(nSec) ‘ seconds’;

end;

end;

procedure TfMain.NMHTTP1PacketRecvd(Sender: TObject);

var

nBytesReceived, nTimeElapsed, nBps, nKBps: Double;

begin

{Следующий код выполняется только однажды, при приёме первого пакета}

if nFileSize NMHTTP1.BytesTotal then

begin

{Получаем размер файла}

nFileSize := NMHTTP1.BytesTotal;

{Вычисляем время передачи, исходя из скорости соединения 33.6 Kbps}

lEstimate.Caption := ‘Estimated download time at 33.6 Kbps: ‘ ss2nn(Round(

(nFileSize / 1024) / 4.2));

{Получаем время начала}

nStartTime := GetTickCount;

end;

{Обновляем nBytesReceived}

nBytesReceived := NMHTTP1.BytesRecvd;

{Вычисляем количество секунд прошедших с момента начала передачи}

nTimeElapsed := (GetTickCount — nStartTime) / 1000;

{Проверяем на 0/Sec, если так, то устанавливаем 1,

чтобы предотвратить деления на ноль}

if nTimeElapsed = 0 then

nTimeElapsed := 1;

{Вычисляем байт в секунду}

nBps := nBytesReceived / nTimeElapsed;

{Вычисляем килобайт в секунду}

nKBps := nBps / 1024;

{Обновляем контролы}

gProgress.Progress := Round((nBytesReceived * 100) / nFileSize);

lbps.Caption := IntToStr(Round(nBps * 8)) ‘ bits per second’;

lKBps.Caption := IntToStr(Round(nKBps)) ‘ KB/Sec (KBps)’;

lReceived.Caption := FloatToStr(nBytesReceived) ‘ of ‘ FloatToStr(

nFileSize) ‘ bytes received’;

lRemaining.Caption := ss2nn(Round(((nFileSize — nBytesReceived) / 1024) /

nKBps)) ‘ remaining’;

end;

procedure TfMain.bGetClick(Sender: TObject);

begin

{Сбрасываем переменные}

nFileSize := 0;

{Обнуляем контролы}

lbMessages.Clear;

gProgress.Progress := 0;

lEstimate.Caption := ‘Estimated download time at 33.6 Kbps: 0 minutes 0 ‘

‘seconds’;

lbps.Caption := ‘0 bits per second’;

lKBps.Caption := ‘0 KB/Sec (KBps)’;

lReceived.Caption := ‘0 of 0 bytes received’;

lRemaining.Caption := ‘0 minutes 0 seconds remaining’;

{Получаем файл}

NMHTTP1.Get(eURL.Text);

end;

procedure TfMain.bCancelClick(Sender: TObject);

begin

{Разрываем соединение с сервером}

NMHTTP1.Disconnect;

{Обновляем lbMessages}

lbMessages.Items.Append(‘Get Canceled’);

lbMessages.Items.Append(‘Disconnected’);

end;

procedure TfMain.NMHTTP1Connect(Sender: TObject);

begin

{Запрещаем/Разрешаем контролы}

bGet.Enabled := False;

bCancel.Enabled := True;

{Работаем с lbMessages}

with lbMessages.Items do

begin

Append(‘Connected’);

Append(‘Local Address: ‘ NMHTTP1.LocalIP);

Append(‘Remote Address: ‘ NMHTTP1.RemoteIP);

end;

end;

procedure TfMain.NMHTTP1ConnectionFailed(Sender: TObject);

begin

ShowMessage(‘Connection Failed.’);

end;

procedure TfMain.NMHTTP1Disconnect(Sender: TObject);

begin

{Запрещаем/Разрешаем контролы}

bCancel.Enabled := False;

bGet.Enabled := True;

{Обновляем lbMessages}

if NMHTTP1.Connected then

lbMessages.Items.Append(‘Disconnected’);

end;

procedure TfMain.NMHTTP1Failure(Cmd: CmdType);

begin

case Cmd of

CmdGET : lbMessages.Items.Append(‘Get Failed’);

CmdOPTIONS : lbMessages.Items.Append(‘Options Failed’);

CmdHEAD : lbMessages.Items.Append(‘Head Failed’);

CmdPOST : lbMessages.Items.Append(‘Post Failed’);

CmdPUT : lbMessages.Items.Append(‘Put Failed’);

CmdPATCH : lbMessages.Items.Append(‘Patch Failed’);

CmdCOPY : lbMessages.Items.Append(‘Copy Failed’);

CmdMOVE : lbMessages.Items.Append(‘Move Failed’);

CmdDELETE : lbMessages.Items.Append(‘Delete Failed’);

CmdLINK : lbMessages.Items.Append(‘Link Failed’);

CmdUNLINK : lbMessages.Items.Append(‘UnLink Failed’);

CmdTRACE : lbMessages.Items.Append(‘Trace Failed’);

CmdWRAPPED : lbMessages.Items.Append(‘Wrapped Failed’);

end;

end;

procedure TfMain.NMHTTP1HostResolved(Sender: TComponent);

begin

lbMessages.Items.Append(‘Host Resolved’);

end;

procedure TfMain.NMHTTP1InvalidHost(var Handled: Boolean);

begin

ShowMessage(‘Invalid Host. Please specify a new URL.’);

end;

procedure TfMain.NMHTTP1Status(Sender: TComponent; Status: string);

begin

if NMHTTP1.ReplyNumber = 404 then

ShowMessage(‘Object Not Found.’);

end;

procedure TfMain.NMHTTP1Success(Cmd: CmdType);

begin

case Cmd of

{Удостоверяемся, что процедура получения не была прервана}

CmdGET:

if NMHTTP1.Connected then

lbMessages.Items.Append(‘Get Succeeded’);

CmdOPTIONS : lbMessages.Items.Append(‘Options Succeeded’);

CmdHEAD : lbMessages.Items.Append(‘Head Succeeded’);

CmdPOST : lbMessages.Items.Append(‘Post Succeeded’);

CmdPUT : lbMessages.Items.Append(‘Put Succeeded’);

CmdPATCH : lbMessages.Items.Append(‘Patch Succeeded’);

CmdCOPY : lbMessages.Items.Append(‘Copy Succeeded’);

CmdMOVE : lbMessages.Items.Append(‘Move Succeeded’);

CmdDELETE : lbMessages.Items.Append(‘Delete Succeeded’);

CmdLINK : lbMessages.Items.Append(‘Link Succeeded’);

CmdUNLINK : lbMessages.Items.Append(‘UnLink Succeeded’);

CmdTRACE : lbMessages.Items.Append(‘Trace Succeeded’);

CmdWRAPPED : lbMessages.Items.Append(‘Wrapped Succeeded’);

end;

end;

end.

{/codecitation}

Реализация передачи по сети сообщений

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

function NetSend(dest, Source, Msg: string): Longint; overload;

type

TNetMessageBufferSendFunction = function(servername, msgname, fromname: PWideChar;

buf: PWideChar; buflen: Cardinal): Longint;

stdcall;

var

NetMessageBufferSend: TNetMessageBufferSendFunction;

SourceWideChar: PWideChar;

DestWideChar: PWideChar;

MessagetextWideChar: PWideChar;

Handle: THandle;

begin

Handle := LoadLibrary(‘NETAPI32.DLL’);

if Handle = 0 then

begin

Result := GetLastError;

Exit;

end;

@NetMessageBufferSend := GetProcAddress(Handle, ‘NetMessageBufferSend’);

if @NetMessageBufferSend = nil then

begin

Result := GetLastError;

Exit;

end;

MessagetextWideChar := nil;

SourceWideChar := nil;

DestWideChar := nil;

try

GetMem(MessagetextWideChar, Length(Msg) * SizeOf(WideChar) 1);

GetMem(DestWideChar, 20 * SizeOf(WideChar) 1);

StringToWideChar(Msg, MessagetextWideChar, Length(Msg) * SizeOf(WideChar) 1);

StringToWideChar(Dest, DestWideChar, 20 * SizeOf(WideChar) 1);

if Source = » then

Result := NetMessageBufferSend(nil, DestWideChar, nil,

MessagetextWideChar, Length(Msg) * SizeOf(WideChar) 1)

else

begin

GetMem(SourceWideChar, 20 * SizeOf(WideChar) 1);

StringToWideChar(Source, SourceWideChar, 20 * SizeOf(WideChar) 1);

Result := NetMessageBufferSend(nil, DestWideChar, SourceWideChar,

MessagetextWideChar, Length(Msg) * SizeOf(WideChar) 1);

FreeMem(SourceWideChar);

end;

finally

FreeMem(MessagetextWideChar);

FreeLibrary(Handle);

end;

end;

function NetSend(Dest, Msg: string): Longint; overload;

begin

Result := NetSend(Dest, », Msg);

end;

function NetSend(Msg: string): Longint; overload;

begin

Result := NetSend(», », Msg);

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

const

NERR_BASE = 2100;

NERR_NameNotFound = NERR_BASE 173;

NERR_NetworkError = NERR_BASE 36;

NERR_Success = 0;

var

Res: Longint;

sMsg: string;

begin

Res := NetSend(‘LoginName’, ‘Your Message…’);

case Res of

ERROR_ACCESS_DENIED: sMsg := ‘user does not have access to the requested information.’;

ERROR_INVALID_PARAMETER: sMsg := ‘The specified parameter is invalid.’;

ERROR_NOT_SUPPORTED: sMsg := ‘This network request is not supported.’;

NERR_NameNotFound: sMsg := ‘The user name could not be found.’;

NERR_NetworkError: sMsg := ‘A general failure occurred in the network hardware.’;

NERR_Success: sMsg := ‘Message sent!’;

end;

ShowMessage(sMsg);

end;

{/codecitation}

Реализация Wake для сети – Волшебный Пакет

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

{

What’s a Magic Packet?

Was ist ein Magic Packet?

DESTINATION SOURCE MISC. FF FF FF FF FF FF 11 22 33 44 55 66 11 22 33 44

55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44

55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44

55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44

55 66 11 22 33 44 55 66 11 22 33 44 55 66 MISC. CRC.

Note: Destination, Source, Misc and CRC are normally added by our Socket-Component

Beachte: Destination, Source, Mis und CRC werden normalerweise von deiner

Socket-Komponente hinzugefugt

}

procedure TForm1.Button1Click(Sender: TObject);

var

Data, temp: string;

k, n: integer;

begin

Data := »;

for k := 0 to 5 do

begin

Data := Data Chr(StrToInt(‘$FF’)); // 6x add a FF / 6x ein FF hinzufugen

end;

temp := StringReplace(Edit1.Text, ‘-‘, », [rfReplaceAll]);

for k := 0 to 15 do

begin

temp := StringReplace(Edit1.Text, ‘-‘, », [rfReplaceAll]);

for n := 0 to 5 do

begin

// 16x add Target-Mac-Adress / 16x die Ziel-Macadresse hinzufugen

Data := Data Chr(StrToInt(‘$’ temp[1] temp[2]));

Delete(temp, 1, 2);

end;

end;

//Example with TIdUDPClient of Indy

//IdUDPClient1.Send(‘255.255.255.255′, ’80’, Data); // Send it / Verschick es

end;

{/codecitation}

Программа обмена сообщениями по сети

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Мамедов Альберт

Исходники под Delphi6 программы обмена сообщениями по сети.

Позволяет:

обмениваться текстовыми сообщениями;

озвучивает пришедшие сообщения (необходимо подключить модуль SpeechAPI. С вопросами на magdelphi.boom.ru)

просмотреть дисплей любого компа подключеного к сети.

сканирует сеть и находит компы одной рабочей группы.

неподкючены функции удалённого управления (выключение, перезагрузка, снятие задачи)

{/codecitation}

Получить список пользователей, подключённых к сети

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Корпорации IBM срочно требуется ламер для организации и проведения увеселительных мероприятий.

unit NetUtils;

interface

uses

Windows, Classes;

function GetContainerList(ListRoot:PNetResource):TList;

type

{$H }

PNetRes = ^TNetRes;

TNetRes = record

dwScope : Integer;

dwType : Integer;

dwDisplayType : Integer;

dwUsage : Integer;

LocalName : string;

RemoteName : string;

Comment : string;

Provider : string;

end;

{H-}

implementation

uses SysUtils;

type

PnetResourceArr = ^TNetResource;

function GetContainerList(ListRoot:PNetResource):TList;

{возвращает список сетевых имён с подуровня ListRoot, каждый

элемент списка TList — это PNetRec, где поле RemoteName определяет

соответственно сетевое имя элемента списка. Если ListRoot=nil, то

возвращается самый верхний уровень типа:

1. Microsoft Windows Network

2. Novell Netware Network

Чтобы получить список доменов сети Microsoft, нужно вызвать эту

функцию второй раз, передав ей в качестве параметра,

соответствующий элемент списка, полученного при первом её вызове.

Чтобы получить список компьютеров домена — вызвать третий раз…}

var

TempRec : PNetRes;

Buf : Pointer;

Count,

BufSize,

Res : DWORD;

lphEnum : THandle;

p : PNetResourceArr;

i : SmallInt;

NetworkList : TList;

begin

NetworkList := TList.Create;

Result:=nil;

BufSize := 8192;

GetMem(Buf, BufSize);

try

Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER{0}, ListRoot,lphEnum);

{в результате получаем ссылку lphEnum}

if Res 0 then

raise Exception(Res);

Count := $FFFFFFFF; {требуем выдать столько записей в список, сколько есть}

Res := WNetEnumResource(lphEnum, Count, Buf, BufSize);

{в буфере Buf — списочек в виде массива указателей на структуры

типа TNetResourceArr, а в Count — число этих структур}

if Res = ERROR_NO_MORE_ITEMS then

Exit;

if (Res 0) then

raise Exception(Res);

P := PNetResourceArr(Buf);

for I := 0 to Count — 1 do

begin

// Требуется копирование из буфера, так как он

// действителен только до следующего вызова функций группы WNet

New(TempRec);

TempRec^.dwScope := P^.dwScope;

TempRec^.dwType := P^.dwType ;

TempRec^.dwDisplayType := P^.dwDisplayType ;

TempRec^.dwUsage := P^.dwUsage ;

{имеются ввиду вот эти указатели}

TempRec^.LocalName := StrPas(P^.lpLocalName);

{в смысле — строки PChar}

TempRec^.RemoteName := StrPas(P^.lpRemoteName);

TempRec^.Comment := StrPas(P^.lpComment);

TempRec^.Provider := StrPas(P^.lpProvider);

NetworkList.Add(TempRec);

Inc(P);

end;

Res := WNetCloseEnum(lphEnum);

{а следующий вызов — вот он!}

if Res 0 then

raise Exception(Res);

Result:=NetWorkList;

finally

FreeMem(Buf);

end;

end;

end.

{/codecitation}

Получить список доменов

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Бог есть. Он просто администрит другой домен…

Переменная List заполняется списком доменов. Функция возвращает код ошибки обращения к сети.

function FillNetLevel(xxx: PNetResource; list: TStrings): Word;

type

PNRArr = ^TNRArr;

TNRArr = array[0..59] of TNetResource;

var

x: PNRArr;

tnr: TNetResource;

I: integer;

EntrReq,

SizeReq,

twx: Integer;

WSName: string;

begin

Result := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,

RESOURCEUSAGE_CONTAINER, xxx, twx);

if Result = ERROR_NO_NETWORK then

Exit;

if Result = NO_ERROR then

begin

New(x);

EntrReq := 1;

SizeReq := SizeOf(TNetResource) * 59;

while (twx 0) and

(WNetEnumResource(twx, EntrReq, x, SizeReq) ERROR_NO_MORE_ITEMS) do

begin

for i := 0 to EntrReq — 1 do

begin

Move(x^[i], tnr, SizeOf(tnr));

case tnr.dwDisplayType of

RESOURCEDISPLAYTYPE_DOMAIN:

begin

if tnr.lpRemoteName » then

WSName := tnr.lpRemoteName

else

WSName := tnr.lpComment;

list.Add(WSName);

end;

else

FillNetLevel(@tnr, list);

end;

end;

end;

Dispose(x);

WNetCloseEnum(twx);

end;

end;

{/codecitation}

Получить сетевой путь к зашаренному файлу по локальному пути 2

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

function GetUNCName(const LocalPath: string): string;

var

BufferSize: DWord;

DummyBuffer: Byte;

Buffer: Pointer;

Error: DWord;

begin

BufferSize := 1;

WNetGetUniversalName(PChar(LocalPath), UNIVERSAL_NAME_INFO_LEVEL, @DummyBuffer, BufferSize);

Buffer := AllocMem(BufferSize);

try

Error := WNetGetUniversalName(PChar(LocalPath), UNIVERSAL_NAME_INFO_LEVEL, Buffer, BufferSize);

if Error NO_ERROR then

begin

SetLastError(Error);

RaiseLastWin32Error;

end;

Result := PUniversalNameInfo(Buffer)^.lpUniversalName

finally

FreeMem(Buffer);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Label1.Caption := GetUNCName(‘y:\xyz\’)

end;

{/codecitation}

Получить сетевой путь к зашаренному файлу по локальному пути

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

ExpandUNCFileName returns the full path of the FileName

with the network drive portion in UNC format.

The pathname in the UNC-Format has the format:

\\Servername\sharename

ExpandUNCFileName gibt einen String mit dem vollstandigen

Pfadnamen der in FileName ubergebenen Datei zuruck.

Ein vollstandig qualifizierter Pfadname besteht aus der

Laufwerkskomponente des Dateinamens im UNC-Format:

\\Servername\sharename

// Example, Beispiel:

Label1.Caption := ExpandUNCFileName(‘K:\sharename.tmp’));

{where «K» is a Network Drive.}

{/codecitation}

Получить Primary Domain Controller (PDC)

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

{

The NetGetDCName function returns the name of the primary domain controller (PDC).

It does not return the name of the backup domain controller (BDC) for the specified domain.

Also, you cannot remote this function to a non-PDC server.

Windows 2000/XP: Applications that support DNS-style names should call the function.

Domain controllers in this type of environment have a multi-master

directory replication relationship.

Therefore, it may be advantageous for your application to use a DC that is not the PDC.

You can call the DsGetDcName function to locate any DC in the domain;

NetGetDCName returns only the name of the PDC.

}

type

EAccessDenied = Exception;

EInvalidOwner = Exception;

EInsufficientBuffer = Exception;

ELibraryNotFound = Exception;

NET_API_STATUS = Integer;

const

NERR_Success = 0;

var

NTNetGetDCName: function (Server, Domain: pWideChar; var DC: pWideChar): NET_API_STATUS; stdcall;

NTNetGetDCNameA: function (Server, Domain: PChar; var DC: PChar): NET_API_STATUS; stdcall;

NTNetApiBufferFree: function (lpBuffer: Pointer): NET_API_STATUS; stdcall;

procedure NetCheck(ErrCode: NET_API_STATUS);

begin

if ErrCode NERR_Success then

begin

case ErrCode of

ERROR_ACCESS_DENIED:

raise EAccessDenied.Create(‘Access is Denied’);

ERROR_INVALID_OWNER:

raise EInvalidOwner.Create(‘Cannot assign the owner of this object.’);

ERROR_INSUFFICIENT_BUFFER:

raise EInsufficientBuffer.Create(‘Buffer passed was too small’);

else

raise Exception.Create(‘Error Code: ‘ IntToStr(ErrCode) #13

SysErrorMessage(ErrCode));

end;

end;

end;

function GetPDC(szSystem: string): string;

{ if szSystem = » return the PDC else return DC for that domain }

const

NTlib = ‘NETAPI32.DLL’;

Win95lib = ‘RADMIN32.DLL’;

var

pAnsiDomain: PChar;

pDomain: PWideChar;

System: array[1..80] of WideChar;

ErrMode: Word;

LibHandle: THandle;

begin

Result := »;

LibHandle := 0;

try

if Win32Platform = VER_PLATFORM_WIN32_NT then

begin

ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);

LibHandle := LoadLibrary(NTlib);

SetErrorMode(ErrMode);

if LibHandle = 0 then

raise ELibraryNotFound.Create(‘Unable to map library: ‘

NTlib); @NTNetGetDCName := GetProcAddress(Libhandle, ‘NetGetDCName’);

@NTNetApiBufferFree := GetProcAddress(Libhandle,

‘NetApiBufferFree’);

try

if szSystem » then

NetCheck(NTNetGetDCName(nil, StringToWideChar(szSystem, @System, 80), pDomain))

else

NetCheck(NTNetGetDCName(nil, nil, pDomain));

Result := WideCharToString(pDomain);

finally

NetCheck(NTNetApiBufferFree(pDomain));

end;

end

else

begin

ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);

LibHandle := LoadLibrary(Win95lib);

SetErrorMode(ErrMode);

if LibHandle = 0 then

raise ELibraryNotFound.Create(‘Unable to map library: ‘

Win95lib); @NTNetGetDCNameA := GetProcAddress(Libhandle, ‘NetGetDCNameA’);

@NTNetApiBufferFree := GetProcAddress(LibHandle, ‘NetApiBufferFree’);

try

if szSystem » then

NetCheck(NTNetGetDCNameA(nil, PChar(szSystem), pAnsiDomain))

else

NetCheck(NTNetGetDCNameA(nil, nil, pAnsiDomain));

Result := StrPas(pAnsiDomain);

finally

NetCheck(NTNetApiBufferFree(pAnsiDomain));

end;

end;

finally

if LibHandle 0 then

begin

FreeLibrary(Libhandle); // free handle if it has been allocated

end;

end;

end;

// Example call, Beispielaufruf:

procedure TForm1.Button1Click(Sender: TObject);

begin

try

Screen.Cursor := crHourGlass;

label1.Caption := GetPDC(»);

finally

Screen.Cursor := crDefault;

end;

end;

{/codecitation}

Получить MAC адрес

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

uses NB30;

function GetMACAdress: string;

var

NCB: PNCB;

Adapter: PAdapterStatus;

URetCode: PChar;

RetCode: char;

I: integer;

Lenum: PlanaEnum;

_SystemID: string;

TMPSTR: string;

begin

Result := »;

_SystemID := »;

Getmem(NCB, SizeOf(TNCB));

Fillchar(NCB^, SizeOf(TNCB), 0);

Getmem(Lenum, SizeOf(TLanaEnum));

Fillchar(Lenum^, SizeOf(TLanaEnum), 0);

Getmem(Adapter, SizeOf(TAdapterStatus));

Fillchar(Adapter^, SizeOf(TAdapterStatus), 0);

Lenum.Length := chr(0);

NCB.ncb_command := chr(NCBENUM);

NCB.ncb_buffer := Pointer(Lenum);

NCB.ncb_length := SizeOf(Lenum);

RetCode := Netbios(NCB);

i := 0;

repeat

Fillchar(NCB^, SizeOf(TNCB), 0);

Ncb.ncb_command := chr(NCBRESET);

Ncb.ncb_lana_num := lenum.lana[I];

RetCode := Netbios(Ncb);

Fillchar(NCB^, SizeOf(TNCB), 0);

Ncb.ncb_command := chr(NCBASTAT);

Ncb.ncb_lana_num := lenum.lana[I];

// Must be 16

Ncb.ncb_callname := ‘* ‘;

Ncb.ncb_buffer := Pointer(Adapter);

Ncb.ncb_length := SizeOf(TAdapterStatus);

RetCode := Netbios(Ncb);

//—- calc _systemId from mac-address[2-5] XOR mac-address[1]…

if (RetCode = chr(0)) or (RetCode = chr(6)) then

begin

_SystemId := IntToHex(Ord(Adapter.adapter_address[0]), 2) ‘-‘

IntToHex(Ord(Adapter.adapter_address[1]), 2) ‘-‘

IntToHex(Ord(Adapter.adapter_address[2]), 2) ‘-‘

IntToHex(Ord(Adapter.adapter_address[3]), 2) ‘-‘

IntToHex(Ord(Adapter.adapter_address[4]), 2) ‘-‘

IntToHex(Ord(Adapter.adapter_address[5]), 2);

end;

Inc(i);

until (I >= Ord(Lenum.Length)) or (_SystemID ’00-00-00-00-00-00′);

FreeMem(NCB);

FreeMem(Adapter);

FreeMem(Lenum);

GetMacAdress := _SystemID;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

label1.Caption := GetMACAdress;

end;

//***************************************************

// Another Code from

// http://delphi.vitpc.com/treasury/lan.htm

//***************************************************

uses

NB30;

type

TAdapterStatus = record

adapter_address: array [0..5] of char;

filler: array [1..4 * SizeOf(char) 19 * SizeOf(Word) 3 * SizeOf(DWORD)] of

Byte;

end;

THostInfo = record

username: PWideChar;

logon_domain: PWideChar;

oth_domains: PWideChar;

logon_server: PWideChar;

end;{record}

function IsNetConnect: Boolean;

begin

if GetSystemMetrics(SM_NETWORK) and $01 = $01 then Result := True

else

Result := False;

end;{function}

function AdapterToString(Adapter: TAdapterStatus): string;

begin

with Adapter do Result :=

Format(‘%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x’,

[Integer(adapter_address[0]), Integer(adapter_address[1]),

Integer(adapter_address[2]), Integer(adapter_address[3]),

Integer(adapter_address[4]), Integer(adapter_address[5])]);

end;{function}

function GetMacAddresses(const Machine: string;

const Addresses: TStrings): Integer;

const

NCBNAMSZ = 16; // absolute length of a net name

MAX_LANA = 254; // lana’s in range 0 to MAX_LANA inclusive

NRC_GOODRET = $00; // good return

NCBASTAT = $33; // NCB ADAPTER STATUS

NCBRESET = $32; // NCB RESET

NCBENUM = $37; // NCB ENUMERATE LANA NUMBERS

type

PNCB = ^TNCB;

TNCBPostProc = procedure(P: PNCB);

stdcall;

TNCB = record

ncb_command: Byte;

ncb_retcode: Byte;

ncb_lsn: Byte;

ncb_num: Byte;

ncb_buffer: PChar;

ncb_length: Word;

ncb_callname: array [0..NCBNAMSZ — 1] of char;

ncb_name: array [0..NCBNAMSZ — 1] of char;

ncb_rto: Byte;

ncb_sto: Byte;

ncb_post: TNCBPostProc;

ncb_lana_num: Byte;

ncb_cmd_cplt: Byte;

ncb_reserve: array [0..9] of char;

ncb_event: THandle;

end;

PLanaEnum = ^TLanaEnum;

TLanaEnum = record

Length: Byte;

lana: array [0..MAX_LANA] of Byte;

end;

ASTAT = record

adapt: TAdapterStatus;

namebuf: array [0..29] of TNameBuffer;

end;

var

NCB: TNCB;

Enum: TLanaEnum;

I: integer;

Adapter: ASTAT;

MachineName: string;

begin

Result := -1;

Addresses.Clear;

MachineName := UpperCase(Machine);

if MachineName = » then MachineName := ‘*’;

FillChar(NCB, SizeOf(NCB), #0);

NCB.ncb_command := NCBENUM;

NCB.ncb_buffer := Pointer(@Enum);

NCB.ncb_length := SizeOf(Enum);

if Word(NetBios(@NCB)) = NRC_GOODRET then

begin

Result := Enum.Length;

for I := 0 to Ord(Enum.Length) — 1 do

begin

FillChar(NCB, SizeOf(TNCB), #0);

NCB.ncb_command := NCBRESET;

NCB.ncb_lana_num := Enum.lana[I];

if Word(NetBios(@NCB)) = NRC_GOODRET then

begin

FillChar(NCB, SizeOf(TNCB), #0);

NCB.ncb_command := NCBASTAT;

NCB.ncb_lana_num := Enum.lana[i];

StrLCopy(NCB.ncb_callname, PChar(MachineName), NCBNAMSZ);

StrPCopy(@NCB.ncb_callname[Length(MachineName)],

StringOfChar(‘ ‘, NCBNAMSZ — Length(MachineName)));

NCB.ncb_buffer := PChar(@Adapter);

NCB.ncb_length := SizeOf(Adapter);

if Word(NetBios(@NCB)) = NRC_GOODRET then

Addresses.Add(AdapterToString(Adapter.adapt));

end;

end;

end;

end;{function}

{/codecitation}