首页  编辑  

获取网站的IP地址

Tags: /计算机文档/Office/   Date Created:

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