另外一个办法:
Using the IP Helper API from Delphi
May 20, 2001
Borland Delphi 5
Windows 2000
If you are building advanced Internet applications, you will often have the need to get information about the network configuration of the system on which your application is running. For example, you might need to retrieve the MAC address (sometimes called the physical address) of the network adapter or the IP address of the default DNS server. The IP Helper API allows you to retrieve such information on Windows 2000.
The IP Helper API <http://msdn.microsoft.com/library/default.asp?URL=/library/psdk/rras/iphpport_7vz9.htm> (or IPHLPAPI or Internet Protocol Helper) is new to Windows 2000, and thus it is not directly usable from Delphi 5. Delphi 6 might contain the necessary header translations, but since Delphi 6 is not yet shipping (it has been announced <http://www.borland.com/about/press/2001/del6released.html>, though), it is impossible to confirm.
The sample application demonstrates using two IP Helper API functions, GetNetworkParams and GetAdaptersInfo. They are declared like this (translated from IPHLPAPI.H):
Function GetNetworkParams(FI : PFixedInfo; Var BufLen : Integer) : Integer;
StdCall; External 'iphlpapi.dll' Name 'GetNetworkParams';
Function GetAdaptersInfo(AI : PIPAdapterInfo; Var BufLen : Integer) : Integer;
StdCall; External 'iphlpapi.dll' Name 'GetAdaptersInfo';
As you can see, both of these functions are implemented in IPHLPAPI.DLL. The first function can be used to return overall information about the IP configuration of the system. The sample application uses the following procedure to demonstrate the usage of the function:
procedure TIPMainForm.GetNetworkParameters;
Var
FI : PFixedInfo;
Size : Integer;
Res : Integer;
I : Integer;
DNS : PIPAddrString;
begin
Size := 1024;
GetMem(FI,Size);
Res := GetNetworkParams(FI,Size);
If (Res <> ERROR_SUCCESS) Then Begin
SetLastError(Res);
RaiseLastWin32Error;
End;
With Info,Lines do Begin
Clear;
Add('Host name: '+FI^.HostName);
Add('Domain name: '+FI^.DomainName);
If (FI^.CurrentDNSServer <> nil) Then
Add('Current DNS Server: '+FI^.CurrentDNSServer^.IPAddress)
Else Add('Current DNS Server: (none)');
I := 1;
DNS := @FI^.DNSServerList;
Repeat
Add('DNS '+IntToStr(I)+': '+DNS^.IPAddress);
Inc(I);
DNS := DNS^.Next;
Until (DNS = nil);
Add('Scope ID: '+FI^.ScopeId);
Add('Routing: '+IntToStr(FI^.EnableRouting));
Add('Proxy: '+IntToStr(FI^.EnableProxy));
Add('DNS: '+IntToStr(FI^.EnableDNS));
End;
FreeMem(FI);
end;
Similarly, the GetAdaptersInfo function can be used like this:
procedure TIPMainForm.GetAdapterInformation;
Var
AI,Work : PIPAdapterInfo;
Size : Integer;
Res : Integer;
I : Integer;
begin
Size := 5120;
GetMem(AI,Size);
Res := GetAdaptersInfo(AI,Size);
If (Res <> ERROR_SUCCESS) Then Begin
SetLastError(Res);
RaiseLastWin32Error;
End;
With Info,Lines do Begin
Work := AI;
I := 1;
Repeat
Add('');
Add('Adapter '+IntToStr(I));
Add(' ComboIndex: '+IntToStr(Work^.ComboIndex));
Add(' Adapter name: '+Work^.AdapterName);
Add(' Description: '+Work^.Description);
Add(' Adapter address: '+MACToStr(@Work^.Address,Work^.AddressLength));
Add(' Index: '+IntToStr(Work^.Index));
Add(' Type: '+IntToStr(Work^._Type));
Add(' DHCP: '+IntToStr(Work^.DHCPEnabled));
Add(' Current IP: '+GetAddrString(Work^.CurrentIPAddress));
Add(' IP addresses: '+GetAddrString(@Work^.IPAddressList));
Add(' Gateways: '+GetAddrString(@Work^.GatewayList));
Add(' DHCP servers: '+GetAddrString(@Work^.DHCPServer));
Add(' Has WINS: '+IntToStr(Integer(Work^.HaveWINS)));
Add(' Primary WINS: '+GetAddrString(@Work^.PrimaryWINSServer));
Add(' Secondary WINS: '+GetAddrString(@Work^.SecondaryWINSServer));
Add(' Lease obtained: '+TimeTToDateTimeStr(Work^.LeaseObtained));
Add(' Lease expires: '+TimeTToDateTimeStr(Work^.LeaseExpires));
Inc(I);
Work := Work^.Next;
Until (Work = nil);
End;
FreeMem(AI);
end;
Since GetAdaptersInfo is able to return complex information about the network adapters installed to the system, you need to be extra-careful when converting the information to the display. The sample application uses the following three helper functions:
Function MACToStr(ByteArr : PByte; Len : Integer) : String;
Begin
Result := '';
While (Len > 0) do Begin
Result := Result+IntToHex(ByteArr^,2)+'-';
ByteArr := Pointer(Integer(ByteArr)+SizeOf(Byte));
Dec(Len);
End;
SetLength(Result,Length(Result)-1); { remove last dash }
End;
Function GetAddrString(Addr : PIPAddrString) : String;
Begin
Result := '';
While (Addr <> nil) do Begin
Result := Result+'A: '+Addr^.IPAddress+' M: '+Addr^.IPMask+#13;
Addr := Addr^.Next;
End;
End;
Function TimeTToDateTimeStr(TimeT : Integer) : String;
Const UnixDateDelta = 25569; { days between 12/31/1899 and 1/1/1970 }
Var
DT : TDateTime;
TZ : TTimeZoneInformation;
Res : DWord;
Begin
If (TimeT = 0) Then Result := ''
Else Begin
{ Unix TIME_T is secs since 1/1/1970 }
DT := UnixDateDelta+(TimeT / (24*60*60)); { in UTC }
{ calculate bias }
Res := GetTimeZoneInformation(TZ);
If (Res = TIME_ZONE_ID_INVALID) Then RaiseLastWin32Error;
If (Res = TIME_ZONE_ID_STANDARD) Then Begin
DT := DT-((TZ.Bias+TZ.StandardBias) / (24*60));
Result := DateTimeToStr(DT)+' '+WideCharToString(TZ.StandardName);
End
Else Begin { daylight saving time }
DT := DT-((TZ.Bias+TZ.DaylightBias) / (24*60));
Result := DateTimeToStr(DT)+' '+WideCharToString(TZ.DaylightName);
End;
End;
End;
The last function, TimeTToDateTimeStr, is particularly interesting because it is able to convert a Unix Time_T type to a TDateTime, and also take into account local time zone and daylight savings time (DST).
Testing the sample application
Once you have downloaded the sample application (see below), and compiled it, you are ready to run the application. The main user interface is really quite trivial, but nonetheless the following information is displayed on screen:
Host name: emerald
Domain name: pp.htv.fi
Current DNS Server: (none)
DNS 1: 212.93.64.18
DNS 2: 212.93.64.16
Scope ID:
Routing: 0
Proxy: 0
DNS: 0
Adapter 1
ComboIndex: 0
Adapter name: {F2B85B21-4E6F-4EDB-AE3E-87BB6B5CAD73}
Description: 3Com 3C90x Ethernet Adapter
Adapter address: 00-60-08-10-28-79
Index: 0
Type: 6
DHCP: 1
Current IP:
IP addresses: A: 212.93.92.191 M: 255.255.255.0
Gateways: A: 212.93.92.1 M: 0.0.0.0
DHCP servers: A: 212.93.64.98 M:
Has WINS: 0
Primary WINS: A: 0.0.0.0 M: 0.0.0.0
Secondary WINS: A: 0.0.0.0 M: 0.0.0.0
Lease obtained: 20.5.2001 14:31:49 FLE Daylight Time
Lease expires: 20.5.2001 19:31:49 FLE Daylight Time
In case you are interested, the main screen looks like this:
Certainly, the information will be quite different on your computer, but you get the idea. For more details about the IP Helper API library, see the Platform SDK documentation, available from http://msdn.microsoft.com.
Download the example code
Download usingtheiphelperapi.zip <http://www.whirlwater.com/downloads/2001/usingtheiphelperapi.zip> (167 kB) which contains the sample application IP Helper Demo that uses the IP Helper API available in Windows 2000. Please note that the sample application requires Delphi 5 or later and Windows 2000 or later.
function TUDPSock2.LocalIPValid(var LocalIP : string): Boolean;
var
i : integer;
slLocalIPs : TStringList;
begin
Result := False;
slLocalIPs := TStringList.Create;
Self.LocalIPs(slLocalIPs);
if slLocalIPs.Count = 0 then
begin
slLocalIPs.Free;
Exit;
end;
if LocalIP = '' then
begin
LocalIP := slLocalIPs[0]; //Default Interface
Result := True;
end else
for i:=0 to slLocalIPs.Count-1 do
if Trim(slLocalIPs[i]) = Trim(LocalIP) then
begin
Result := True;
Break;
end;
slLocalIPs.Free;
end;
function TUDPSock2.Setup(udpSockType : TUDPSockType; LocalIP : string = '';
BufferSize : integer = DEFAULTBUFFERSIZE):Boolean;
begin
Result := False;
//Already started?
if fSockCount > 0 then
Exit;
//Local IP set valid?
if not LocalIPValid(LocalIP) then
Exit;
//Buffer Size Valid?
if not ((BufferSize <= MAXBUFFERSIZE) and (BufferSize >= MINBUFFERSIZE)) then
Exit;
function TUDPSock2.Add(RemoteIP : string; Port : u_Short): integer;
var
nMCAddr : Cardinal;
nTTL, nReuseAddr : integer;
Sock : TSocket;
SockAddrLocal, SockAddrRemote : TSockAddr;
MCReq : TIP_mreq;
pPE : PProtoEnt;
begin
Result := -1;
//Maximum fds allowed
if fSockCount = FD_SETSIZE then
Exit;
//Already started?
if (fRecvThd <> nil) or (not fbSetupReady) then
Exit;
//Multicast address valid?
if (fSockType = stMultiCastSender) or (fSockType = stMultiCastReceiver) then
begin
nMCAddr := ntohl(inet_addr(PChar(RemoteIP)));
//though Multicast ip is between 224.0.0.0 to 239.255.255.255
//the 224.0.0.0 to 224.0.0.225 ips are reserved for system
if not ((nMCAddr <= $efffffff) and (nMCAddr >= $e0000100)) then
Exit;
end;
pPE := GetProtoByName('UDP');
//Create Socket
Sock := Socket(AF_INET, SOCK_DGRAM, pPE.p_proto);
if Sock = INVALID_SOCKET then
Exit;
//Reuse the address, according to WinSock help, nReuseAddr must be a BOOL and
//the fifth param must be SizeOf(integer), but in a sample codes, the fifth is SizeOf(BOOL)
//faint! I used integer and SizeOf(integer) is also OK
nReuseAddr := 1;
if SetSockOpt(Sock, SOL_SOCKET, SO_REUSEADDR, @nReuseAddr, SizeOf(integer)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
//Set Local Address and bind
FillChar(SockAddrLocal, SizeOf(SockAddrLocal), 0);
SockAddrLocal.sin_family := AF_INET;
if (fSockType = stMultiCastSender) or (fSockType = stUnicastSender)
or (fSockType = stBroadcastSender) then
SockAddrLocal.sin_port := htons(0)
else
SockAddrLocal.sin_port := htons(Port);
SockAddrLocal.sin_addr.S_addr := Inet_Addr(PChar(fLocalIP));
if Bind(Sock, SockAddrLocal, SizeOf(SockAddrLocal)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
if (fSockType = stMultiCastSender) or (fSockType = stUnicastSender)
or (fSockType = stBroadcastSender)then
begin
//Set Send Buffer Size
if SetSockOpt(Sock, SOL_SOCKET, SO_SNDBUF, @fBufSize, SizeOf(integer)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
//Set output interface
if fSockType = stMultiCastSender then
begin
if SetSockOpt(Sock, IPPROTO_IP, IP_MULTICAST_IF, @(SockAddrLocal.sin_addr),
SizeOf(In_Addr)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
nTTL := MULTICAST_TTL;
if SetSockOpt(Sock, IPPROTO_IP, IP_MULTICAST_TTL, @nTTL, SizeOf(integer)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
end else //For send, must set the opt SO_BROADCAST
if fSockType = stBroadcastSender then
if SetSockOpt(Sock, SOL_SOCKET, SO_BROADCAST, @nReuseAddr, SizeOf(integer))
= SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
fSockCount := fSockCount + 1;
SetLength(fAddrTo, fSockCount);
fAddrTo[fSockCount-1] := SockAddrRemote;
end else //UDPReceiver or MulticastReceiver or BroadcastReceiver
begin
//Set Receive Buffer Size
if SetSockOpt(Sock, SOL_SOCKET, SO_RCVBUF, @fBufSize, SizeOf(integer)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
//Join Group
if fSockType = stMulticastReceiver then
begin
MCReq.imr_multiaddr.S_addr := Inet_Addr(PChar(RemoteIP));
MCReq.imr_interface.S_addr := Inet_Addr(PChar(fLocalIP));
if SetSockOpt(Sock, IPPROTO_IP, IP_ADD_MEMBERSHIP, @MCReq,
SizeOf(TIP_mreq)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
end;
fSockCount := fSockCount + 1;
if fSockType = stMulticastReceiver then
begin
SetLength(fMCReq, fSockCount);
fMCReq[fSockCount-1] := MCReq;
end;
end;
function TUDPSock2.Close:Boolean;
var
i : integer;
begin
Result := False;
if fSockCount = 0 then
Exit;
if (fSockType = stUnicastReceiver) or (fSockType = stMulticastReceiver)
or (fSockType = stBroadcastReceiver) then
begin
//Exception will be? :( I don't know
if fRecvThd <> nil then
begin
fRecvThd.Suspend;
fRecvThd.Free;
fRecvThd := nil;
end;
if fSockType = stMulticastReceiver then
for i := 0 to fSockCount - 1 do
SetSockOpt(fSocks[i], IPPROTO_IP, IP_DROP_MEMBERSHIP, @fMCReq[i], SizeOf(fMCReq[i]));
end;
for i := 0 to fSockCount - 1 do
CloseSocket(fSocks[i]);
function TUDPSock2.Send(index : integer; buffer : Pointer; len : integer) : Boolean;
begin
Result := False;
if (len < 0) or (index < 0) or (index >= fSockCount) then
Exit;
if (fSockType <> stMultiCastSender) and (fSockType <> stUnicastSender)
and (fSockType <> stBroadcastSender) then
Exit;
if SendTo(fSocks[index], buffer^, len, 0{MSG_DONTROUTE}, fAddrTo[index],
SizeOf(fAddrTo[index])) <> SOCKET_ERROR then
Result := True;
end;
TAPInAddr = Array [0..10] of PInAddr; // array of pInaddr
PAPInAddr = ^TAPInaddr; // pointer of Array
//Note : Dut to broadcast fragmentation's problem, broadcast message can be at most
//512 bytes long defined by WinSock, not longer than 1472 by Berkeley Socket
//not longer than 1468 under MIPS machine
//So don't send a broadcast message longer than 512 here, no use
TUDPSockType = (stMultiCastSender, stMultiCastReceiver, stUnicastSender, stUnicastReceiver,
stBroadcastSender, stBroadcastReceiver);
TUDPSock2 = class(TObject)
private
fbSetupReady : Boolean;
fSockType : TUDPSockType;
fOnRecv : TUDPOnRecv;
fSockCount : integer;
fAddrTo : array of TSockAddr;
fMCReq : array of TIP_mreq;
fSocks : TArraySocket;
fRecvThd : TUDPRecvThd;
fLocalIP : String;
fBufSize : integer;
function LocalIPValid(var LocalIP : string): Boolean;
public
property OnRecv : TUDPOnRecv read fOnRecv write fOnRecv;
constructor Create; ReIntroduce;
destructor Destroy; Override;
procedure LocalIPs(slIPs : TStringList);
procedure LocalMAC(slMac : TStringList);
procedure StartReceive;
function Add(RemoteIP : string; Port : u_Short): integer;
function Setup(udpSockType : TUDPSockType; LocalIP : string = '';
BufferSize : integer = DEFAULTBUFFERSIZE) : Boolean;
function Close : Boolean;
function Send(index : integer; buffer : Pointer; len : integer) : Boolean;
end;
implementation
var
wsData : TWSAData;
procedure TUDPRecvThd.Execute;
var
readFDs : TFDSet;
i, nRecved, nAddrLen: integer;
buf : array [0..MAXBUFFERSIZE] of Byte;
SockFrom : TSockAddr;
begin
Priority := tpHighest;
while not Terminated do
begin
nAddrLen := SizeOf(SockFrom);
FD_ZERO(readFDs);
for i := 0 to fSockCount-1 do
FD_SET(fSocks[i], readFDs);
//The first param of select is provided just for
//compatibility with Berkeley Sockets, no meaning in WinSock
//Note!!! the select's last param here is nil
//so it can be blocked forever
Select(0, @readFDs, nil, nil, nil);
for i := 0 to fSockCount-1 do
if FD_ISSET(fSocks[i], readFDs) then
begin
nRecved := RecvFrom(fSocks[i], buf, fBufSize, 0, SockFrom, nAddrLen);
if Assigned(fOnRecv) then
//Note!!! I didn't call Synchronize here so u can call Terminate and WaitFor
//but I suggest using Suspend and Free STRONGLY!
//For the call of select can be blocked forever
fOnRecv(@buf, nRecved, string(Inet_Ntoa(SockFrom.sin_addr)),
Cardinal(Ntohs(SockFrom.sin_port)));
end;
end;
end;
procedure TUDPSock2.LocalIPs(slIPs : TStringList);
var
strLocalHost : string;
pHE : PHostent;
pInAd : PAPInAddr;
saLocal : TSockAddr;
i : integer;
begin
SetLength(strLocalHost, 255);
if GetHostName(PChar(strLocalHost), 254) = SOCKET_ERROR then
Exit;
pHE := GetHostByName(PChar(strLocalHost));
pInAd := PAPInAddr(pHE^.h_addr_list);
saLocal.sin_addr := (pInAd^[0]^);
i := 0;
while True do
begin
slIPs.Add(inet_ntoa(saLocal.sin_addr));
i := i + 1;
if(pInAd^[i] <> nil) then
saLocal.sin_addr := (pInAd^[i]^) //local host
else
break;
end;
end;
for i := 0 to integer(lanaEnum.length)-1 do
begin
FillChar(ncb, SizeOf(TNCB), 0);
ncb.ncb_command := Char(NCBReset);
ncb.ncb_lana_num := lanaEnum.lana[i];
Netbios(@ncb);
FillChar(ncb, SizeOf(TNCB), 0);
ncb.ncb_command := Chr(NCBAstat);
ncb.ncb_lana_num := lanaEnum.lana[i];
ncb.ncb_callname := '* ';
ncb.ncb_buffer := PChar(@adapt);
ncb.ncb_length := SizeOf(TASTAT);
if Netbios(@ncb) = Chr(0) then
begin
strMac := '';
for j := 0 to 5 do
begin
strPart := IntToHex(integer(adapt.adapter.adapter_address[j]), 2);
strMac := strMac + strPart + '-';
end;
SetLength(strMac, Length(strMac)-1);
slMac.Add(strMac);
end;
end;
end;
procedure TUDPSock2.StartReceive;
begin
if fRecvThd <> nil then
Exit;
if ((fSockType = stUnicastReceiver) or (fSockType = stMulticastReceiver)
or (fSockType = stBroadcastReceiver)) and (fSockCount > 0) then
fRecvThd := TUDPRecvThd.Create(fSocks, fOnRecv, fBufSize);
end;