怎样做一个程序能像飞鸽那样快速PING到局域网存活的机子啊？

[vbfdy]

求源码啊，谢谢各位大哥教一下小弟啊，谢谢

[therockdelt]

偶有点菜 一下为别人源码，未研究过，请谅解

Dim iReturn As Long, sLowByte As String, sHighByte As String
Dim sMsg As String, HostLen As Long, Host As String
Dim Hostent As Hostent, PointerToPointer As Long, ListAddress As Long
Dim WSAdata As WSAdata, DotA As Long, DotAddr As String, ListAddr As Long
Dim MaxUDP As Long, MaxSockets As Long, i As Integer
Dim Description As String, Status As String

' ICMP Variables

Dim bReturn As Boolean, hIP As Long
Dim szBuffer As String
Dim Addr As Long
Dim RCode As String
Dim RespondingHost As String

' TRACERT Variables

Dim TraceRT As Boolean
Dim TTL As Integer


' WSock32 Constants

Const WS_VERSION_MAJOR = &H101 \ &H100 And &HFF&
Const WS_VERSION_MINOR = &H101 And &HFF&
Const MIN_SOCKETS_REQD = 0

Sub GetRCode()

If pIPe.Status = 0 Then RCode = "Success"
If pIPe.Status = 11001 Then RCode = "Buffer too Small"
If pIPe.Status = 11002 Then RCode = "Dest Network Not Reachable"
If pIPe.Status = 11003 Then RCode = "Dest Host Not Reachable"
If pIPe.Status = 11004 Then RCode = "Dest Protocol Not Reachable"
If pIPe.Status = 11005 Then RCode = "Dest Port Not Reachable"
If pIPe.Status = 11006 Then RCode = "No Resources Available"
If pIPe.Status = 11007 Then RCode = "Bad Option"
If pIPe.Status = 11008 Then RCode = "Hardware Error"
If pIPe.Status = 11009 Then RCode = "Packet too Big"
If pIPe.Status = 11010 Then RCode = "Rqst Timed Out"
If pIPe.Status = 11011 Then RCode = "Bad Request"
If pIPe.Status = 11012 Then RCode = "Bad Route"
If pIPe.Status = 11013 Then RCode = "TTL Exprd in Transit"
If pIPe.Status = 11014 Then RCode = "TTL Exprd Reassemb"
If pIPe.Status = 11015 Then RCode = "Parameter Problem"
If pIPe.Status = 11016 Then RCode = "Source Quench"
If pIPe.Status = 11017 Then RCode = "Option too Big"
If pIPe.Status = 11018 Then RCode = " Bad Destination"
If pIPe.Status = 11019 Then RCode = "Address Deleted"
If pIPe.Status = 11020 Then RCode = "Spec MTU Change"
If pIPe.Status = 11021 Then RCode = "MTU Change"
If pIPe.Status = 11022 Then RCode = "Unload"
If pIPe.Status = 11050 Then RCode = "General Failure"
RCode = RCode + " (" + CStr(pIPe.Status) + ")"

DoEvents
If TraceRT = False Then

If pIPe.Status = 0 Then
text3.Text = text3.Text + " Reply from " + RespondingHost + ": Bytes = " + Trim$(CStr(pIPe.DataSize)) + " RTT = " + Trim$(CStr(pIPe.RoundTripTime)) + "ms TTL = " + Trim$(CStr(pIPe.Options.TTL)) + Chr$(13) + Chr$(10)
Else
text3.Text = text3.Text + " Reply from " + RespondingHost + ": " + RCode + Chr$(13) + Chr$(10)
End If

Else
If TTL - 1 < 10 Then text3.Text = text3.Text + " Hop # 0" + CStr(TTL - 1) Else text3.Text = text3.Text + " Hop # " + CStr(TTL - 1)
text3.Text = text3.Text + " " + RespondingHost + Chr$(13) + Chr$(10)
End If

End Sub

[therockdelt]

Sub vbGetHostByName()

Dim szString As String

Host = Trim$(Text1.Text) ' Set Variable Host to Value in Text1.text

szString = String(64, &H0)
Host = Host + Right$(szString, 64 - Len(Host))

If gethostbyname(Host) = SOCKET_ERROR Then ' If WSock32 error, then tell me about it
sMsg = "Winsock Error" & Str$(WSAGetLastError())
MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
Else
PointerToPointer = gethostbyname(Host) ' Get the pointer to the address of the winsock hostent structure
CopyMemory Hostent.h_name, ByVal _
PointerToPointer, Len(Hostent) ' Copy Winsock structure to the VisualBasic structure

