//列举出整个网络中的工作组名称,返回值为TRUE表示执行成功,
//参数List中返回服务器(工作组)的名称
Function GetServerList( 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);//执行失败
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;
//WNetCloseEnum关闭一个列举句柄
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;
//列举出指定工作组GroupName中的计算机名称,返回值为TRUE表示执行成功,
//参数List中返回计算机名称
Function GetUsers( GroupName : string; var List : TStringList ) : Boolean;
type
TNetResourceArray = ^TNetResource;//网络类型的数组
Var
NetResource : TNetResource;
Buf : Pointer;
Count,BufSize,Res : DWord;
Ind : Integer;
lphEnum : THandle;
Temp : TNetResourceArray;
Begin
Result := False;
List.Clear;
FillChar(NetResource,SizeOf(NetResource),0);//初始化网络层次信息
//获取指定工作组的网络资源句柄
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 Ind := 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;//执行失败
procedure TForm1.btnGetHostNameClick(Sender: TObject);
var
i: integer;
IpHeader,sIP: string;
//p: PHostEnt;
begin
if GetIPHeader(edStart.Text) <> GetIPHeader(edEnd.Text) then
showMessage(' Error ');
IpHeader := GetIPHeader(edStart.Text);
IpStartLastSection := GetIPLastSection(edStart.Text);
IpEndLastSection := GetIPLastSection(edEnd.Text);
if (IpStartLastSection = 0)or(IpEndLastSection = 0)
or(IpStartLastSection > IpEndLastSection) then
exit;
lbUsedTime.Caption := '0';
timer1.Enabled := true;
for i := IpStartLastSection to IpEndLastSection do
begin
sIP := IpHeader + inttostr(i);
with TThreadGetComputerName.Create(handle,sIP,false) do;
//FreeOnTerminate := true;
inc(CountOfThreads);
end;
end;
procedure TForm1.MyMsgHasGetName(var msg: TMessage);
var
sIP: string;
p: PHostEnt;
i: integer;
begin
if msg.WParam <> 0 then
begin
sIP := string(pchar(msg.WParam));
if length(sIP) < 20 then
for i:=length(sIP) to 20 do
sIP := sIP + ' ';
end
else exit;
if msg.LParam <> 0 then
begin
p := PHostEnt(msg.LParam);
Memo1.Lines.Add('IP: ' + sIP + ' Computer Name: ' + p^.h_name);
end
else
begin
Memo1.Lines.Add('IP: ' + sIP + ' Computer Name: ' + '=Unknown=');
end;
Application.ProcessMessages;
dec(CountOfThreads);
if CountOfThreads = 0 then Timer1.Enabled := false;
end;
procedure TForm1.MyMsgResultOfPing(var msg: TMessage);
var
ResultStr: string;
begin
ResultStr := string(PChar(msg.lParam));
Memo1.Lines.Add(ResultStr);
dec(CountOfThreads);
ProgressBar.Position := ProgressBar.Position + 1;
Application.ProcessMessages;
if CountOfThreads = 0 then Timer1.Enabled := false;
end;
procedure TForm1.Memo1Change(Sender: TObject);
begin
lbCount.Caption := inttostr(Memo1.Lines.Count);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if CountOfThreads = 0 then
timer1.Enabled := false
else
lbUsedTime.Caption := inttostr((strtoint(lbUsedTime.Caption))+1);
Application.ProcessMessages;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
IniFile: TIniFile;
strStart,strEnd: string;
begin
plMemo.Align := alClient;
CountOfThreads := 0;
SetLength(sysDir,255);
GetSystemDirectory(pChar(sysDir),255);
sysDir := PChar(sysDir);
if (length(sysDir) = 0) then exit;
if copy(sysDir,length(sysDir),1) <> '\' then
sysDir := sysDir + '\';
IniFile:=TIniFile.Create(sysDir + 'RSetup.ini');
try
strStart := IniFile.ReadString('RANGE','START','');
strEnd := IniFile.ReadString('RANGE','END','');
if (strStart <> '')and(strEnd <> '') then
begin
edStart.Text := strStart;
edEnd.Text := strEnd;
end;
finally
IniFile.Free;
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
IniFile: TIniFile;
begin
if sysDir = '' then exit;
IniFile:=TIniFile.Create(sysDir + 'RSetup.ini');
try
IniFile.WriteString('RANGE','START',edStart.Text);
IniFile.WriteString('RANGE','END',edEnd.Text);
finally
IniFile.Free;
end;
end;
lbUsedTime.Caption := '0';
timer1.Enabled := true;
for i := IpStartLastSection to IpEndLastSection do
begin
sIP := IpHeader + inttostr(i);
with TThreadPing.Create(handle,sIP,true,
hICMP,
IcmpCreateFile,
IcmpCloseHandle,
IcmpSendEcho) do
begin
inc(CountOfThreads);
Application.ProcessMessages;
Resume;
end;
while(CountOfThreads > 20)and(Not Application.Terminated) do
Application.ProcessMessages;
end;
while(CountOfThreads <> 0)and(Not Application.Terminated) do
Application.ProcessMessages;
finally
WSACleanup;
end;
end;
procedure TForm1.Memo1DblClick(Sender: TObject);
begin
Memo1.Clear;
Memo1Change(sender);
end;
function GetIPHeader(sIP: string): string;
var
tmpIp: string;
begin
result := '';
tmpIp := sIP;
while copy(tmpIp,length(tmpIp),1) <> '.' do
delete(tmpIp,length(tmpIp),1);
result := tmpIp;
end;
function GetIPLastSection(sIP: string): byte;
var
tmpIp: string;
resultStr: string;
begin
resultStr := '';
tmpIp := sIP;
while copy(tmpIp,length(tmpIp),1) <> '.' do
begin
resultStr := copy(tmpIp,length(tmpIp),1) + resultStr;
delete(tmpIp,length(tmpIp),1);
end;
if StrToInt(resultStr) > 255 then
result := 0
else
result := StrToInt(resultStr);
end;
function wpGetUserNameByIP(sIP: string): PHostEnt;
var
WSAData: TWSAData;
p: PHostEnt;
InetAddr: dword;
begin
WSAStartup(2,WSAData);
InetAddr := inet_addr(PChar(sIP));
try
try
p := GetHostByAddr(@InetAddr,length(sIP),PF_Inet);
finally
WSACleanup;
end;
except
ShowMessage('Can not Get the COMPUTER NAME which IP = ' + sIP +', Abort');
end;
result := p;
end;
function winPing(sIP: string;
hICMP: THandle;
IcmpCreateFile: TIcmpCreateFile;
IcmpCloseHandle: TIcmpCloseHandle;
IcmpSendEcho: TIcmpSendEcho): string;
var
IPOpt: TIPOptionInformation; //the option information which send with echo packet
FIPAddress: dword;
pReqData,pRevData: PChar;
pIPE: PIcmpEchoReply; //ICMP Echo reply cache
FSize: dword;
MyString: string;
FTimeOut: dword;
BufferSize: dword;
i: integer;
begin
Result := PChar(sIP) + 'No acknowledgement';
if sIP = '' then exit;
FIPAddress := inet_addr(pchar(sIP));
FSize := 40;
BufferSize := SizeOf(TICMPEchoReply) + FSize;
GetMem(pRevData,FSize);
GetMem(pIPE,BufferSize);
FillChar(pIPE^,SizeOf(pIPE^),0);
pIPE^.Data := pRevData;
MyString := '------Hello,This is My Echo-------';
pReqData := PChar(MyString);
FillChar(IPOpt,Sizeof(IPOpt),0);
IPOpt.TTL := 64;
FTimeout := 4000;
IcmpSendEcho(hICMP,FIPAddress,pReqData,Length(MyString),
@IPOpt,pIPE,BufferSize,FTimeout);
try
try
if length(sIP) < 20 then
for i:=length(sIP) to 20 do
sIP := sIP + ' ';
Result := sIP + 'No acknowledgement';
if pIPE^.Options.TTL <> 0 then
if pReqData^ = pIPE^.Options.OptionsData^ then
begin
Result := sIP + '--------'
+IntToStr(pIPE^.DataSize)
+ '----------------'
+ inttostr(pIPE^.RTT);
end;
except
Result := sIP + ' No answer ';
end;
finally
FreeMem(pRevData);
FreeMem(pIPE);
end;
end;