Option Explicit'用于网络不通时先判断网络状态,免得网络不通而导致数据库连接状态检查时间较长带来的麻烦Private Declare Function IcmpCreateFile Lib "icmp.dll" () As LongPrivate Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As LongPrivate Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Long, ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As LongPrivate Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As LongPrivate Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As LongPrivate Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
' ICMP返回的报文信息常数和Winsock版本等相关 常数Private Const IP_STATUS_BASE = 11000Private Const IP_SUCCESS = 0Private 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 + 50Private Const IP_PENDING = (11000 + 255)Private Const PING_TIMEOUT = 200Private Const WS_VERSION_REQD = &H101Private 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 = 1Private Const SOCKET_ERROR = -1Private Const MAX_WSADescription = 256Private Const MAX_WSASYSStatus = 128
' ICMP选项结构Private Type ICMP_OPTIONSTtl As ByteTos As ByteFlags As ByteOptionsSize As ByteOptionsData As LongEnd Type
' ICMP应答结构Private Type ICMP_ECHO_REPLYAddress As Longstatus As LongRoundTripTime As LongDataSize As LongDataPointer As LongOptions As ICMP_OPTIONSData As String * 250End Type
' 存放Winsock版本等信息的结构Private Type WSADATAwVersion As IntegerwHighVersion As IntegerszDescription(0 To MAX_WSADescription) As ByteszSystemStatus(0 To MAX_WSASYSStatus) As BytewMaxSockets As LongwMaxUDPDG As LongdwVendorInfo As LongEnd Type
Dim ICMPOPT As ICMP_OPTIONS
' 返回Private Function GetStatusCode(status As Long) As StringDim msg As StringSelect Case statusCase 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 SelectGetStatusCode = CStr(status) & " [ " & msg & " ]"End Function' 获得一个整数的高位字节Private Function HiByte(ByVal wParam As Long) As IntegerHiByte = wParam / &H100 And &HFF&End Function'获得一个整数的低位字节Private Function LoByte(ByVal wParam As Long) As IntegerLoByte = wParam And &HFF&End Function
' Ping一个IP地址Private Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As LongDim hPort As LongDim dwAddress As LongDim sDataToSend As StringDim iOpt As LongsDataToSend = "Echo This"dwAddress = AddressStringToLong(szAddress)hPort = IcmpCreateFile()If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, ECHO, Len(ECHO), PING_TIMEOUT) Then'如果ping成功,返回状态0Ping = ECHO.RoundTripTimeElsePing = ECHO.status * -1End IfCall IcmpCloseHandle(hPort)End Function
' 将文本框中的IP地址转换成系统识别的长整数形式Function AddressStringToLong(ByVal tmp As String) As LongDim i As IntegerDim parts(1 To 4) As Stringi = 0'转换IP地址While InStr(tmp, ".") > 0i = i + 1parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)tmp = Mid(tmp, InStr(tmp, ".") + 1)Wendi = i + 1parts(i) = tmpIf i <> 4 ThenAddressStringToLong = 0Exit FunctionEnd IfAddressStringToLong = 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
' 初始化SocketPrivate Function SocketsInitialize() As BooleanDim WSAD As WSADATADim x As IntegerDim szLoByte As StringDim szHiByte As StringDim szBuf As String
'初始化Socketx = WSAStartup(WS_VERSION_REQD, WSAD)If x <> 0 Then'MsgBox "Windows Sockets for 32 bit Windows " & "environments is not successfully responding."Exit FunctionEnd If
' 判断是否有支持足够的SocketIf LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) ThenszHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByteszBuf = szBuf & " is not supported by Windows " & "Sockets for 32 bit Windows environments."'MsgBox szBuf, vbExclamationExit FunctionEnd If
' 判断Winsock的版本是否被32位的Winsock支持If WSAD.wMaxSockets < MIN_SOCKETS_REQD ThenszBuf = "This application requires a minimum of " & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."'MsgBox szBuf, vbExclamationExit FunctionEnd IfSocketsInitialize = TrueEnd Function
' 关闭SocketsPrivate Sub SocketsCleanup()Dim x As Long'关闭Socketsx = WSACleanup()If x <> 0 ThenMsgBox "Windows Sockets error " & Trim$(Str$(x)) & " occurred in Cleanup.", vbExclamationEnd IfEnd Sub
Public Function Ping_IP(IPStr As String) As Long'0-成功;1-错误IP(继续访问数据库);2-Ping不通Ping_IP = 1If Trim(IPStr) = "" Then Exit FunctionDim ECHO As ICMP_ECHO_REPLYDim pos As IntegerIf SocketsInitialize() Then'ping地址Call Ping(IPStr, ECHO)'显示ping结果Select Case ECHO.statusCase IP_SUCCESS:Ping_IP = 0Case IP_BAD_DESTINATION:Ping_IP = 1Case Else:Ping_IP = 2End SelectSocketsCleanupEnd IfEnd Function
