Форум на Исходниках.RU

// Демонстрационная программа получения информации о компьютере

// на основе IP адреса

// Автор: Александр (Rouse_) Багель

// 30 декабря 2004

// =============================================================

// Специально для FAQ сайта Мастера Дельфи и Исходники.RU

// http://www.delphimaster.ru

// http://forum.sources.ru

// Windows9x, Windows Millenium не поддерживются

// Примечание: Я не любитель венгерской нотации в отношении переменных

// и давно выработал собственный, удобный для меня, стиль написания кода,

// (да и начальство не против :) поэтому не судить строго ;)

unit uMain;

{$DEFINE RUS}

interface

uses

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

Dialogs, StdCtrls, ComCtrls, CommCtrl, Winsock;

const

{$IFDEF RUS}

RES_UNKNOWN = 'Неизвестно';

RES_IP = 'IP адрес: ';

RES_CMP = 'Имя компьютера: ';

RES_USR = 'Имя пользователя: ';

RES_DOM = 'Домен: ';

RES_SER = 'Сервер домена: ';

RES_COM = 'Коментарий: ';

RES_PROV = 'Провайдер: ';

RES_GRP = 'Группы: ';

RES_MAC = 'MAC адресс: ';

RES_SHARES = 'Доступные ресурсы: ';

RES_TIME = 'Времени затрачено: ';

RES_COM_NO = 'Отсутствует';

{$ELSE}

RES_UNKNOWN = 'Unknown';

RES_IP = 'IP adress: ';

RES_CMP = 'Computer name: ';

RES_USR = 'User name: ';

RES_DOM = 'Domen: ';

RES_SER = 'Domen server: ';

RES_COM = 'Comment: ';

RES_PROV = 'Provider: ';

RES_GRP = 'Groups: ';

RES_MAC = 'MAC adress: ';

RES_SHARES = 'Available shares: ';

RES_TIME = 'Expended time: ';

RES_COM_NO = 'Absent';

{$ENDIF}

WSA_TYPE = 1; //2;

// Для работы с ARP (Address Resolution Protocol) таблицей

IPHLPAPI = 'IPHLPAPI.DLL';

MAX_ADAPTER_ADDRESS_LENGTH = 7;

type

LMSTR = LPWSTR;

NET_API_STATUS = DWORD;

// Следующие три типа используются для работы с Iphlpapi.dll

// Выдрал из Iphlpapi.h

// Так будет выглядеть МАС

TMacAddress = array[0..MAX_ADAPTER_ADDRESS_LENGTH] of byte;

// Это структура для единичного запроса

TMibIPNetRow = packed record

dwIndex : DWORD;

dwPhysAddrLen : DWORD;

bPhysAddr : TMACAddress; // Вот здесь и лежит МАС!!!

dwAddr : DWORD;

dwType : DWORD;

end;

// Как и в статье не будем выделять память динамически,

// а сразу создадим массив... (хотя, чесно говоря, это не правильно,

// но я иду простым путем :)

TMibIPNetRowArray = array [0..512] of TMibIPNetRow;

// А это, как и во всей библиотеке, такая вот...

// запрашиваемая структура (в моей статье уже видел пример...)

PTMibIPNetTable = ^TMibIPNetTable;

TMibIPNetTable = packed record

dwNumEntries : DWORD;

Table: TMibIPNetRowArray;

end;

// Структура для перечисления залогиненных пользователей

_WKSTA_USER_INFO_1 = record

wkui1_username: LPWSTR;

wkui1_logon_domain: LPWSTR;

wkui1_oth_domains: LPWSTR;

wkui1_logon_server: LPWSTR;

end;

WKSTA_USER_INFO_1 = _WKSTA_USER_INFO_1;

PWKSTA_USER_INFO_1 = ^_WKSTA_USER_INFO_1;

LPWKSTA_USER_INFO_1 = ^_WKSTA_USER_INFO_1;

// Структура для определения принадлежности пользователя к группам

PGroupUsersInfo0 = ^_GROUP_USERS_INFO_0;

_GROUP_USERS_INFO_0 = packed record

grui0_name: LPWSTR;

end;

TGroupUsersInfo0 = _GROUP_USERS_INFO_0;

