unet.pas

delphi 编制的服务器程序

  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 := TNetResourceArray(Buf);
  for i := 0 to Count - 1 do//记录各个网络类型的信息
  begin
    List.Add(p^.lpRemoteName);
    Inc(P);
  end;
  Res := WNetCloseEnum(lphEnum); //关闭一次列举
  if Res <> NO_ERROR then exit; //执行失败
  Result := True;
  FreeMem(Buf); //释放内存
end;
{=================================================================
  功  能: 映射网络驱动器
  参  数:
          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;

function GetIP(Name:string) : string;
type
  TaPInAddr = array [0..10] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  phe :PHostEnt;
  pptr : PaPInAddr;
  I : Integer;
  GInitData : TWSADATA;
begin
  WSAStartup($101, GInitData);
  Result := '';
  phe :=GetHostByName(pchar(Name));
  pptr := PaPInAddr(Phe^.h_addr_list);
  result:=StrPas(inet_ntoa(pptr^[0]^));
  WSACleanup;
end;

procedure CopyFileToNeb(var Source,Dest:String);
var
  FData : TShFileOpStruct;
begin
  Source:='c:\sss';//sss为目录
  dest:='\\computername\kkk';
  //首先建立文件目录
  if not DirectoryExists(Dest) then
     begin
     if not CreateDir(Dest) then
        begin
        MessageDlg('建立目录出现错误！',mtWarning,[mbOK],0);
        Exit;
        end;
      Fdata.pFrom :=PChar(Source);
      Fdata.pTo := PChar(Dest);
      Fdata.wFunc := FO_COPY ;
      Fdata.Wnd := Application.Handle ;
      Fdata.lpszProgressTitle := 'Wait';
      Fdata.fFlags :=FOF_SIMPLEPROGRESS;
      ShFileOperation(FData);
      end;
end;

{
function SelectComputer: string; //从对话框返回的计算机名
 var
   WindowList: Pointer;
   BrowseInfo: TBrowseInfo;
   Buffer: PChar;
   RootItemIDList, ItemIDList: PItemIDList;
   ShellMalloc: IMalloc;
 begin
   Result := '';
   FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
   if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
     begin
       Buffer := ShellMalloc.Alloc(MAX_PATH);
       try
         RootItemIDList := nil;
         SHGetSpecialFolderLocation(Application.Handle, CSIDL_NETWORK, RootItemIDList);
         with BrowseInfo do
           begin
             hwndOwner := Application.Handle;
             pidlRoot := RootItemIDList;
             pszDisplayName := Buffer;
             lpszTitle := '选择机器名';
             ulFlags := BIF_BROWSEFORCOMPUTER;
           end;
         WindowList := DisableTaskWindows(0);
         try
           ItemIDList := ShBrowseForFolder(BrowseInfo);
         finally
           EnableTaskWindows(WindowList);
         end;
         if ItemIDList <> nil then
           begin
             Result := StrPas(Buffer);
             ShGetPathFromIDList(ItemIDList, Buffer);
             ShellMalloc.Free(ItemIDList);
           end;
       finally
         ShellMalloc.Free(Buffer);
       end;
     end;
 end;
}

end.

/////////////////////////////*******************************************//错误信息常量