ListAddress = Hostent.h_addr_list ' Get the ListAddress of the Address List
CopyMemory ListAddr, ByVal ListAddress, 4 ' Copy Winsock structure to the VisualBasic structure
CopyMemory IPLong, ByVal ListAddr, 4 ' Get the first list entry from the Address List
CopyMemory Addr, ByVal ListAddr, 4

Label3.Caption = Trim$(CStr(Asc(IPLong.Byte4)) + "." + CStr(Asc(IPLong.Byte3)) _
+ "." + CStr(Asc(IPLong.Byte2)) + "." + CStr(Asc(IPLong.Byte1)))
End If

End Sub
Sub CenterForm()
Form1.Left = (Screen.Width - Form1.ScaleWidth) \ 2
Form1.Top = (Screen.Height - Form1.ScaleHeight) \ 2
End Sub

Sub vbGetHostName()

Host = String(64, &H0) ' Set Host value to a bunch of spaces

If gethostname(Host, HostLen) = SOCKET_ERROR Then ' This routine is where we get the host's name
sMsg = "WSock32 Error" & Str$(WSAGetLastError()) ' If WSOCK32 error, then tell me about it
MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
Else
Host = Left$(Trim$(Host), Len(Trim$(Host)) - 1) ' Trim up the results
Text1.Text = Host ' Display the host's name in label1
End If

End Sub

Sub vbIcmpSendEcho()

Dim NbrOfPkts As Integer

szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklm"

If IsNumeric(Text5.Text) Then
If Val(Text5.Text) < 32 Then Text5.Text = "32"
If Val(Text5.Text) > 128 Then Text5.Text = "128"
Else
Text5.Text = "32"
End If

szBuffer = Left$(szBuffer, Val(Text5.Text))

If IsNumeric(text4.Text) Then
If Val(text4.Text) < 1 Then text4.Text = "1"
Else
text4.Text = "1"
End If

If TraceRT = True Then text4.Text = "1"

For NbrOfPkts = 1 To Trim$(text4.Text)

DoEvents
bReturn = IcmpSendEcho(hIP, Addr, szBuffer, Len(szBuffer), pIPo, pIPe, Len(pIPe) + 8, 2700)

If bReturn Then

RespondingHost = CStr(pIPe.Address(0)) + "." + CStr(pIPe.Address(1)) + "." + CStr(pIPe.Address(2)) + "." + CStr(pIPe.Address(3))

GetRCode

Else ' I hate it when this happens. If I get an ICMP timeout
' during a TRACERT, try again.

If TraceRT Then
TTL = TTL - 1
Else ' Don't worry about trying again on a PING, just timeout
text3.Text = text3.Text + "ICMP Request Timeout" + Chr$(13) + Chr$(10)
End If

End If

Next NbrOfPkts

End Sub

[therockdelt]

Sub vbWSAStartup()

' Subroutine to Initialize WSock32

iReturn = WSAStartup(&H101, WSAdata)

If iReturn <> 0 Then ' If WSock32 error, then tell me about it
MsgBox "WSock32.dll is not responding!", vbOKOnly, "VB4032-ICMPEcho"
End If

If LoByte(WSAdata.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAdata.wVersion) = WS_VERSION_MAJOR And HiByte(WSAdata.wVersion) < WS_VERSION_MINOR) Then
sHighByte = Trim$(Str$(HiByte(WSAdata.wVersion)))
sLowByte = Trim$(Str$(LoByte(WSAdata.wVersion)))

sMsg = "WinSock Version " & sLowByte & "." & sHighByte
sMsg = sMsg & " is not supported "
MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
End
End If

If WSAdata.iMaxSockets < MIN_SOCKETS_REQD Then
sMsg = "This application requires a minimum of "
sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
End
End If

MaxSockets = WSAdata.iMaxSockets

' WSAdata.iMaxSockets is an unsigned short, so we have to convert it to a signed long

If MaxSockets < 0 Then
MaxSockets = 65536 + MaxSockets
End If

MaxUDP = WSAdata.iMaxUdpDg
If MaxUDP < 0 Then
MaxUDP = 65536 + MaxUDP
End If

' Process the Winsock Description information

Description = ""

For i = 0 To WSADESCRIPTION_LEN
If WSAdata.szDescription(i) = 0 Then Exit For
Description = Description + Chr$(WSAdata.szDescription(i))
Next i

' Process the Winsock Status information

Status = ""

For i = 0 To WSASYS_STATUS_LEN
If WSAdata.szSystemStatus(i) = 0 Then Exit For
Status = Status + Chr$(WSAdata.szSystemStatus(i))
Next i

End Sub
Function HiByte(ByVal wParam As Integer)