GROUP_USERS_INFO_0 = _GROUP_USERS_INFO_0;

// Структура для отределения доступных сетевых ресурсов

PSHARE_INFO_1 = ^SHARE_INFO_1;

_SHARE_INFO_1 = record

shi1_netname: LMSTR;

shi1_type: DWORD;

shi1_remark: LMSTR;

end;

SHARE_INFO_1 = _SHARE_INFO_1;

TShareInfo1 = SHARE_INFO_1;

PShareInfo1 = PSHARE_INFO_1;

TMainForm = class(TForm)

gbIP: TGroupBox;

gbInfo: TGroupBox;

memInfo: TMemo;

btnGetInfo: TButton;

procedure btnGetInfoClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

IP, Font: Integer; // Это переменные для работы с

edIP: HWND; // WC_IPADDRESS классом

function GetNameFromIP(const IP: String): String;

function GetUsers(const CompName: String): String;

function GetDomain(const CompName, Provider: String): String;

function GetComment(CompName, Provider: String): String;

function GetProvider(const CompName: String): String;

function GetMacFromIP(const IP: String): String;

function GetDomainServer(const DomainName: String): String;

function GetGroups(DomainServer: String; UserName: String): String;

function GetShares(const CompName: String): String;

end;

// Объявим функции, так как их объявлений нет в Дельфи.

// Здесь идет статическая загрузка библиотек, только потому,

// что данные функции есть во всех системах, начиная с W95...

{$EXTERNALSYM WNetGetResourceInformation}

function WNetGetResourceInformation(lpNetResource: PNetResource;

lpBuffer: Pointer; var lpcbBuffer: DWORD; lplpSystem: Pointer): DWORD; stdcall;

{$EXTERNALSYM GetIpNetTable}

function GetIpNetTable(pIpNetTable: PTMibIPNetTable;

pdwSize: PULONG; bOrder: Boolean): DWORD; stdcall;

function WNetGetResourceInformation; external mpr name 'WNetGetResourceInformationA';

function GetIpNetTable; external IPHLPAPI name 'GetIpNetTable';

function NetGetAnyDCName(servername: LPCWSTR; domainname: LPCWSTR;

bufptr: Pointer): Cardinal;

stdcall; external 'netapi32.dll';

function NetShareEnum(servername: LMSTR; level: DWORD; var bufptr: Pointer;

prefmaxlen: DWORD; entriesread, totalentries,

resume_handle: LPDWORD): NET_API_STATUS; stdcall; external 'Netapi32.dll';

function NetApiBufferFree(buffer: Pointer): Cardinal;

stdcall; external 'netapi32.dll';

function NetWkstaUserEnum(ServerName: LPCWSTR;

Level: DWORD;

BufPtr: Pointer;

PrefMaxLen: DWORD;

EntriesRead: LPDWORD;

TotalEntries: LPDWORD;

ResumeHandle: LPDWORD): LongInt; stdcall; external 'netapi32.dll';

function NetUserGetGroups(ServerName: LPCWSTR;

UserName: LPCWSTR;

level: DWORD;

bufptr: Pointer;

prefmaxlen: DWORD;

var entriesread: DWORD;

var totalentries: DWORD): LongInt; stdcall; external 'netapi32.dll';

var

MainForm: TMainForm;

implementation

{$R *.dfm}

// Для ввода IP адреса будем использовать класс WC_IPADDRESS

// именно для этого и предназначеный...

procedure TMainForm.FormCreate(Sender: TObject);

begin

// Зададим первоначальный IP адрес (это адрес моей машины)

IP := MAKEIPADDRESS(192, 168, 2, 108);

// Инициализируем дополнительные классы библиотеки ComCtl32.dll.

InitCommonControl(ICC_INTERNET_CLASSES);

// Создадим само окошко (предком ему будет gbIP)

edIP:= CreateWindow(WC_IPADDRESS, nil, WS_CHILD or WS_VISIBLE,

6, 16, 100, 21, gbIP.Handle, 0, hInstance, nil);

// Укажем ему какой IP показывать

SendMessage(edIP, IPM_SETADDRESS, 0, IP);

// Подберем нужный шрифтик для него...

