如何将PING命令添加到VB程序中取得相应域名的IP地址？

Question

请问如何将PING命令添加到VB程序中取得相应域名的IP地址，最好能提供一小段可以直接用的源代码，小弟现在急着用，谢谢各位高手的指点！

Answer 1

Option Explicit';----------------------------------------
';-------------------------------
'; 从域名得到IP及从IP得到域名
';
'; 调用接口：GetIP() & GetName()
';-------------------------------
';----------------------------------------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 WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128Private Type HOSTENT
   hname As Long
   hAliases As Long
   hAddrType As Integer
   hLength As Integer
   hAddrList As Long
End TypePrivate Type WSADATA
   wversion As Integer
   wHighVersion As Integer
   szDescription(0 To WSADescription_Len) As Byte
   szSystemStatus(0 To WSASYS_Status_Len) As Byte
   iMaxSockets As Integer
   iMaxUdpDg As Integer
   lpszVendorInfo As Long
End TypePrivate Declare Function gethostbyaddr Lib "WSOCK32.DLL" (addr As Any, ByVal byteslen As Integer, addrtype As Integer) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)'-------------------------------
'通过主机名获取IP
'   :不传递参数将获取本机IP地址
'-------------------------------
Function GetIP(Optional ByVal name As String) As String
    
    If Not SocketsInitialize() Then
        'Stockets 初始化失败
        GetIP = ""
        Exit Function
    End If   Dim hostent_addr As Long
   Dim host As HOSTENT
   Dim hostip_addr As Long
   Dim temp_ip_address() As Byte
   Dim i As Integer
   Dim ip_address As String
   
   hostent_addr = gethostbyname(name)
   
   If hostent_addr = 0 Then
        '主机名不能被解释
      GetIP = ""
      Exit Function
   End If
   
   RtlMoveMemory host, hostent_addr, LenB(host)
   RtlMoveMemory hostip_addr, host.hAddrList, 4
   
   ReDim temp_ip_address(1 To host.hLength)
   RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
   
   For i = 1 To host.hLength
      ip_address = ip_address & temp_ip_address(i) & "."
   Next
   ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
   
   GetIP = ip_address    SocketsCleanup
End Function'----------------------------------
'通过IP地址获得主机名称
'   :不传递参数将获取本机名称
'----------------------------------
Function GetName(Optional ByVal addrstr As String) As String
    
    If Not SocketsInitialize() Then
        'Stockets 初始化失败
        GetName = ""
        Exit Function
    End If
    
    Dim hostent_addr As Long
    Dim host As HOSTENT
    Dim addr(0 To 50) As Byte
    Dim addrs As String
    Dim hname(1 To 50) As Byte
    Dim str As String
    Dim i As Integer, j As Integer
    Dim temp_int As Integer
    Dim byt As Byte
    
    str = Trim$(addrstr)
    i = 0
    j = 0
    Do
        temp_int = 0
        i = i + 1
        Do While Mid$(str, i, 1) >= "0" And Mid$(str, i, 1) <= "9" And i <= Len(str)
            temp_int = temp_int * 10 + Mid$(str, i, 1)
            i = i + 1
        Loop
        If temp_int <= 255 Then
            addr(j) = temp_int
            j = j + 1
        End If
    
    Loop Until Mid$(str, i, 1) <> "." Or i > Len(str) Or temp_int > 255
    If temp_int > 255 Then
        'GetName = "地址非法"
        GetName = ""
        Exit Function
    End If
    
    hostent_addr = gethostbyaddr(addr(0), j, 2)
    If hostent_addr = 0 Then
        'GetName = "此地址无法解析"
        GetName = ""
        Exit Function
    End If
    
    RtlMoveMemory host, hostent_addr, LenB(host)
    RtlMoveMemory hname(1), host.hname, 50
    
    j = 51
    For i = 1 To 50
        If hname(i) = 0 Then
            j = i
        End If
        If i >= j Then
            hname(i) = 32
        End If
    Next i
    GetName = Trim$(StrConv(hname, vbUnicode))
    
    SocketsCleanup
End FunctionPrivate Function hibyte(ByVal wParam As Integer)
'获得整数的高位
   hibyte = wParam \ &H100 And &HFF&
End FunctionPrivate Function lobyte(ByVal wParam As Integer)
'获得整数的低位
   lobyte = wParam And &HFF&
End FunctionPrivate Function SocketsInitialize() As Boolean
'初始化 Stockets   Dim WSAD As WSADATA
   Dim iReturn As Integer
   Dim sLowByte As String, sHighByte As String, sMsg As String
   
   iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
   
   If iReturn <> 0 Then
      'MsgBox "Winsock.dll 没有反应."
      'End
      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
      sHighByte = Trim$(str$(hibyte(WSAD.wversion)))
      sLowByte = Trim$(str$(lobyte(WSAD.wversion)))
      'sMsg = "Windows Sockets版本 " & sLowByte & "." & sHighByte
      'sMsg = sMsg & " 不被winsock.dll支持 "
      'MsgBox sMsg
      'End
      Exit Function
   End If
   
   If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
      'sMsg = "这个系统需要的最少 Sockets 数为 "
      'sMsg = sMsg & Trim$(str$(MIN_SOCKETS_REQD))
      'MsgBox sMsg
      'End
      Exit Function
   End If
   
   SocketsInitialize = True
End FunctionPrivate Function SocketsCleanup() As Boolean
'释放 Stocks   Dim lReturn As Long
   
   lReturn = WSACleanup()
   
   If lReturn <> 0 Then
      'MsgBox "Socket错误 " & Trim$(str$(lReturn)) & " occurred in Cleanup "
      'End
      Exit Function
   End If
   
   SocketsCleanup = True
End Function

Answer 2

http://www.mndsoft.com/blog/blogview.asp?logID=519&cateID=3