Ver Mensaje Individual
  #4  
Antiguo 24-06-2003
__cadetill __cadetill is offline
Miembro
 
Registrado: may 2003
Posts: 3.387
Reputación: 27
__cadetill Va por buen camino
Bueno, para el rollo que te pongo a continuacion necesitas el componente TIdIcmpClient de las Indy

Creo que he logrado sacar todo lo que no te interesa (no se si sacando me abre pasado o no abre llegado ).

Esta unit lo que hace es recuperar el nombre y la IP de los equipos de una red. Lo de conectarse si tienen el mismo programa ya te lo dejo a ti

Espero te sirva

P.D. : empieza a mirarlo por el ultimo procedimiento que es donde esta la llamada a ObtenerIPs y, desde alli, ves mirando lo que hace cada uno de los procedures y functions

Código:
unit UCTerminales;

interface

uses
.......

type
  TCTerminales = class(TForm)
.....
    ICMP: TIdIcmpClient;
  private
    { Private declarations }
    ID2             : array of PItemiDList;
    Dir_ip          : String;
    procedure ICMPReply(ASender: TComponent; const ReplyStatus: TReplyStatus);
    procedure Ping(var vHost : String);
    function GetComputerName: String;
    function OriginFolderNT: IShellFolder;
    function WinNT : Boolean;
    function Win2K : Boolean;

    procedure DisposePIDL(ID: PItemIDList);
    function  OriginFolder: IShellFolder;
    function  GetDisplayName(ShellFolder: IShellFolder; PIDL: PItemIDList): String;
    function  parser(Folder: IShellFolder; vPing: Boolean; Lista : TStringlist): Integer;
    function  EnumObjects( ShellFolder: IShellFolder): IEnumIDList;
    function ObtenerIPs(var Ips : TStringList) : boolean;

    procedure StripLastID(IDList: PItemIDList);
    function  CreatePIDL(Size: Integer): PItemIDList;
    function  GetPrevPIDL(PIDL: PItemIDList): PItemIDList;
    function  GetPIDLSize(IDList: PItemIDList): Integer;
    function  NextPIDL(IDList: PItemIDList): PItemIDList;
    function  CopyPIDL(IDList: PItemIDList): PItemIDList;
  public
    { Public declarations }
  end;

var
  CTerminales: TCTerminales;

implementation

{$R *.dfm}

function TCTerminales.WinNT : Boolean;
begin
     Result := Win32Platform = VER_PLATFORM_WIN32_NT;
end;

function TCTerminales.Win2K : Boolean;
begin
     Result := (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT);
end;

function TCTerminales.OriginFolderNT: IShellFolder;
var Desktop   : IShellFolder;
    S         : String;
    W         : WideString;
    P         : PWideChar;
    Len, Flags: LongWord;
    Machine, Workgroup, Network : PItemIDList;
    NetShell  : IShellFolder;
    Enum      : IEnumIDList;
    ID        : PItemIDList;
begin
     S := '\\'+GetComputerName;
     Len := Length(S);
     W := S;
     P := PWideChar(W);
     SHGetDesktopFolder(Desktop);
     Desktop.ParseDisplayName(0, nil, P, Len, Machine, Flags);
     Workgroup:=GetPrevPIDL(Machine);
     Network:=GetPrevPIDL(Workgroup);
     Desktop.BindToObject(Network, nil, IShellFolder, NetShell);
     Enum := EnumObjects(NetShell);
     Enum.Next(1, ID, Flags);
     NetShell.BindToObject(ID, nil, IShellFolder, Pointer(Result));
     DisposePIDL(Network);
     DisposePIDL(Workgroup);
end;

function TCTerminales.Parser(Folder: IShellFolder; vPing: Boolean; Lista : TStringlist): Integer;
var ID       : PItemiDList;
    EnumList : IEnumIDList;
    NumIDs   : LongWord;
    S        : String;
    Index    : Integer;
begin
     EnumList := EnumObjects(Folder);
     Index := 0;
     if Assigned(EnumList) then
        while EnumList.Next(1, ID, NumIDs) = S_OK do
        begin
              S := GetDisplayName(Folder, ID);
              if vping then
              begin
                   Ping(S);
                   Lista.add(S);
              end
              else
              begin
                   SetLength(ID2, index + 1);
                   ID2[index] := ID;
              end;
              inc(Index);
        end;
     Result := Index;
end;

function TCTerminales.EnumObjects(ShellFolder: IShellFolder): IEnumIDList;
const Flags = SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN;
begin
     ShellFolder.EnumObjects(0, Flags, Result);
end;

procedure TCTerminales.Ping(var vHost : String);
begin
     ICMP.OnReply := ICMPReply;
     ICMP.ReceiveTimeout := 1000;
     try
        ICMP.Host := vHost;
        ICMP.Ping;
        Application.ProcessMessages;
        vhost := vhost + '|' + Dir_ip;
     finally
     end;
end;

procedure TCTerminales.ICMPReply(ASender: TComponent; const ReplyStatus: TReplyStatus);
begin
     if ReplyStatus.BytesReceived > 0 then // respuesta de la otra máquina.
        Dir_ip := ReplyStatus.FromIpAddress; // -> direccion del Servidor