Font := CreateFont(-11, 0, 0, 0, 400, 0, 0, 0, DEFAULT_CHARSET,

OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,

DEFAULT_PITCH or FF_DONTCARE, 'MS Sans Serif');

// и скажем, чтоб он был с этим шрифтом (а то больно уж неказистый...)

SendMessage(edIP, WM_SETFONT, Font, 0);

end;

// Ну это короче понятно...

procedure TMainForm.btnGetInfoClick(Sender: TObject);

var

TmpCompName, TmpProvider, TmpGroup, TmpUser, TmpServer: String;

Time: Cardinal;

IPStr: String;

begin

Time := GetTickCount; // Засечем время...

// Узнаем, что за адрес введен... (он появится в IP)

SendMessage(edIP, IPM_GETADDRESS, 0, Longint(PDWORD(@IP)));

// Преобразуем эту абракадабру в нормальный "Dotted IP"

IPStr := IntToStr(FIRST_IPADDRESS(IP));

IPStr := IPStr + '.' + IntToStr(SECOND_IPADDRESS(IP));

IPStr := IPStr + '.' + IntToStr(THIRD_IPADDRESS(IP));

IPStr := IPStr + '.' + IntToStr(FOURTH_IPADDRESS(IP));

// Ну и начнем работать...

with memInfo, memInfo.Lines do // Вывод информации

begin

Clear; // Очищаем экран

Refresh; // Ну и обновляем...

// (при вызове первой функции может не обновиться)

Add(RES_IP + IPStr); // Выводим IP адрес

TmpCompName := GetNameFromIP(IPStr);

if TmpCompName = RES_UNKNOWN then Exit;

Add(RES_CMP + TmpCompName); // Выводим имя компьютера

TmpUser := GetUsers(IPStr);

Add(RES_USR + TmpUser); // Выводим имя пользователя

TmpProvider := GetProvider(TmpCompName);

Add(RES_PROV + TmpProvider); // Выводим провайдера

Add(RES_COM + GetComment(TmpCompName,

TmpProvider)); // Выводим комментарий к ресурсу

TmpGroup := GetDomain(TmpCompName, TmpProvider);

Add(RES_DOM + TmpGroup); // Выводим группу

TmpServer := GetDomainServer(TmpGroup);

if TmpServer <> '' then

begin

Add(RES_SER + TmpServer); // Выводим имя сервера

Add(RES_GRP + GetGroups(TmpServer, TmpUser)); // Выводим группы домена в которые входит пользователь

end;

Add(RES_SHARES + GetShares(TmpCompName)); // Выводим список доступных ресурсов

Add(RES_MAC + GetMacFromIP(IPStr)); // Выводим МАС адрес

Add(RES_TIME + IntToStr(GetTickCount - Time)); // Сколько времени затрачено

end;

// Вообщето желательно запускать данную функцию отдельным потоком.

// Поясню: при отсутствии компьютера с заданным IP программа будет

// ожидать выполнения gethostbyaddr и на это время подвиснет.

function TMainForm.GetNameFromIP(const IP: String): String;

var

WSA: TWSAData;

Host: PHostEnt;

Addr: Integer;

Err: Integer;

begin

Result := RES_UNKNOWN;

Err := WSAStartup(WSA_TYPE, WSA);

if Err <> 0 then // Лучше пользоваться такой конструкцией,

begin // чтобы в случае ошибки можно было увидеть ее код.

ShowMessage(SysErrorMessage(GetLastError));

Exit;

end;

try

Addr := inet_addr(PChar(IP));

if Addr = INADDR_NONE then

begin

ShowMessage(SysErrorMessage(GetLastError));

WSACleanup;

Exit;

end;

Host := gethostbyaddr(@Addr, SizeOf(Addr), PF_INET);

if Assigned(Host) then // Обязательная проверка, в противном случае, при

Result := Host.h_name // отсутствии компьютера с заданым IP, получим AV

else

ShowMessage(SysErrorMessage(GetLastError));

finally

WSACleanup;

end;

// Перечисляем всех залогиненных на машине пользователей

// начинаем перечисления со второго пользователя, потомчто

// первым будет "имя компьютера"$

function TMainForm.GetUsers(const CompName: String): String;

var

