FAQ VCL
Сеть

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как получить IP-адрес?

// Способ первый
// На компьютере может быть установлено несколько сетевых
// плат, тогда у этого компьютера будет несколько IP-адресов.
// Эта процедура найдет все IP-адреса.

uses
  {...,} WinSock;

procedure TForm1.Button1Click(Sender: TObject);
type
  InAddr = array [0..10] of PInAddr;
  TInAddr = ^InAddr;
var
  Host: PHostEnt;
  pPtr: TInAddr;
  Buffer: array [0..63] of AnsiChar;
  i: Integer;
  Socket: TWSAData;
begin
  ListBox1.Clear;
  WSAStartup($101, Socket);
  GetHostName(Buffer, SizeOf(Buffer));
  Host := GetHostByName(Buffer);

  if Host = nil then
    Exit;

  i := 0;
  pPtr := TInAddr(Host^.h_addr_list);
  while pPtr^[i] <> nil do
  begin
    ListBox1.Items.Add(inet_ntoa(pPtr^[i]^));
    Inc(i);
  end;
  WSACleanup;
end;

// Способ второй
uses
  IdStack;

function LocalIP: string;
var
  AAddresses: TStrings;
begin
   AAddresses := TStringList.Create;
   try
      TIdStack.IncUsage;
      try
         GStack.AddLocalAddressesToList( AAddresses );
      finally
         TIdStack.DecUsage;
      end;
      if AAddresses.Count > 0 then
         Result := AAddresses.Strings[0];
   finally
      AAddresses.Free;
   end;
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
   ShowMessage( LocalIP );
end;

// Способ третий
// С помощью TIdUDPServer посылаем широковещательное сообщение, и с его же помощью
// сами получаем его и в ABinding узнаем с какого IP оно пришло. Таким образом мы
// узнаем IP адрес интерфейса с маршрутом по умолчанию. 

uses
  {...,} IdBaseComponent, IdComponent, IdUDPBase, IdUDPServer, IdGlobal, IdSocketHandle;

type
  TForm1 = class(TForm)
    IdUDPServer: TIdUDPServer;
  private
    FMyIP: string;
    procedure OnUDPServerUDPRead(AThread: TIdUDPListenerThread;
      const AData: TIdBytes; ABinding: TIdSocketHandle);
  {...}
  end;

var
  Form1: TForm1;

implementation

const
  ConstUDPSendString = 'eryt54634edf';

procedure TForm1.Button1Click(Sender: TObject);
begin
   IdUDPServer := TIdUDPServer.Create;
   IdUDPServer.DefaultPort := 46734;
   IdUDPServer.BroadcastEnabled := True;
   IdUDPServer.OnUDPRead := OnUDPServerUDPRead;
   IdUDPServer.Active := True;
   IdUDPServer.Broadcast(ConstUDPSendString, IdUDPServer.DefaultPort);

   while FMyIP = '' do
      Application.ProcessMessages;
   ShowMessage(FMyIP);

   IdUDPServer.Destroy;
end;

procedure TForm1.OnUDPServerUDPRead(AThread: TIdUDPListenerThread;
  const AData: TIdBytes; ABinding: TIdSocketHandle);
begin
   AThread.Synchronize(AThread,
      procedure
      begin
         if BytesToString(AData).Equals(ConstUDPSendString) and FMyIP.IsEmpty then
            FMyIP := ABinding.PeerIP;
      end
   );
end;


Как получить список компьютеров в рабочей группе?

procedure TForm1.FindAllComputers(Workgroup: String);
var
  Computer: array[1..500] of string[25];
  ComputerCount: integer;
  EnumHandle: THandle;
  WorkgroupRS: TNetResource;
  Buf: array[1..500] of TNetResource;
  BufSize: cardinal;
  Entries: cardinal;
  Result: integer;
  i: 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 );
   for i := 1 to ComputerCount do
      ListBox1.Items.Add( Computer[i] );
end;


Как получить доменное имя по IP-адресу?

uses
  {...,} WinSock;

function TForm1.IPAddrToName(IPAddr : String): String; 
var
  SockAddrIn: TSockAddrIn;
  HostEnt: PHostEnt;
  WSAData: TWSAData;
