Delphi网络函数

unit net;

interface
  uses
      sysutils
     ,windows
     ,dialogs
     ,winsock
     ,classes
     ,comobj
     ,wininet;

  //得到本机的局域网ip地址
  function getlocalip(var localip:string): boolean;
  //通过ip返回机器名
  function getnamebyipaddr(ipaddr: string; var macname: string): boolean ;
  //获取网络中sqlserver列表
  function getsqlserverlist(var list: tstringlist): boolean;
  //获取网络中的所有网络类型
  function getnetlist(var list: tstringlist): boolean;
  //获取网络中的工作组
  function getgrouplist(var list: tstringlist): boolean;
  //获取工作组中所有计算机
  function getusers(groupname: string; var list: tstringlist): boolean;
  //获取网络中的资源
  function getuserresource(ipaddr: string; var list: tstringlist): boolean;
  //映射网络驱动器
  function netaddconnection(netpath: pchar; password: pchar;localpath: pchar): boolean;
  //检测网络状态
  function checknet(ipaddr:string): boolean;
  //检测机器是否登入网络
  function checkmacattachnet: boolean;

  //判断ip协议有没有安装   这个函数有问题
  function isipinstalled : boolean;
  //检测机器是否上网
  function internetconnected: boolean;
implementation

{=================================================================
  功  能: 检测机器是否登入网络
  参  数: 无
  返回值: 成功:  true  失败:  false
  备 注:
  版 本:
     1.0  2002/10/03 09:55:00
=================================================================}
function checkmacattachnet: boolean;
begin
  result := false;
  if getsystemmetrics(sm_network) <> 0 then
    result := true;
end;

{=================================================================
  功  能: 返回本机的局域网ip地址
  参  数: 无
  返回值: 成功:  true, 并填充localip   失败:  false
  备 注:
  版 本:
     1.0  2002/10/02 21:05:00
=================================================================}
function getlocalip(var localip: string): boolean;
var
    hostent: phostent;
    ip: string;
    addr: pchar;
    buffer: array [0..63] of char;
    ginitdata: twsadata;
begin
  result := false;
  try
    wsastartup(2, ginitdata);
    gethostname(buffer, sizeof(buffer));
    hostent := gethostbyname(buffer);
    if hostent = nil then exit;
    addr := hostent^.h_addr_list^;
    ip := format(''%d.%d.%d.%d'', [byte(addr [0]),
          byte (addr [1]), byte (addr [2]), byte (addr [3])]);
    localip := ip;
    result := true;
  finally
    wsacleanup;
  end;
end;