Buffer, tmpBuffer: Pointer;

PrefMaxLen : DWORD;

Resume_Handle : DWORD;

EntriesRead : DWORD;

TotalEntries : DWORD;

I, Size : Integer;

PSrvr : PWideChar;

begin

PSrvr := nil;

try

// Переводим имя компьютера типа PWideChar

Size := Length(CompName);

GetMem(PSrvr, Size * SizeOf(WideChar) + 1);

StringToWideChar(CompName, PSrvr, Size + 1);

PrefMaxLen := DWORD(-1);

EntriesRead := 0;

TotalEntries := 0;

Resume_Handle := 0;

Buffer := nil;

// Получаем список пользователей на компьютере из PSrvr

if NetWkstaUserEnum( PSrvr, 1, @Buffer, PrefMaxLen, @EntriesRead,

@TotalEntries, @Resume_Handle) = S_OK then

begin

tmpBuffer := Pointer(DWORD(Buffer) + SizeOf(WKSTA_USER_INFO_1));

for I := 1 to TotalEntries - 1 do

begin

Result := Result + WKSTA_USER_INFO_1(tmpBuffer^).wkui1_username + ', ';

tmpBuffer := Pointer(DWORD(tmpBuffer) + SizeOf(WKSTA_USER_INFO_1));

end;

Result := Copy(Result, 1, Length(Result) - 2);

end

else

ShowMessage(SysErrorMessage(GetLastError));

finally

NetApiBufferFree(Buffer);

FreeMem(PSrvr);

end;

// Все-таки будем сканировать сеть, НО!!!

// Мы не будем производить рекурсивное сканирование ресурсов с

// dwDisplayType равным RESOURCEDISPLAYTYPE_SERVER!!!

// В основном все торможение происходить именно здесь,

// так как эти ресурсы являются так называемыми корневыми

// для компьютеров. Если компьютер отключен его имя может сохраниться

// в кэше и при попытке сканирования получим ненужные нам тормоза.

// В принципе, у меня эта функция выдавала неплохие результаты по скорости...

// (Около 31 мс - максимум с отображением на memInfo, сеть 100Мб, 28 компов)

function TMainForm.GetComment(CompName, Provider: String): String;

var

StopScan: Boolean;

TmpRes: TNetResource;

// Само сканирование

procedure Scan(Res: TNetResource; Root: boolean);

var

Enum, I: Cardinal;

ScanRes: array [0..512] of TNetResource; // Можно сделать и больший размер массива

Size, Entries, Err: DWORD; // но, как показывает практика, такого достаточно

begin

if StopScan then Exit; // Используем флаг для выхода из рекурсии

// Ну тут думаю все понятно... просто два типа начала сканирования

if Root = True then

Err := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

0, nil, Enum) // корневой...

else

Err := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

0, @Res, Enum); // и рекурсионный для поиска вложений...

if Err = NO_ERROR then

begin

Size := SizeOf(ScanRes);

Entries := DWORD(-1);

Err := WNetEnumResource(Enum, Entries, @ScanRes, Size);

if Err = NO_ERROR then

try

for I := 0 to Entries - 1 do

begin

if StopScan then Exit; // Еще один флаг, так как выход на верхний вызов

with ScanRes[i] do // может осуществиться из цикла

begin

if dwDisplayType = RESOURCEDISPLAYTYPE_SERVER then

if lpRemoteName = CompName then // если нашли наш компьютер...

begin

Result := lpComment; // вытаскиваем комментарий

StopScan := True; // и выставляем флаг для выхода из рекуссии

Exit;

end;

if dwDisplayType <> RESOURCEDISPLAYTYPE_SERVER then // не будем сканировать шары у компов...

Scan(ScanRes[i], False);

end;

finally

WNetCloseEnum(Enum);

end

else

if Err <> ERROR_NO_MORE_ITEMS then // Нет элементов для отображения...

MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOK], 0);

end

else

ShowMessage(SysErrorMessage(GetLastError));

end;

// Основная процедура

begin

// Подготовительные действия...

Result := RES_UNKNOWN;

if CompName = RES_UNKNOWN then Exit; // Если имя компа не найдено,

// незачем и продолжать.

CompName := '\' + CompName; // Подправим имя,