begin
   WSAStartup( $101, WSAData );
   SockAddrIn.sin_addr.s_addr := inet_addr( PChar( IPAddr ) );
   HostEnt := gethostbyaddr( @SockAddrIn.sin_addr.S_addr, 4, AF_INET );
   if HostEnt <> nil then
      result := StrPas( Hostent^.h_name )
   else
      result := '';
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   Form1.Caption := IPAddrToName( Edit1.Text );
end;


Как получить IP-адрес по доменному имени?

uses
  {...,} WinSock;

function TForm1.HostToIP(Name: string; var Ip: string): boolean;
var
  wsdata: TWSAData;
  hostName: array [0..255] of char;
  hostEnt: PHostEnt;
  addr: PChar;
begin
   WSAStartup( $0101, wsdata );
   try
      gethostname( hostName, sizeof( hostName ) );
      StrPCopy( hostName, Name );
      hostEnt := gethostbyname( hostName );
      if Assigned( hostEnt ) then
         if Assigned( hostEnt^.h_addr_list ) then
         begin
            addr := hostEnt^.h_addr_list^;
            if Assigned( addr ) then
            begin
               Ip := Format( '%d.%d.%d.%d', [byte( addr[0] ),
                                             byte( addr[1] ),
                                             byte( addr[2] ),
                                             byte( addr[3] )] );
               Result := true;
            end
            else
               Result := false;
         end
         else
            Result := false
      else
         Result := false;
   finally
      WSACleanup;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  IP: string;
begin
   if HostToIp( 'www.decoding.dax.ru', IP ) then
      Caption := IP
   else
      Caption := 'не определено';
end;


Как просканировать все домены в локальной сети?

var
  Form1: TForm1;
  NetResource: PNetResource;
  ts: TStrings;

function TForm1.FillNetLevel(NetRes: PNetResource; list: TStrings): Word;
type
  PNRArr = ^TNRArr;
  TNRArr = array[0..59] of TNetResource;
var
  x: PNRArr;
  tnr: TNetResource;
  i: integer;
  EntrReq,
  SizeReq,
  twx: Cardinal;
  WSName: string;
begin
   Result := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_ANY,
                           RESOURCEUSAGE_CONTAINER, NetRes, 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;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ts := TStringList.Create;
   FillNetLevel( NetResource, ts );
   ListBox1.Items := ts;
end;


Как узнать все доступные сетевые pесуpсы?

uses
  {...,} ComCtrls;

type
  PNetResourceArray = ^TNetResourceArray;
  TNetResourceArray = array[0..MaxInt div SizeOf( TNetResource )-1] of TNetResource;

procedure EnumResources(LpNR: PNetResource);
var
  NetHandle: THandle;
  BufSize: integer;
  Size: integer;
  NetResources: PNetResourceArray;
  Count: Integer;
  NetResult: integer;
  i: integer;
  NewItem: TListItem;
begin
   if WNetOpenEnum( RESOURCE_GLOBALNET,
                    RESOURCETYPE_ANY,
                    // RESOURCETYPE_ANY - все ресурсы
                    // RESOURCETYPE_DISK - диски
                    // RESOURCETYPE_PRINT - принтеры
                    0, LpNR, NetHandle) <> NO_ERROR then Exit;
   try
      BufSize := 50 * SizeOf( TNetResource );
      GetMem( NetResources, BufSize );
      try
         while true do
         begin
            Count := -1;
            Size := BufSize;
            NetResult := WNetEnumResource( NetHandle, Cardinal( Count ), NetResources, Cardinal( Size ) );
            if NetResult = ERROR_MORE_DATA then
            begin
               BufSize := Size;
               ReallocMem( NetResources, BufSize );
               Continue;
            end;
            if NetResult <> NO_ERROR then Exit;
            for i := 0 to Count-1 do
            begin
               with NetResources^[I] do
               begin
                  if RESOURCEUSAGE_CONTAINER = ( DwUsage and RESOURCEUSAGE_CONTAINER ) then
                     EnumResources(@NetResources^[I]);
                  if dwDisplayType = RESOURCEDISPLAYTYPE_SHARE then
                  // ^^^^^^^^^^^^^^^^^^^^^^^^^^ - ресурс
                  // RESOURCEDISPLAYTYPE_SERVER - компьютер
                  // RESOURCEDISPLAYTYPE_DOMAIN - рабочая группа
                  // RESOURCEDISPLAYTYPE_GENERIC - сеть
                  begin
                     NewItem := Form1.ListView1.Items.Add;
                     NewItem.Caption := LpRemoteName;
                  end;
               end;
            end;
         end;
      finally
         FreeMem( NetResources, BufSize );
      end;
   finally
      WNetCloseEnum( NetHandle );
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  OldCursor: TCursor;
begin
   OldCursor := Screen.Cursor;
   Screen.Cursor := crHourGlass;
   with ListView1.Items do
   begin
      BeginUpdate;
      Clear;
      EnumResources( nil );
      EndUpdate;
   end;
   Screen.Cursor := OldCursor;