{=================================================================
  功  能: 通过ip返回机器名
  参  数:
          ipaddr: 想要得到名字的ip
  返回值: 成功:  机器名   失败:  ''''
  备 注:
    inet_addr function converts a string containing an internet
    protocol dotted address into an in_addr.
  版 本:
    1.0  2002/10/02 22:09:00
=================================================================}
function getnamebyipaddr(ipaddr : string;var macname:string): boolean;
var
  sockaddrin: tsockaddrin;
  hostent: phostent;
  wsadata: twsadata;
begin
  result := false;
  if ipaddr = '''' then exit;
  try
    wsastartup(2, wsadata);
    sockaddrin.sin_addr.s_addr := inet_addr(pchar(ipaddr));
    hostent := gethostbyaddr(@sockaddrin.sin_addr.s_addr, 4, af_inet);
    if hostent <> nil then
      macname := strpas(hostent^.h_name);
    result := true;
  finally
    wsacleanup;
  end;
end;

{=================================================================
  功  能: 返回网络中sqlserver列表
  参  数:
          list: 需要填充的list
  返回值: 成功:  true,并填充list  失败 false
  备 注:
  版 本:
    1.0  2002/10/02 22:44:00
=================================================================}
function getsqlserverlist(var list: tstringlist): boolean;
var
   i: integer;
   sretvalue: string;
   sqlserver: variant;
   serverlist: variant;
begin
  result := false;
  list.clear;
  try
    sqlserver := createoleobject(''sqldmo.application'');
    serverlist := sqlserver.listavailablesqlservers;
    for i := 1 to serverlist.count do
      list.add (serverlist.item(i));
    result := true;
  finally
    sqlserver := null;
    serverlist := null;
  end;
end;

{=================================================================
  功  能: 判断ip协议有没有安装
  参  数: 无
  返回值: 成功:  true 失败: false;
  备 注:   该函数还有问题
  版 本:
     1.0  2002/10/02 21:05:00
=================================================================}
function isipinstalled : boolean;
var
  wsdata: twsadata;
  protoent: pprotoent;
begin
  result := true;
  try
    if wsastartup(2,wsdata) = 0 then
    begin
      protoent := getprotobyname(''ip'');
      if protoent = nil then
        result := false
    end;
  finally
    wsacleanup;
  end;
end;

{=================================================================
  功  能: 返回网络中的共享资源
  参  数:
          ipaddr: 机器ip
          list: 需要填充的list
  返回值: 成功:  true,并填充list 失败: false;
  备 注:
     wnetopenenum function starts an enumeration of network
     resources or existing connections.
     wnetenumresource function continues a network-resource
     enumeration started by the wnetopenenum function.
  版 本:
     1.0  2002/10/03 07:30:00
=================================================================}
function getuserresource(ipaddr: string; var list: tstringlist): boolean;
type
  tnetresourcearray = ^tnetresource;//网络类型的数组
var
  i: integer;
  buf: pointer;
  temp: tnetresourcearray;
  lphenum: thandle;
  netresource: tnetresource;
  count,bufsize,res: dword;
begin
  result := false;
  list.clear;
  if copy(ipaddr,0,2) <> ''\\'' then
    ipaddr := ''\\''+ipaddr;   //填充ip地址信息
  fillchar(netresource, sizeof(netresource), 0);//初始化网络层次信息
  netresource.lpremotename := @ipaddr[1];//指定计算机名称
  //获取指定计算机的网络资源句柄
  res := wnetopenenum( resource_globalnet, resourcetype_any,
                      resourceusage_connectable, @netresource,lphenum);
  if res <> no_error then exit;//执行失败
  while true do//列举指定工作组的网络资源
  begin
    count := $ffffffff;//不限资源数目
    bufsize := 8192;//缓冲区大小设置为8k
    getmem(buf, bufsize);//申请内存，用于获取工作组信息
    //获取指定计算机的网络资源名称
    res := wnetenumresource(lphenum, count, pointer(buf), bufsize);
    if res = error_no_more_items then break;//资源列举完毕
    if (res <> no_error) then exit;//执行失败
    temp := tnetresourcearray(buf);
    for i := 0 to count - 1 do
    begin
       //获取指定计算机中的共享资源名称，+2表示删除"\\"，
       //如\\192.168.0.1 => 192.168.0.1
       list.add(temp^.lpremotename + 2);
       inc(temp);
    end;
  end;
  res := wnetcloseenum(lphenum);//关闭一次列举
  if res <> no_error then exit;//执行失败
  result := true;
  freemem(buf);
end;

{=================================================================
  功  能: 返回网络中的工作组
  参  数:
          list: 需要填充的list
  返回值: 成功:  true,并填充list 失败: false;
  备  注:
  版  本:
     1.0  2002/10/03 08:00:00
=================================================================}
function getgrouplist( var list : tstringlist ) : boolean;
type
  tnetresourcearray = ^tnetresource;//网络类型的数组
var
  netresource: tnetresource;
  buf: pointer;
  count,bufsize,res: dword;
  lphenum: thandle;
  p: tnetresourcearray;
  i,j: smallint;
  networktypelist: tlist;
begin
  result := false;
  networktypelist := tlist.create;
  list.clear;
  //获取整个网络中的文件资源的句柄，lphenum为返回名柄
  res := wnetopenenum( resource_globalnet, resourcetype_disk,
                       resourceusage_container, nil,lphenum);
  if res <> no_error then exit;//raise exception(res);//执行失败
  //获取整个网络中的网络类型信息
  count := $ffffffff;//不限资源数目
  bufsize := 8192;//缓冲区大小设置为8k
  getmem(buf, bufsize);//申请内存，用于获取工作组信息
  res := wnetenumresource(lphenum, count, pointer(buf), bufsize);
     //资源列举完毕                    //执行失败
  if ( res = error_no_more_items ) or (res <> no_error ) then exit;
  p := tnetresourcearray(buf);
  for i := 0 to count - 1 do//记录各个网络类型的信息
  begin
    networktypelist.add(p);
    inc(p);
  end;
  res := wnetcloseenum(lphenum);//关闭一次列举
  if res <> no_error then exit;
  for j := 0 to networktypelist.count-1 do //列出各个网络类型中的所有工作组名称
  begin//列出一个网络类型中的所有工作组名称
    netresource := tnetresource(networktypelist.items[j]^);//网络类型信息
    //获取某个网络类型的文件资源的句柄，netresource为网络类型信息，lphenum为返回名柄
    res := wnetopenenum(resource_globalnet, resourcetype_disk,
                        resourceusage_container, @netresource,lphenum);
    if res <> no_error then break;//执行失败
    while true do//列举一个网络类型的所有工作组的信息
    begin
      count := $ffffffff;//不限资源数目
      bufsize := 8192;//缓冲区大小设置为8k
      getmem(buf, bufsize);//申请内存，用于获取工作组信息
      //获取一个网络类型的文件资源信息，
      res := wnetenumresource(lphenum, count, pointer(buf), bufsize);
          //资源列举完毕                   //执行失败
      if ( res = error_no_more_items ) or (res <> no_error)  then break;
      p := tnetresourcearray(buf);
      for i := 0 to count - 1 do//列举各个工作组的信息
      begin
        list.add( strpas( p^.lpremotename ));//取得一个工作组的名称
        inc(p);
      end;
    end;
    res := wnetcloseenum(lphenum);//关闭一次列举
    if res <> no_error then break;//执行失败
  end;
  result := true;
  freemem(buf);
  networktypelist.destroy;
end;

{=================================================================
  功  能: 列举工作组中所有的计算机
  参  数:
          list: 需要填充的list
  返回值: 成功:  true,并填充list 失败: false;
  备  注:
  版  本:
     1.0  2002/10/03 08:00:00
=================================================================}
function getusers(groupname: string; var list: tstringlist): boolean;
type
  tnetresourcearray = ^tnetresource;//网络类型的数组
var
  i: integer;
  buf: pointer;
  temp: tnetresourcearray;
  lphenum: thandle;
  netresource: tnetresource;
  count,bufsize,res: dword;
begin
  result := false;
  list.clear;
  fillchar(netresource, sizeof(netresource), 0);//初始化网络层次信息
  netresource.lpremotename := @groupname[1];//指定工作组名称
  netresource.dwdisplaytype := resourcedisplaytype_server;//类型为服务器（工作组）
  netresource.dwusage := resourceusage_container;
  netresource.dwscope := resourcetype_disk;//列举文件资源信息
  //获取指定工作组的网络资源句柄
  res := wnetopenenum( resource_globalnet, resourcetype_disk,
                        resourceusage_container, @netresource,lphenum);
  if res <> no_error then exit; //执行失败
  while true do//列举指定工作组的网络资源
  begin
    count := $ffffffff;//不限资源数目
    bufsize := 8192;//缓冲区大小设置为8k
    getmem(buf, bufsize);//申请内存，用于获取工作组信息
    //获取计算机名称
    res := wnetenumresource(lphenum, count, pointer(buf), bufsize);
    if res = error_no_more_items then break;//资源列举完毕
    if (res <> no_error) then exit;//执行失败
    temp := tnetresourcearray(buf);
    for i := 0 to count - 1 do//列举工作组的计算机名称
    begin
      //获取工作组的计算机名称，+2表示删除"\\"，如\\wangfajun=>wangfajun
      list.add(temp^.lpremotename + 2);
      inc(temp);
    end;
  end;
  res := wnetcloseenum(lphenum);//关闭一次列举
  if res <> no_error then exit;//执行失败
  result := true;
  freemem(buf);
end;

{=================================================================
  功  能: 列举所有网络类型
  参  数:
          list: 需要填充的list
  返回值: 成功:  true,并填充list 失败: false;
  备 注:
  版 本:
     1.0  2002/10/03 08:54:00
=================================================================}
function getnetlist(var list: tstringlist): boolean;
type
  tnetresourcearray = ^tnetresource;//网络类型的数组
var
  p: tnetresourcearray;
  buf: pointer;
  i: smallint;
  lphenum: thandle;
  netresource: tnetresource;
  count,bufsize,res: dword;
begin
  result := false;
  list.clear;
  res := wnetopenenum( resource_globalnet, resourcetype_disk,
                      resourceusage_container, nil,lphenum);
  if res <> no_error then exit;//执行失败
  count := $ffffffff;//不限资源数目
  bufsize := 8192;//缓冲区大小设置为8k
  getmem(buf, bufsize);//申请内存，用于获取工作组信息
  res := wnetenumresource(lphenum, count, pointer(buf), bufsize);//获取网络类型信息
      //资源列举完毕                    //执行失败
  if ( res = error_no_more_items ) or (res <> no_error ) then exit;
  p := tnetresourcearra

{=================================================================
  功  能: 映射网络驱动器
  参  数:
          netpath: 想要映射的网络路径
          password: 访问密码
          localpath 本地路径
  返回值: 成功:  true  失败: false;
  备 注:
  版 本:
     1.0  2002/10/03 09:24:00
=================================================================}
function netaddconnection(netpath: pchar; password: pchar
                          ;localpath: pchar): boolean;
var
  res: dword;
begin
  result := false;
  res := wnetaddconnection(netpath,password,localpath);
  if res <> no_error then exit;
  result := true;
end;

{=================================================================
  功  能:  检测网络状态
  参  数:
          ipaddr: 被测试网络上主机的ip地址或名称，建议使用ip
  返回值: 成功:  true  失败: false;
  备 注:
  版 本:
     1.0  2002/10/03 09:40:00
=================================================================}
function checknet(ipaddr: string): boolean;
type
  pipoptioninformation = ^tipoptioninformation;
  tipoptioninformation = packed record
     ttl:         byte;      // time to live (used for traceroute)
     tos:         byte;      // type of service (usually 0)
     flags:       byte;      // ip header flags (usually 0)
     optionssize: byte;      // size of options data (usually 0, max 40)
     optionsdata: pchar;     // options data buffer
  end;

  picmpechoreply = ^ticmpechoreply;
  ticmpechoreply = packed record
     address:       dword;                // replying address
     status:        dword;                // ip status value (see below)
     rtt:           dword;                // round trip time in milliseconds
     datasize:      word;                 // reply data size
     reserved:      word;
     data:          pointer;              // pointer to reply data buffer
     options:       tipoptioninformation; // reply options
  end;

  ticmpcreatefile = function: thandle; stdcall;
  ticmpclosehandle = function(icmphandle: thandle): boolean; stdcall;
  ticmpsendecho = function(
     icmphandle:          thandle;
     destinationaddress:  dword;
     requestdata:         pointer;
     requestsize:         word;
     requestoptions:      pipoptioninformation;
     replybuffer:         pointer;
     replysize:           dword;
     timeout:             dword
  ): dword; stdcall;

const
  size = 32;
  timeout = 1000;
var
  wsadata: twsadata;
  address: dword;                     // address of host to contact
  hostname, hostip: string;           // name and dotted ip of host to contact
  phe: phostent;                      // hostentry buffer for name lookup
  buffersize, npkts: integer;
  preqdata, pdata: pointer;
  pipe: picmpechoreply;               // icmp echo reply buffer
  ipopt: tipoptioninformation;        // ip options for packet to send
const
  icmpdll = ''icmp.dll'';
var
  hicmplib: hmodule;
  icmpcreatefile : ticmpcreatefile;
  icmpclosehandle: ticmpclosehandle;
  icmpsendecho:    ticmpsendecho;
  hicmp: thandle;                     // handle for the icmp calls
begin
  // initialise winsock
  result:=true;
  if wsastartup(2,wsadata) <> 0 then begin
     result:=false;
     halt;
  end;
  // register the icmp.dll stuff
  hicmplib := loadlibrary(icmpdll);
  if hicmplib <> null then begin
    @icmpcreatefile := getprocaddress(hicmplib, ''icmpcreatefile'');
    @icmpclosehandle:= getprocaddress(hicmplib, ''icmpclosehandle'');
    @icmpsendecho:= getprocaddress(hicmplib, ''icmpsendecho'');
    if (@icmpcreatefile = nil) or (@icmpclosehandle = nil) or (@icmpsendecho = nil) then begin
        result:=false;
        halt;
    end;
    hicmp := icmpcreatefile;
    if hicmp = invalid_handle_value then begin
      result:=false;
      halt;
    end;
  end else begin
    result:=false;
    halt;
  end;
// ------------------------------------------------------------
  address := inet_addr(pchar(ipaddr));
  if (address = inaddr_none) then begin
    phe := gethostbyname(pchar(ipaddr));
    if phe = nil then result:=false
    else begin
      address := longint(plongint(phe^.h_addr_list^)^);
      hostname := phe^.h_name;
      hostip := strpas(inet_ntoa(tinaddr(address)));
    end;
  end
  else begin
    phe := gethostbyaddr(@address, 4, pf_inet);
    if phe = nil then result:=false;
  end;

  if address = inaddr_none then
  begin
     result:=false;
  end;
  // get some data buffer space and put something in the packet to send
  buffersize := sizeof(ticmpechoreply) + size;
  getmem(preqdata, size);
  getmem(pdata, size);
  getmem(pipe, buffersize);
  fillchar(preqdata^, size, $aa);
  pipe^.data := pdata;

    // finally send the packet
  fillchar(ipopt, sizeof(ipopt), 0);
  ipopt.ttl := 64;
  npkts := icmpsendecho(hicmp, address, preqdata, size,
                        @ipopt, pipe, buffersize, timeout);
  if npkts = 0 then result:=false;

  // free those buffers
  freemem(pipe); freemem(pdata); freemem(preqdata);

// --------------------------------------------------------------
  icmpclosehandle(hicmp);
  freelibrary(hicmplib);
  // free winsock
  if wsacleanup <> 0 then result:=false;
end;

{=================================================================
  功  能:  检测计算机是否上网
  参  数:  无
  返回值:  成功:  true  失败: false;
  备 注:   uses wininet
  版 本:
     1.0  2002/10/07 13:33:00
=================================================================}
function internetconnected: boolean;
const
  // local system uses a modem to connect to the internet.
  internet_connection_modem      = 1;
  // local system uses a local area network to connect to the internet.
  internet_connection_lan        = 2;
  // local system uses a proxy server to connect to the internet.
  internet_connection_proxy      = 4;
  // local system''s modem is busy with a non-internet connection.
  internet_connection_modem_busy = 8;
var
  dwconnectiontypes : dword;
begin
  dwconnectiontypes := internet_connection_modem+ internet_connection_lan
  + internet_connection_proxy;
  result := internetgetconnectedstate(@dwconnectiontypes, 0);
end;

end.
//错误信息常量
unit head;

interface
const
  c_err_getlocalip       = ''获取本地ip失败'';
  c_err_getnamebyipaddr  = ''获取主机名失败'';
  c_err_getsqlserverlist = ''获取sqlserver服务器失败'';
  c_err_getuserresource  = ''获取共享资失败'';
  c_err_getgrouplist     = ''获取所有工作组失败'';
  c_err_getgroupusers    = ''获取工作组中所有计算机失败'';
  c_err_getnetlist       = ''获取所有网络类型失败'';
  c_err_checknet         = ''网络不通'';
  c_err_checkattachnet   = ''未登入网络'';
  c_err_internetconnected =''没有上网'';
 
  c_txt_checknetsuccess  = ''网络畅通'';
  c_txt_checkattachnetsuccess = ''已登入网络'';
  c_txt_internetconnected =''上网了'';

implementation

end.