vb 判断域名是否能连通

在vb6中添加一个模块,输入下面代码。调用方法:PingIp("www.3gcomet.com")  或 PingIp("172.18.170.200") 

ASP/Visual Basic代码
  1. '*******************************************  
  2. '**函 数 名: PingIp  
  3. '**输    入: ByVal szIP(String) -IP或域名  
  4. '**输    出: (Boolean) -True为可ping通  
  5. '**功能描述: 判断输入IP或域名是否可ping通  
  6. '**全局变量:  
  7. '**调用模块:  
  8. '**作    者: comet  
  9. '**日    期: 2012-06-19 06:15:00  
  10. '**修 改 人:  
  11. '**日    期:  
  12. '**版    本: V1.0.0  
  13. '*******************************************  
  14.   
  15. Option Explicit  
  16.   
  17.     
  18. Private Const IP_SUCCESS As Long = 0  
  19. Private Const IP_STATUS_BASE As Long = 11000  
  20. Private Const IP_BUF_TOO_SMALL As Long = (11000 + 1)  
  21. Private Const IP_DEST_NET_UNREACHABLE As Long = (11000 + 2)  
  22. Private Const IP_DEST_HOST_UNREACHABLE As Long = (11000 + 3)  
  23. Private Const IP_DEST_PROT_UNREACHABLE As Long = (11000 + 4)  
  24. Private Const IP_DEST_PORT_UNREACHABLE As Long = (11000 + 5)  
  25. Private Const IP_NO_RESOURCES As Long = (11000 + 6)  
  26. Private Const IP_BAD_OPTION As Long = (11000 + 7)  
  27. Private Const IP_HW_ERROR As Long = (11000 + 8)  
  28. Private Const IP_PACKET_TOO_BIG As Long = (11000 + 9)  
  29. Private Const IP_REQ_TIMED_OUT As Long = (11000 + 10)  
  30. Private Const IP_BAD_REQ As Long = (11000 + 11)  
  31. Private Const IP_BAD_ROUTE As Long = (11000 + 12)  
  32. Private Const IP_TTL_EXPIRED_TRANSIT As Long = (11000 + 13)  
  33. Private Const IP_TTL_EXPIRED_REASSEM As Long = (11000 + 14)  
  34. Private Const IP_PARAM_PROBLEM As Long = (11000 + 15)  
  35. Private Const IP_SOURCE_QUENCH As Long = (11000 + 16)  
  36. Private Const IP_OPTION_TOO_BIG As Long = (11000 + 17)  
  37. Private Const IP_BAD_DESTINATION As Long = (11000 + 18)  
  38. Private Const IP_ADDR_DeleteD As Long = (11000 + 19)  
  39. Private Const IP_SPEC_MTU_CHANGE As Long = (11000 + 20)  
  40. Private Const IP_MTU_CHANGE As Long = (11000 + 21)  
  41. Private Const IP_UNLOAD As Long = (11000 + 22)  
  42. Private Const IP_ADDR_ADDED As Long = (11000 + 23)  
  43. Private Const IP_GENERAL_FAILURE As Long = (11000 + 50)  
  44. Private Const MAX_IP_STATUS As Long = (11000 + 50)  
  45. Private Const IP_PENDING As Long = (11000 + 255)  
  46. Private Const PING_TIMEOUT As Long = 500  
  47. Private Const WS_VERSION_REQD As Long = &H101  
  48. Private Const MIN_SOCKETS_REQD As Long = 1  
  49. Private Const SOCKET_ERROR As Long = -1  
  50. Private Const INADDR_NONE As Long = &HFFFFFFFF  
  51. Private Const MAX_WSADescription As Long = 256  
  52. Private Const MAX_WSASYSStatus As Long = 128  
  53.   
  54. Private Type ICMP_OPTIONS  
  55.     Ttl             As Byte  
  56.     Tos             As Byte  
  57.     Flags           As Byte  
  58.     OptionsSize     As Byte  
  59.     OptionsData     As Long  
  60. End Type  
  61. Private Type ICMP_ECHO_REPLY  
  62.     Address         As Long  
  63.     status          As Long  
  64.     RoundTripTime   As Long  
  65.     DataSize        As Long  
  66.     DataPointer     As Long  
  67.     Options         As ICMP_OPTIONS  
  68.     Data            As String * 250  
  69. End Type  
  70. Private Type WSADATA  
  71.    wVersion As Integer  
  72.    wHighVersion As Integer  
  73.    szDescription(0 To MAX_WSADescription) As Byte  
  74.    szSystemStatus(0 To MAX_WSASYSStatus) As Byte  
  75.    wMaxSockets As Long  
  76.    wMaxUDPDG As Long  
  77.    dwVendorInfo As Long  
  78. End Type  
  79.   
  80. Private Type HOSTENT  
  81.   hname As Long  
  82.   hAliases As Long  
  83.   hAddrType As Integer  
  84.   hLength As Integer  
  85.   hAddrList As Long  
  86. End Type  
  87.   
  88. Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long  
  89. Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As LongAs Long  
  90. Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As LongByVal DestinationAddress As LongByVal RequestData As StringByVal RequestSize As LongByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As LongByVal Timeout As LongAs Long  
  91. Private Declare Function WSAGetLastError Lib "wsock32" () As Long  
  92. Private Declare Function WSAStartup Lib "wsock32" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long  
  93. Private Declare Function WSACleanup Lib "wsock32" () As Long  
  94. Private Declare Function gethostname Lib "wsock32" (ByVal szHost As StringByVal dwHostLen As LongAs Long  
  95. Private Declare Function gethostbyname Lib "wsock32" (ByVal szHost As StringAs Long  
  96. Private Declare Function inet_addr Lib "wsock32" (ByVal s As StringAs Long  
  97. Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)  
  98.   
  99. Private Function GetStatusCode(status As LongAs String  
  100.    On Error GoTo Z  
  101.    Dim Msg As String  
  102.    Select Case status  
  103.             Case IP_SUCCESS:               Msg = "ip success"  
  104.             Case INADDR_NONE:              Msg = "inet_addr: bad IP format"  
  105.             Case IP_BUF_TOO_SMALL:         Msg = "ip buf too_small"  
  106.             Case IP_DEST_NET_UNREACHABLE:  Msg = "ip dest net unreachable"  
  107.             Case IP_DEST_HOST_UNREACHABLE: Msg = "ip dest host unreachable"  
  108.             Case IP_DEST_PROT_UNREACHABLE: Msg = "ip dest prot unreachable"  
  109.             Case IP_DEST_PORT_UNREACHABLE: Msg = "ip dest port unreachable"  
  110.             Case IP_NO_RESOURCES:          Msg = "ip no resources"  
  111.             Case IP_BAD_OPTION:            Msg = "ip bad option"  
  112.             Case IP_HW_ERROR:              Msg = "ip hw_error"  
  113.             Case IP_PACKET_TOO_BIG:        Msg = "ip packet too_big"  
  114.             Case IP_REQ_TIMED_OUT:         Msg = "ip req timed out"  
  115.             Case IP_BAD_REQ:               Msg = "ip bad req"  
  116.             Case IP_BAD_ROUTE:             Msg = "ip bad route"  
  117.             Case IP_TTL_EXPIRED_TRANSIT:   Msg = "ip ttl expired transit"  
  118.             Case IP_TTL_EXPIRED_REASSEM:   Msg = "ip ttl expired reassem"  
  119.             Case IP_PARAM_PROBLEM:         Msg = "ip param_problem"  
  120.             Case IP_SOURCE_QUENCH:         Msg = "ip source quench"  
  121.             Case IP_OPTION_TOO_BIG:        Msg = "ip option too_big"  
  122.             Case IP_BAD_DESTINATION:       Msg = "ip bad destination"  
  123.             Case IP_ADDR_DeleteD:          Msg = "ip addr deleted"  
  124.             Case IP_SPEC_MTU_CHANGE:       Msg = "ip spec mtu change"  
  125.             Case IP_MTU_CHANGE:            Msg = "ip mtu_change"  
  126.             Case IP_UNLOAD:                Msg = "ip unload"  
  127.             Case IP_ADDR_ADDED:            Msg = "ip addr added"  
  128.             Case IP_GENERAL_FAILURE:       Msg = "ip general failure"  
  129.             Case IP_PENDING:               Msg = "ip pending"  
  130.             Case PING_TIMEOUT:             Msg = "ping timeout"  
  131.             Case Else:                     Msg = "unknown msg returned"  
  132.    End Select  
  133.    GetStatusCode = Msg  
  134.    Exit Function  
  135. Z:  
  136.    GetStatusCode = ""  
  137. End Function  
  138. Private Function Ping(sAddress As String, sDataToSend As String, ECHO As ICMP_ECHO_REPLY) As Long  
  139.    On Error GoTo Z  
  140.    Dim hPort As Long  
  141.    Dim dwAddress As Long  
  142.    dwAddress = inet_addr(sAddress)  
  143.    If dwAddress <> INADDR_NONE Then  
  144.       hPort = IcmpCreateFile()  
  145.       If hPort Then  
  146.          Call IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, ECHO, Len(ECHO), PING_TIMEOUT)  
  147.          Ping = ECHO.status  
  148.          Call IcmpCloseHandle(hPort)  
  149.       End If  
  150.    Else  
  151.       Ping = INADDR_NONE  
  152.    End If  
  153.    Exit Function  
  154. Z:  
  155.    Ping = INADDR_NONE  
  156. End Function  
  157.   
  158. Private Function GetIPByName(name As StringAs String  
  159.    Dim hostent_addr As Long  
  160.    Dim host As HOSTENT  
  161.    Dim hostip_addr As Long  
  162.    Dim temp_ip_address() As Byte  
  163.    Dim i As Integer  
  164.    Dim ip_address As String  
  165.      
  166.    hostent_addr = gethostbyname(name)  
  167.      
  168.    If hostent_addr = 0 Then  
  169.       GetIPByName = ""                     '主机名不能被解释  
  170.       Exit Function  
  171.    End If  
  172.      
  173.    RtlMoveMemory host, hostent_addr, LenB(host)  
  174.    RtlMoveMemory hostip_addr, host.hAddrList, 4  
  175.      
  176.    ReDim temp_ip_address(1 To host.hLength)  
  177.    RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength  
  178.      
  179.    For i = 1 To host.hLength  
  180.       ip_address = ip_address & temp_ip_address(i) & "."  
  181.    Next  
  182.    ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)  
  183.      
  184.    GetIPByName = ip_address  
  185.   
  186. End Function  
  187.   
  188. Function IsIP(ByVal Expression As StringAs Boolean  
  189.     If InStr(Expression, ","Then IsIP = FalseExit Function  
  190.     Dim vArr  
  191.     vArr = Split(Expression, ".")  
  192.     If UBound(vArr) = 3 Then  
  193.         Dim i As Integer  
  194.         For i = 0 To 3  
  195.             If IsNumeric(vArr(i)) Then  
  196.                 If Val(vArr(i)) < 0 Or Val(vArr(i)) > 255 Then  
  197.                     IsIP = False  
  198.                     Exit Function  
  199.                 End If  
  200.             Else  
  201.                 IsIP = False  
  202.                 Exit Function  
  203.             End If  
  204.         Next  
  205.     IsIP = True  
  206.     End If  
  207. End Function  
  208.   
  209.   
  210. '(Ping函数)  
  211. '参数:目标IP地址  
  212. '返回值:存在返回True,否则返回False  
  213. Public Function PingIp(ByVal szIp As StringAs Boolean  
  214.     On Error GoTo Z  
  215.     Dim WSAD As WSADATA  
  216.     Dim ECHO As ICMP_ECHO_REPLY  
  217.     Dim ret As Long  
  218.   
  219.     If WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS Then  
  220.         If IsIP(szIp) Then  
  221.             ret = Ping(Trim(szIp), "comet", ECHO)  
  222.         Else  
  223.             ret = Ping(GetIPByName(Trim(szIp)), "comet", ECHO)  
  224.         End If  
  225.       
  226.         If InStr(1, GetStatusCode(ret), "success") <> 0 Then  
  227.             WSACleanup  
  228.             PingIp = True  
  229.             Exit Function  
  230.         End If  
  231.     End If  
  232.     PingIp = False  
  233.     Exit Function  
  234. Z:  
  235.     PingIp = False  
  236. End Function  

 

发表评论

电子邮件地址不会被公开。 必填项已用*标注

此站点使用Akismet来减少垃圾评论。了解我们如何处理您的评论数据