HiByte = wParam \ &H100 And &HFF&

End Function
Function LoByte(ByVal wParam As Integer)

LoByte = wParam And &HFF&

End Function
Sub vbWSACleanup()

' Subroutine to perform WSACleanup

iReturn = WSACleanup()

If iReturn <> 0 Then ' If WSock32 error, then tell me about it.
sMsg = "WSock32 Error - " & Trim$(Str$(iReturn)) & " occurred in Cleanup"
MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
End
End If

End Sub

Sub vbIcmpCloseHandle()

bReturn = IcmpCloseHandle(hIP)

If bReturn = False Then
MsgBox "ICMP Closed with Error", vbOKOnly, "VB4032-ICMPEcho"
End If

End Sub

Sub vbIcmpCreateFile()

hIP = IcmpCreateFile()

If hIP = 0 Then
MsgBox "Unable to Create File Handle", vbOKOnly, "VBPing32"
End If

End Sub
Private Sub Command1_Click()

vbWSAStartup ' Initialize Winsock

If Len(Text1.Text) = 0 Then
vbGetHostName
End If

If Text1.Text = "" Then
MsgBox "No Hostname Specified!", vbOKOnly, "VB4032-ICMPEcho" ' Complain if No Host Name Identified
vbWSACleanup
Exit Sub
End If

vbGetHostByName ' Get the IPAddress for the Host

vbIcmpCreateFile ' Get ICMP Handle

' The following determines the TTL of the ICMPEcho

If IsNumeric(Text2.Text) Then
If (Val(Text2.Text) > 255) Then Text2.Text = "255"
If (Val(Text2.Text) < 2) Then Text2.Text = "2"
Else
Text2.Text = "255"
End If

pIPo.TTL = Trim$(Text2.Text)

vbIcmpSendEcho ' Send the ICMP Echo Request

vbIcmpCloseHandle ' Close the ICMP Handle

vbWSACleanup ' Close Winsock

End Sub

Private Sub Command2_Click()

text3.Text = ""

End Sub

Private Sub Command3_Click()

text3.Text = ""

vbWSAStartup ' Initialize Winsock

If Len(Text1.Text) = 0 Then
vbGetHostName
End If

If Text1.Text = "" Then
MsgBox "No Hostname Specified!", vbOKOnly, "VB4032-ICMPEcho" ' Complain if No Host Name Identified
vbWSACleanup
Exit Sub
End If

vbGetHostByName ' Get the IPAddress for the Host

vbIcmpCreateFile ' Get ICMP Handle


' The following determines the TTL of the ICMPEcho for TRACE function

TraceRT = True

text3.Text = text3.Text + "Tracing Route to " + Label3.Caption + ":" + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)

For TTL = 2 To 255

pIPo.TTL = TTL

vbIcmpSendEcho ' Send the ICMP Echo Request
DoEvents

If RespondingHost = Label3.Caption Then

text3.Text = text3.Text + Chr$(13) + Chr$(10) + "Route Trace has Completed" + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)

Exit For ' Stop TraceRT

End If

Next TTL

TraceRT = False

vbIcmpCloseHandle ' Close the ICMP Handle

vbWSACleanup ' Close Winsock

End Sub

Private Sub Form_Load()

' I have, on many occasions, found the need to be able to perform
' a Ping function from within Visual Basic. There are a few OCX
' Controls available on the market, however, they all require the
' ability for the WinSock stack to support SOCK_RAW.

' Microsoft does not support Raw Sockets on any of their WinSock1.1
' stacks. It also appears that it will not be supported on the
' Winsock2.0 stack for Windows95.

' Raw Sockets, however, is supported on NT4.0.

' Microsoft, due to the lack of support of Raw Sockets, created the
' ICMP.DLL in order to perform basic ICMP functions such as PING and
' TRACERT.

' Well, I have finally figured out how to use the ICMP.DLL from Visual
' Basic. There are not additives and no preservatives.

' This program is provided as is, without any warranties. I am providing
' it freely. I designed it on Windows95, however, I am sure it will work
' on NT3.51. if you use portions of this code, please include some sort
' of reference to the author.

' This program was created by Jim Huff of Edinborg Productions.

' If you have any questions, you can reach me at:

' [e-mail]
' [e-mail]

CenterForm

End Sub

[vbfdy]

飞鸽是局域网的一个软件，传输文件用的

谢谢therockdelt(Dm和弦），这些代码我找过很多了，从1TO255 ping下来都卡机。。。

[zhzhq800204]

帮顶，学习

[daisy8675]

飞鸽是虾米东西....

扫描器的代码网上到处都有

只是send网段