VB6 通过IP判断局域网主机是否在线！

VB6 通过IP判断局域网主机是否在线！

'请把以下代码放到模块中

'调用方法

IPValid("127.0.0.1") = True or False

Option Explicit

'************************************************************

Private Const IP_STATUS_BASE = 11000

Private Const IP_SUCCESS = 0

Private Const IP_BUF_TOO_SMALL = (11000 + 1)

Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2)

Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)

Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)

Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)

Private Const IP_NO_RESOURCES = (11000 + 6)

Private Const IP_BAD_OPTION = (11000 + 7)

Private Const IP_HW_ERROR = (11000 + 8)

Private Const IP_PACKET_TOO_BIG = (11000 + 9)

Private Const IP_REQ_TIMED_OUT = (11000 + 10)

Private Const IP_BAD_REQ = (11000 + 11)

Private Const IP_BAD_ROUTE = (11000 + 12)

Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)

Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)

Private Const IP_PARAM_PROBLEM = (11000 + 15)

Private Const IP_SOURCE_QUENCH = (11000 + 16)

Private Const IP_OPTION_TOO_BIG = (11000 + 17)

Private Const IP_BAD_DESTINATION = (11000 + 18)

Private Const IP_ADDR_DELETED = (11000 + 19)

Private Const IP_SPEC_MTU_CHANGE = (11000 + 20)

Private Const IP_MTU_CHANGE = (11000 + 21)

Private Const IP_UNLOAD = (11000 + 22)

Private Const IP_ADDR_ADDED = (11000 + 23)

Private Const IP_GENERAL_FAILURE = (11000 + 50)

Private Const MAX_IP_STATUS = 11000 + 50

Private Const IP_PENDING = (11000 + 255)

Private Const PING_TIMEOUT = 200

Private Const WS_VERSION_REQD = &H101

Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&

Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&

Private Const MIN_SOCKETS_REQD = 1

Private Const SOCKET_ERROR = -1

Private Const MAX_WSADescription = 256

Private Const MAX_WSASYSStatus = 128

Private Type ICMP_OPTIONS

Ttl As Byte

Tos As Byte

Flags As Byte

OptionsSize As Byte

OptionsData As Long

End Type

'************************************************************

Dim ICMPOPT As ICMP_OPTIONS

Private Type ICMP_ECHO_REPLY

Address As Long

status As Long

RoundTripTime As Long

DataSize As Integer

Reserved As Integer

DataPointer As Long

Options As ICMP_OPTIONS

Data As String * 250

End Type

'************************************************************

Private Type WSADATA

wVersion As Integer

wHighVersion As Integer

szDescription(0 To MAX_WSADescription) As Byte

szSystemStatus(0 To MAX_WSASYSStatus) As Byte

wMaxSockets As Integer

wMaxUDPDG As Integer

dwVendorInfo As Long

End Type

'************************************************************

Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long

Private Declare Function IcmpCloseHandle Lib "icmp.dll" _

(ByVal IcmpHandle As Long) _

As Long

Private Declare Function IcmpSendEcho Lib "icmp.dll" _

(ByVal IcmpHandle As Long, _

ByVal DestinationAddress As Long, _

ByVal RequestData As String, _

ByVal RequestSize As Integer, _

ByVal RequestOptions As Long, _

ReplyBuffer As ICMP_ECHO_REPLY, _

ByVal ReplySize As Long, _

ByVal Timeout As Long) _

As Long

Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

Private Declare Function WSAStartup Lib "WSOCK32.DLL" _

(ByVal wVersionRequired As Long, _

lpWSADATA As WSADATA) _

As Long

Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Private Function GetStatusCode(status As Long) As String

Dim msg As String

Select Case status

Case IP_SUCCESS: msg = "ip success"

Case IP_BUF_TOO_SMALL: msg = "ip buf too_small"

Case IP_DEST_NET_UNREACHABLE: msg = "ip dest net unreachable"

Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"

Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"

Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"

Case IP_NO_RESOURCES: msg = "ip no resources"

Case IP_BAD_OPTION: msg = "ip bad option"

Case IP_HW_ERROR: msg = "ip hw_error"

Case IP_PACKET_TOO_BIG: msg = "ip packet too_big"

Case IP_REQ_TIMED_OUT: msg = "ip req timed out"

Case IP_BAD_REQ: msg = "ip bad req"