end;


Как изменить NetBios-имя компьютера?

function SetComputerName( AComputerName: string ): boolean;
var
  ComputerName: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char;
begin
   StrPCopy( ComputerName, AComputerName );
   Result := Windows.SetComputerName( ComputerName );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if SetComputerName( 'NewName' ) then
      ShowMessage( 'Новое имя начнет использоваться после перезагрузки.' )
   else
      ShowMessage( 'Не удалось изменить имя.' );
end;


Как синхронизировать два компьютера по времени?

// В качестве параметра передается IP или имя
// компьютера, с которым нужно синхронизироваться
procedure SynchronizationComp( Server: string );
begin
   WinExec( PAnsiChar( 'net time \\' + Server + ' /set /yes' ), SW_HIDE );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   SynchronizationComp( '10.0.0.1' );
end;


Как получить время удаленного компьютера?

// Пример использования NetRemoteTOD
type
  PTIME_OF_DAY_INFO = ^TIME_OF_DAY_INFO;
  TIME_OF_DAY_INFO = record
    tod_elapsedt : DWORD;
    tod_msecs    : DWORD;
    tod_hours    : DWORD;
    tod_mins     : DWORD;
    tod_secs     : DWORD;
    tod_hunds    : DWORD;
    tod_timezone : Longint;
    tod_tinterval: DWORD;
    tod_day      : DWORD;
    tod_month    : DWORD;
    tod_year     : DWORD;
    tod_weekday  : DWORD;
  end;

  function NetRemoteTOD(Server: PWChar; var pBuffer: PTIME_OF_DAY_INFO): DWORD;
    stdcall; external 'NETAPI32.DLL';
  function NetApiBufferFree(pBuffer: Pointer): DWORD;
    stdcall; external 'NETAPI32.DLL';

{...}

implementation

{...}

procedure TForm1.Button1Click(Sender: TObject);
var
  TOD: PTIME_OF_DAY_INFO;
begin
   if NetRemoteTOD( '\\10.0.5.160', TOD ) = 0 then
      try
         with TOD^ do
            ShowMessage( Format( 'Data %.2d.%.2d.%.4d Time %.2d:%.2d:%.2d',
                                 [tod_day, tod_month, tod_year,
                                  tod_hours - ( tod_timezone div 60 ),
                                  tod_mins, tod_secs] ) );
      finally
         NetApiBufferFree( TOD );
      end
   else
      RaiseLastOSError;
end;


Как получить снимок с IP камеры?

uses
  {...,} IdHTTP, jpeg;

type
  TForm1 = class(TForm)
    IdHTTP1: TIdHTTP;
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    MMS: TMemoryStream;
    Jpg: TJPEGImage;
  public
  end;

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
   MMS := TMemoryStream.Create;
   Jpg := TJpegImage.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
   Jpg.Free;
   MMS.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   MMS.Clear;
   IdHTTP1.Get( 'http://10.0.7.203:8080/shot.jpg', MMS );
   MMS.Position := 0;
   Jpg.LoadFromStream( MMS );
   Image1.Picture.Assign( Jpg );
end;

При использовании материала - ссылка на сайт обязательна