Add the code below to a new VBA module and then use this formula:
=GetStringFromIPAddress(GetIPAddressFromHostName(A1))
[Begin Code Segment]
Option Explicit
Private Const INTERNET_CONNECTION_LAN = &H2
Private Const INTERNET_CONNECTION_MODEM = &H1
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Const WS_VERSION_REQD As Long = &H101
Private Const PING_TIMEOUT As Long = 500
Public Enum tPingError
PingError_InvalidTarget = 0
PingError_Timeout = -1
PingError_Other = -2
End Enum
Private Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Private Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Long
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription As String * MAX_WSADescription
szSystemStatus As String * MAX_WSASYSStatus
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Declare Function InternetGetConnectedState Lib "wininet.dll" ( _
ByRef lpdwFlags As Long, _
ByVal dwReserved As Long _
) As Long
Private Declare Function gethostbyname Lib "wsock32" ( _
ByVal HostName As String _
) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long _
)
Public Declare Function WSAStartup Lib "wsock32" _
(ByVal wVersionRequired As Long, _
lpWSADATA As WSADATA) As Long
Public Declare Function WSACleanup Lib "wsock32" () As Long
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 Long, _
ByVal RequestOptions As Long, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal Timeout As Long) As Long
Public Function GetFullHostNameFromHostName( _
ByVal HostName As String _
) As String
' Return the full host name from a host name.
Dim HostEntry As HOSTENT
Dim HostEntryPtr As Long
Dim IPAddressesPtr As Long
Dim Result As String
If InitializeSockets Then
HostEntryPtr = gethostbyname(HostName & vbNullChar)
If HostEntryPtr > 0 Then
CopyMemory HostEntry, ByVal HostEntryPtr, Len(HostEntry)
Result = Space(256)
CopyMemory ByVal Result, ByVal HostEntry.hName, 256
Result = Left(Result, InStr(Result, vbNullChar) - 1)
GetFullHostNameFromHostName = Result
End If
End If
End Function
Public Function GetIPAddressFromHostName( _
ByVal HostName As String _
) As Long
' Return the IP address from a host name as a long.
Dim HostEntry As HOSTENT
Dim HostEntryPtr As Long
Dim IPAddressesPtr As Long
Dim Result As Long
If InitializeSockets Then
HostEntryPtr = gethostbyname(HostName & vbNullChar)
If HostEntryPtr > 0 Then
CopyMemory HostEntry, ByVal HostEntryPtr, Len(HostEntry)
CopyMemory IPAddressesPtr, ByVal HostEntry.hAddrList, 4
CopyMemory Result, ByVal IPAddressesPtr, 4
GetIPAddressFromHostName = Result
End If
End If
End Function
Public Function GetIPAddressFromString( _
ByVal IPAddress As String _
) As Long
' Return the long form of the string IP address.
Dim Octets As Variant
Dim HexString As String
Dim Index As Long
Octets = Split(IPAddress, ".")
If UBound(Octets) <> 3 Then Exit Function
For Index = 0 To 3
If Not IsNumeric(Octets(Index)) Then Exit Function
Next Index
GetIPAddressFromString = CLng("&H" & _
Right("0" & Hex(Octets(0)), 2) _
& Right("0" & Hex(Octets(1)), 2) _
& Right("0" & Hex(Octets(2)), 2) _
& Right("0" & Hex(Octets(3)), 2))
End Function
Public Function GetNormalizedIPAddress( _
ByVal Text As String, _
Optional ByVal ZeroPadOctets As Long = 0 _
) As String
' Convert text to IP address. Text can be any value or an eight character
' hexidecimal number. Examples:
'
' 0 -> 0.0.0.0
' 255.10 -> 255.10.0.0
' FFFE0001 -> 255.254.0.1
' 258.-1.0.0 -> 255.0.0.0
'
' Use the parameter ZeroPadOctets to pad each octet with zeroes. Pass a
' positive integer from 1 to 4 to pad that number of octets starting from
' the left. Pass a negative integer from -1 to -4 to pad that number of
' octets starting from the right.
Dim Nodes As Variant
Dim Index As Long
Dim Result As String
If Len(Text) > 0 Then
Nodes = Split(Text, ".")
If UBound(Nodes) = 0 And Len(Nodes(0)) = 8 Then
ReDim Nodes(0 To 3)
For Index = 0 To 3
Nodes(Index) = CStr(CLng("&H" & Mid(Text, Index * 2 + 1, 2)))
Next Index
End If
For Index = 0 To UBound(Nodes)
If Not IsNumeric(Nodes(Index)) Then Nodes(Index) = 0
Nodes(Index) = Application.Max(0, Application.Min(255, Nodes(Index)))
Next Index
Result = Join(Nodes, ".") & Left(".0.0.0", 6 - UBound(Nodes) * 2)
Nodes = Split(Result, ".")
If ZeroPadOctets > 0 Then
For Index = 0 To 3
If Index + 1 <= ZeroPadOctets Then Nodes(Index) = Right("00" & Nodes(Index), 3)
Next Index
Else
For Index = 0 To 3
If 4 - Index <= -ZeroPadOctets Then Nodes(Index) = Right("00" & Nodes(Index), 3)
Next Index
End If
GetNormalizedIPAddress = Join(Nodes, ".")
End If
End Function
Public Function GetStringFromIPAddress( _
ByVal IPAddress As Long _
) As String
' Return the string form of the IP address.
Dim IPAddressString As String
Dim Index As Long
IPAddressString = Space(4)
CopyMemory ByVal IPAddressString, IPAddress, 4
GetStringFromIPAddress = _
Asc(Mid$(IPAddressString, 1, 1)) _
& "." _
& Asc(Mid$(IPAddressString, 2, 1)) _
& "." _
& Asc(Mid$(IPAddressString, 3, 1)) _
& "." _
& Asc(Mid$(IPAddressString, 4, 1))
End Function
Public Function InitializeSockets() As Boolean
' Initialize Windows sockets.
Dim WinSockData As WSADATA
InitializeSockets = WSAStartup(WS_VERSION_REQD, WinSockData) = 0
End Function
Public Function IsInternetConnectionDialUp() As Boolean
' Return True if a dial up Internet connection is active, False otherwise.
Dim Result As Boolean
Dim Flags As Long
Result = InternetGetConnectedState(Flags, 0&)
If (Flags And INTERNET_CONNECTION_MODEM) > 0 Then
IsInternetConnectionDialUp = True
End If
End Function
Public Function IsInternetConnectionLAN() As Boolean
' Return True if a LAN Internet connection is active, False otherwise.
Dim Result As Boolean
Dim Flags As Long
Result = InternetGetConnectedState(Flags, 0&)
If (Flags And INTERNET_CONNECTION_LAN) > 0 Then
IsInternetConnectionLAN = True
End If
End Function
Public Function IsInternetConnectionOnline() As Boolean
' Return True is an Internet connection is available, False otherwise.
Dim Result As Boolean
Dim Flags As Long
Result = InternetGetConnectedState(Flags, 0&)
If Result Then
IsInternetConnectionOnline = True
End If
End Function
Public Function IsServerAvailable( _
ByVal Path As String _
) As Boolean
' Return true if the server or path is available, False otherwise. If the
' server is not local and is not available the response time can be five
' to ten seconds.
On Error Resume Next
ChDir Path
IsServerAvailable = Err <> 76
End Function
Public Function Ping( _
ByVal Target As Variant, _
Optional ByVal Data As String = " " _
) As tPingError
' Ping the target and return the round trip time in milliseconds or a negative
' value describing the failure. Target can be a host name, string IP address,
' or long IP address.
Dim IPAddress As Long
Dim Port As Long
Dim EchoReply As ICMP_ECHO_REPLY
Select Case VarType(Target)
Case vbLong
IPAddress = Target
Case vbString
IPAddress = GetIPAddressFromString(Target)
If IPAddress = 0 Then
IPAddress = GetIPAddressFromHostName(Target)
If IPAddress = 0 Then
Ping = PingError_InvalidTarget
Exit Function
End If
End If
Case Else
Stop ' Target must be a string or a long
End Select
' Initialize Windows sockets
If Not InitializeSockets Then
Ping = PingError_Other
Exit Function
End If
' Open a port
Port = IcmpCreateFile()
If Port = 0 Then
TerminateSockets
Ping = PingError_Other
Exit Function
End If
' Ping the IP adddress
IcmpSendEcho Port, IPAddress, Data, Len(Data), 0, EchoReply, Len(EchoReply), PING_TIMEOUT
' Evaluate ping response
If EchoReply.status = IP_REQ_TIMED_OUT Then
Ping = PingError_Timeout
ElseIf EchoReply.status <> 0 Then
Ping = PingError_Other
Else
Ping = EchoReply.RoundTripTime
End If
' Cleanup
IcmpCloseHandle Port
TerminateSockets
End Function
Public Sub TerminateSockets()
' Terminate Windows sockets.
WSACleanup
End Sub