// чтоб не делать это далее в цикле...

StopScan := False; // Снимем флаг выхода из рекурсии.

// Здесь обязательно инициализирование переменной

// типа Boolean, так как было замечено, что

// некоторые версии Дельфи криво инициализируют

// значение по умолчанию, после чего логические

// операторы типа AND - OR - NOT перестают работать.

// Например: по умолчанию переменная StopScan равна False

// без инициализации, после StopScan := not StopScan;

// переменная StopScan НЕ ВСЕГДА станет True!!!

// Запускаем сканирование...

// (можно и в потоке, но у меня время на сканирование уходит 8 мс.)

Scan(TmpRes, True);

// И смотрим результаты...

if Result = '' then Result := RES_COM_NO;

end;

// Задача этой функции предельно проста:

// При известном имени компьютера мы можем заполнить структуру

// и передать ее функции WNetGetResourceParent которая и вернет

// нам предка, в моем случае группу.

// Да, чуть не забыл, если имя компьютера есть в кэше, а сам

// компьютер отключен, то в качестве результата будет либо

// пустая строка либо 'Нет данных'...

// Поэтому опять придется сканировать, если слишком уж критично...

function TMainForm.GetDomain(const CompName, Provider: String): String;

var

CurrRes: TNetResource;

ParentName: array [0..1] of TNetResource;

Enum: DWORD;

Err: Integer;

begin

with CurrRes do

begin

dwScope := RESOURCE_GLOBALNET;

dwType := RESOURCETYPE_DISK;

dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;

dwUsage := RESOURCEUSAGE_CONTAINER;

lpLocalName := '';