Case IP_BAD_ROUTE: msg = "ip bad route"

Case IP_TTL_EXPIRED_TRANSIT: msg = "ip ttl expired transit"

Case IP_TTL_EXPIRED_REASSEM: msg = "ip ttl expired reassem"

Case IP_PARAM_PROBLEM: msg = "ip param_problem"

Case IP_SOURCE_QUENCH: msg = "ip source quench"

Case IP_OPTION_TOO_BIG: msg = "ip option too_big"

Case IP_BAD_DESTINATION: msg = "ip bad destination"

Case IP_ADDR_DELETED: msg = "ip addr deleted"

Case IP_SPEC_MTU_CHANGE: msg = "ip spec mtu change"

Case IP_MTU_CHANGE: msg = "ip mtu_change"

Case IP_UNLOAD: msg = "ip unload"

Case IP_ADDR_ADDED: msg = "ip addr added"

Case IP_GENERAL_FAILURE: msg = "ip general failure"

Case IP_PENDING: msg = "ip pending"

Case PING_TIMEOUT: msg = "ping timeout"

Case Else: msg = "unknown msg returned"

End Select

GetStatusCode = CStr(status) & " [ " & msg & " ]"

End Function

'************************************************************

Private Function HiByte(ByVal wParam As Integer)

HiByte = wParam \ &H100 And &HFF&

End Function

'************************************************************

Private Function LoByte(ByVal wParam As Integer)

LoByte = wParam And &HFF&

End Function

'************************************************************

Private Function ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long

Dim hPort As Long

Dim dwAddress As Long

Dim sDataToSend As String

Dim iOpt As Long

sDataToSend = "My Request"

dwAddress = AddressStringToLong(szAddress)

Call SocketsInitialize

hPort = IcmpCreateFile()

If IcmpSendEcho(hPort, _

dwAddress, _

sDataToSend, _

Len(sDataToSend), _

0, _

ECHO, _

Len(ECHO), _

PING_TIMEOUT) Then

ping = ECHO.RoundTripTime

Else: ping = ECHO.status * -1

End If

Call IcmpCloseHandle(hPort)

Call SocketsCleanup

End Function

'************************************************************

Function AddressStringToLong(ByVal tmp As String) As Long

Dim i As Integer

Dim parts(1 To 4) As String

i = 0

While InStr(tmp, ".") > 0

i = i + 1

parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)

tmp = Mid(tmp, InStr(tmp, ".") + 1)

Wend

i = i + 1

parts(i) = tmp

If i <> 4 Then

AddressStringToLong = 0

Exit Function

End If

AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _

Right("00" & Hex(parts(3)), 2) & _

Right("00" & Hex(parts(2)), 2) & _

Right("00" & Hex(parts(1)), 2))

End Function

'************************************************************

Private Function SocketsCleanup() As Boolean

Dim X As Long

X = WSACleanup()

If X <> 0 Then

MsgBox "Windows Sockets error " & Trim$(Str$(X)) & _

" occurred in Cleanup.", vbExclamation

SocketsCleanup = False

Else

SocketsCleanup = True

End If

End Function

'************************************************************

Private Function SocketsInitialize() As Boolean

Dim WSAD As WSADATA

Dim X As Integer

Dim szLoByte As String, szHiByte As String, szBuf As String

X = WSAStartup(WS_VERSION_REQD, WSAD)

If X <> 0 Then

MsgBox "Windows Sockets for 32 bit Windows " & _

"environments is not successfully responding."

SocketsInitialize = False

Exit Function

End If

If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _

(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _

HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then

szHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))

szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))

szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte

szBuf = szBuf & " is not supported by Windows " & _

"Sockets for 32 bit Windows environments."

MsgBox szBuf, vbExclamation

SocketsInitialize = False

Exit Function

End If

If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then

szBuf = "This application requires a minimum of " & _

Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."

MsgBox szBuf, vbExclamation

SocketsInitialize = False

Exit Function

End If

SocketsInitialize = True

End Function

'************************************************************

Public Function IPValid(ip As String) As Boolean

SocketsInitialize

Dim ECHO As ICMP_ECHO_REPLY

ping Trim(ip), ECHO

If ECHO.DataSize <> 0 Then IPValid = True Else IPValid = False

SocketsCleanup

End Function

本方法来自网络，如有侵权请联系本人删除！