end;

function TCTerminales.GetComputerName: String;
var N   : Cardinal;
    Buf : array [0..MAX_COMPUTERNAME_LENGTH + 1] of AnsiChar;
begin
     N := SizeOf(Buf) - 1;
     Windows.GetComputerName(Buf, N);
     Result := PChar(@Buf[0]);
end;

function TCTerminales.CreatePIDL(Size: Integer): PItemIDList;
var Malloc : IMalloc;
    HR     : HResult;
begin
     Result := nil;
     HR := SHGetMalloc(Malloc);
     if Failed(HR) then Exit;
     try
        Result := Malloc.Alloc(Size);
        if Assigned(Result) then FillChar(Result^, Size, 0);
     finally
     end;
end;

procedure TCTerminales.DisposePIDL(ID: PItemIDList);
var Malloc : IMalloc;
begin
     if ID = nil then Exit;
     OLECheck(SHGetMalloc(Malloc));
     Malloc.Free(ID);
end;

function TCTerminales.GetPrevPIDL(PIDL: PItemIDList): PItemIDList;
var Temp : PItemIDList;
begin
     Temp := CopyPIDL(PIDL);
     if Assigned(Temp) then StripLastID(Temp);
     if Temp.mkid.cb <> 0 then Result := Temp
     else Result := nil;
end;

function TCTerminales.GetPIDLSize(IDList: PItemIDList): Integer;
begin
     Result := 0;
     if Assigned(IDList) then
      begin
           Result := SizeOf(IDList^.mkid.cb);
           while IDList^.mkid.cb <> 0 do
            begin
                 Result := Result + IDList^.mkid.cb;
                 IDList := NextPIDL(IDList);
            end;
      end;
end;

procedure TCTerminales.StripLastID(IDList: PItemIDList);
var MarkerID: PItemIDList;
begin
     MarkerID := IDList;
     if Assigned(IDList) then
      begin
           while IDList.mkid.cb <> 0 do
            begin
                 MarkerID := IDList;
                 IDList := NextPIDL(IDList);
            end;
           MarkerID.mkid.cb := 0;
      end;
end;

function TCTerminales.NextPIDL(IDList: PItemIDList): PItemIDList;
begin
     Result := IDList;
     Inc(PChar(Result), IDList^.mkid.cb);
end;

function TCTerminales.CopyPIDL(IDList: PItemIDList): PItemIDList;
var Size : Integer;
begin
     Size := GetPIDLSize(IDList);
     Result := CreatePIDL(Size);
     if Assigned(Result) then CopyMemory(Result, IDList, Size);
end;

function TCTerminales.OriginFolder: IShellFolder;
var Desktop : IShellFolder;
    S       : String;
    P       : PWideChar;
    Len, Flags: LongWord;
    Machine, Workgroup, Network: PItemIDList;
begin
     S := '\\'+GetComputerName;
     Len := Length(S);
     P := StringToOleStr(S);
     Flags := 0;
     SHGetDesktopFolder(Desktop);
     Desktop.ParseDisplayName(0, nil, P, Len, Machine, Flags);
     Workgroup := GetPrevPIDL(Machine);
     try
        Network := GetPrevPIDL(Workgroup);
        try
           Desktop.BindToObject(Network, nil, IShellFolder, Pointer(Result));
        finally
               DisposePIDL(Network);
        end;
     finally
            DisposePIDL(Workgroup);
     end;
end;

function TCTerminales.GetDisplayName(ShellFolder: IShellFolder;
  PIDL: PItemIDList): String;
var StrRet : TStrRet;
    P      : PChar;
begin
     Result := '';
     ShellFolder.GetDisplayNameOf(PIDL, SHGDN_NORMAL, StrRet);
     case StrRet.uType of
          STRRET_CSTR   : SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
          STRRET_OFFSET : begin
                               P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
                               SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
                          end;
          STRRET_WSTR: Result := StrRet.pOleStr;
     end;
end;

function TCTerminales.ObtenerIPs(var Ips : TStringList) : boolean;
var Network   : IShellFolder;
    Workgroup : IShellFolder;
    i, Redes  : Integer;
begin
     Result := true;

     if WinNT and (not Win2K) then Network := OriginFolderNT
     else Network := OriginFolder;
     redes := Parser(Network, false, Ips);
     try
         for i := 0 to Redes - 1 do
         begin
              Network.BindToObject(ID2[i], nil, IShellFolder, Workgroup);
              Parser(Workgroup, TRUE, Ips);
              Workgroup := nil;
         end;
     except
           Result := false;
     end;
end;

procedure TCTerminales.A_BuscaIPsExecute(Sender: TObject);
var Ips : TStringList;
begin
     Ips := TStringList.Create;
     try
        Screen.Cursor := crHourglass;
        ObtenerIPs(Ips);
        Screen.Cursor := crDefault;
     finally
            Ips.Free;
            Screen.Cursor := crDefault;
     end;
end;

end.

Última edición por __cadetill fecha: 24-06-2003 a las 20:01:16.
Responder Con Cita