Option Explicit
'###################
'    雪糕乐园 www.btoss.com
'###################
Private Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End Type
  
Private Type WSADATA
    wversion As Integer
    wHighVersion As Integer
    szDescription(0 To 256) As Byte
    szSystemStatus(0 To 128) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpszVendorInfo As Long
End Type
  
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Integer, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHostname As String, ByVal HostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHostname As String) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
  
Private Const WS_VERSION_REQD = &H101
  
Private Function Test(URL As String) As String
    InitializeWinSock
    Test = GetAddressByName(URL) '    雪糕乐园 www.btoss.com
    TerminateWinSock
End Function
  
Private Function GetAddressByName(strHostname As String)
    Dim lngAddr As Long
    Dim udtHost As HOSTENT
    Dim lngIP As Long
    Dim bteTmp() As Byte
    Dim i As Integer
    Dim strIP As String
  
    lngAddr = gethostbyname(strHostname)
  
    If lngAddr = 0 Then
        MsgBox "Kein Host gefunden."
        GetAddressByName = Null
        Exit Function
    End If
  
    RtlMoveMemory udtHost, lngAddr, LenB(udtHost)
    RtlMoveMemory lngIP, udtHost.hAddrList, 4
  
    ReDim bteTmp(1 To udtHost.hLength)
    RtlMoveMemory bteTmp(1), lngIP, udtHost.hLength
    For i = 1 To udtHost.hLength
        strIP = strIP & bteTmp(i) & "."
    Next
    strIP = Mid$(strIP, 1, Len(strIP) - 1)
  
    GetAddressByName = strIP
End Function
  
Private Sub InitializeWinSock()
    Dim udtWSAD As WSADATA
    Dim lngRet As Long
    lngRet = WSAStartup(WS_VERSION_REQD, udtWSAD)
    If lngRet <> 0 Then
        MsgBox "Winsock.dll konnte nicht initialisiert werden."
        End
    End If
End Sub
'###################
'    雪糕乐园 www.btoss.com
'###################
Private Sub TerminateWinSock()
    Dim lngRet As Long
    lngRet = WSACleanup()
    If lngRet <> 0 Then
        MsgBox "Fehler " & lngRet & " beim Beenden von Winsock.dll" '    雪糕乐园 www.btoss.com
        End
    End If
End Sub
  
Private Sub Command1_Click()
    Dim MyURL As String
    MyURL = "www.btoss.com"
    MsgBox MyURL & "的IP地址是：" & Test(MyURL)
End Sub