lpRemoteName := PChar('\' + CompName);

lpComment := '';

lpProvider := PChar(Provider);

end;

Enum := SizeOf(ParentName);

Err := WNetGetResourceParent(@CurrRes, @ParentName, Enum);

if Err = NO_ERROR then

begin

Result := ParentName[0].lpRemoteName;

if Result = '' then Result := RES_COM_NO;

end

else

ShowMessage(SysErrorMessage(GetLastError));

end;

// А этой функцией мы можем узнать провайдера

// (в основном это Microsoft Network).

function TMainForm.GetProvider(const CompName: String): String;

var

Buffer: array [0..255] of Char;

Size: DWORD;

begin

Size := SizeOf(Buffer);

if WNetGetProviderName(WNNC_NET_LANMAN, @Buffer, Size) <> NO_ERROR then

Result := RES_COM_NO

else

Result := String(Buffer);

end;

// Из всех приведенных функций эта самая интересная.

// Я много раз говорил о незаслуженном невнимании программистов

// к IPHLPAPI.DLL. Данный пример подтверждает это. На всех форумах

// можно услышать о получании МАС адреса посредством посылки IPX пакета

// и разбора заголовка ответа от удаленного компьютера

// (что само по себе геморой, если не принимать во внимание,

// что IPX уже практически вымер, и его мало где встретишь).

// Здесь же строится полная ARP таблица, на основании которой мы

// можем спокойно произвести выборку по нужному IP адресу,

// а так как все берется из кэша, то мы сможем узнать МАС адреса

// даже выключенных компьютеров...

// Единственный минус: в таблице (не всегда) отсутсвует информация

// по локальному компьютеру, т.е. таким образом можно получить

// все МАС адреса за исключением своего,

// но для этого есть уже другие функции...

// Приведу выдержку из MSDN:

// You can use IP Helper to perform Address Resolution Protocol (ARP) operations for the local computer.

// Use the following functions to retrieve and modify the ARP table.

// The GetIpNetTable retrieves the ARP table.

// The ARP table contains the mapping of IP addresses to physical addresses.

// Physical addresses are sometimes referred to as Media Access Controller (MAC) addresses.

// Хочу заметить что для NT есть очень интересная функция SendARP - позволяющая

// напрямую получить требуемый МАС без построения таблицы, поэтому советую

// модифицировать код программы для более эффективного исполнения участков кода

// под различными системами.

function TMainForm.GetMacFromIP(const IP: String): String;

// (Будем использовать функцию приведения из статьи)

// В качестве первого значения массив, второе значение,

// размер данных в массиве

function GetMAC(Value: TMacAddress; Length: DWORD): String;

var

I: Integer;

begin

if Length = 0 then Result := '00-00-00-00-00-00' else

begin

Result := '';

for i:= 0 to Length -2 do

Result := Result + IntToHex(Value[i], 2) + '-';

Result := Result + IntToHex(Value[Length-1], 2);

end;

// Получаем IP адрес, заметь в отличии от работы с классом WC_IPADDRESS

// здесь преобразование идет в обратном порядке!

function GetDottedIPFromInAddr(const InAddr: Integer): String;

begin

Result := '';

Result := IntToStr(FOURTH_IPADDRESS(InAddr));

Result := Result + '.' + IntToStr(THIRD_IPADDRESS(InAddr));

Result := Result + '.' + IntToStr(SECOND_IPADDRESS(InAddr));

Result := Result + '.' + IntToStr(FIRST_IPADDRESS(InAddr));

end;

// Основная функция

var

Table: TMibIPNetTable;

Size: Integer;

CatchIP: String;

Err, I: Integer;

begin

Result := RES_UNKNOWN;

Size := SizeOf(Table); // Ну тут все просто...

Err := GetIpNetTable(@Table, @Size, False); // Выполняем...

if Err <> NO_ERROR then // Проверка на ошибку...

begin

ShowMessage(SysErrorMessage(GetLastError));

Exit;

end;

// Теперь мы имеем таблицу из IP адресов и соответсвующих им MAC адресов

for I := 0 to Table.dwNumEntries - 1 do // Ищем нужный IP ...

begin

CatchIP := GetDottedIPFromInAddr(Table.Table[I].dwAddr);

if CatchIP = IP then // И выводим его МАС ...

begin

Result := GetMAC(Table.Table[I].bPhysAddr, Table.Table[I].dwPhysAddrLen);

Break;

end;

// Полуение доступных сетевых ресурсов на удаленном компьютере

function TMainForm.GetShares(const CompName: String): String;

type TShareInfo1Array = array of TShareInfo1;

var

entriesread, totalentries: DWORD;

Info: Pointer;

I: Integer;

CN: PWideChar;

begin

CN := StringToOleStr(CompName);

// так как нам нужны только имена ресурсов, воспользуемся струтурой TShareInfo1

// тогда, не нужно будет получать привилегии администратора на удаленной машине :)

if NetShareEnum(CN, 1, Info, DWORD(-1), @entriesread,

@totalentries, nil) = 0 then

try // список ресурсов смотрим здесь

if entriesread > 0 then

for I := 0 to entriesread - 1 do

Result := Result + TShareInfo1Array(@(Info^))[I].shi1_netname + ' ';

finally

NetApiBufferFree(Info);

end;

// Вот таким простым путем будем получать имя сервера домена

function TMainForm.GetDomainServer(const DomainName: String): String;

var

Domain, Server: PWideChar;

begin

GetMem(Domain, MAX_PATH);

try

StringToWideChar(DomainName, Domain, MAX_PATH);

if NetGetAnyDCName(nil, Domain, @Server)= NO_ERROR then

try

Result := WideCharToString(Server);

finally

NetApiBufferFree(Server);

end;

finally

FreeMem(Domain, MAX_PATH);

end;

// перечисление доменных групп в которые входит пользователь

function TMainForm.GetGroups(DomainServer: String; UserName: String): String;

type

TGroupUsersInfoArray = array of TGroupUsersInfo0;

var

Info: PGroupUsersInfo0;

Sn, Un: PWideChar;

entriesread, totalentries: DWORD;

I, A, B, Size: Integer;

P: Pointer;

begin

// нам нужно только имя сервера домена

Sn := StringToOLEStr(DomainServer);

// и имя пользователя

Un := StringToOleStr(UserName);

// делаем запрос

if NetUserGetGroups(Sn, Un, 0, @Info, DWORD(-1), entriesread, totalentries) = NO_ERROR then

try // и смотрим, что там у нас получилось

if entriesread > 0 then

for I := 0 to entriesread - 1 do

Result := Result + TGroupUsersInfoArray(@(Info^))[I].grui0_name + ' ';

finally

NetApiBufferFree(Info);

end;

end.