Получение локального и внешнего IP-адресов

Option Explicit
'On Error Resume Next
 
Dim sIP
 
Sub XMLRequest(sQuery, objRemXML)
    Set objRemXML = CreateObject("Microsoft.XMLDOM")
    objRemXML.async = False
    objRemXML.Load (sQuery)
End Sub
 
 
Sub XMLParse(objRemXML, sNode, sRet)
    Dim objXMLret
    Set objXMLret = objRemXML.SelectSingleNode(sNode)
    If Err.Number <> 0 Then
        'MsgBox "Error of IPRange"
      Else
        If Not objXMLret Is Nothing Then sRet = objXMLret.Text
    End If
End Sub
 
 
Sub GetMyIP(sIP)
    Dim sQuery, objRemXML
 
    sQuery = "http://ip2country.sourceforge.net/ip2c.php?format=XML"
    Call XMLRequest(sQuery, objRemXML)
 
    'Get your IP-address
    Call XMLParse(objRemXML, "/lookup/ip", sIP)
    
    'if Sourceforge is Down
    If Len(sIP) = 0 Then
        Set objRemXML = Nothing
        
        sQuery = "http://wtfismyip.com/xml"
        Call XMLRequest(sQuery, objRemXML)
        
        Call XMLParse(objRemXML, "/wtf/your-fucking-ip-address", sIP) ':)
    End If
    
    Set objRemXML = Nothing
End Sub
 
'Here we go
Call GetMyIP(sIP)
 
WScript.Echo sIP

Option Explicit
 
Private Const STD_OUTPUT_HANDLE = -11&
Private Const STD_ERROR_HANDLE = -12&
 
Private Declare Function GetIpAddrTable Lib "IpHlpApi.dll" (pIPAddrTable As Any, pdwSize As Long, ByVal bOrder As Long) As Long
Private Declare Function StdOut Lib "kernel32" Alias "GetStdHandle" (Optional ByVal HandleType As Long = STD_OUTPUT_HANDLE) As Long
Private Declare Function StdErr Lib "kernel32" Alias "GetStdHandle" (Optional ByVal HandleType As Long = STD_ERROR_HANDLE) As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long)
 
Private cOut As Long
Private cErr As Long
 
Private Sub Main()
    Dim sExternalIP As String
 
    cOut = StdOut()
    cErr = StdErr()
 
    sExternalIP = GetExternalIp()
    
    If Len(sExternalIP) Then WriteC sExternalIP, cOut
    
    FreeConsole
    ExitProcess IIf(Len(sExternalIP), 0, 1)
End Sub
 
Private Function GetExternalIp() As String
    Dim buf(0 To 511) As Byte
    Dim BufSize As Long
    Dim rc As Long
    Dim NrOfEntries As Long
    Dim i As Long
    Dim j As Long
    Dim s As String
   
    BufSize = UBound(buf) + 1
    rc = GetIpAddrTable(buf(0), BufSize, 1)
   
    If rc <> 0 Then WriteC "GetIpAddrTable failed with return value: " & rc, cErr: Exit Function
   
    NrOfEntries = buf(1) * 256& + buf(0)
    If NrOfEntries = 0 Then Exit Function
   
    ReDim IpAddrs(0 To NrOfEntries - 1) As String
   
    For i = 0 To NrOfEntries - 1
        s = ""
        For j = 0 To 3
            s = s & IIf(j > 0, ".", "") & buf(4 + i * 24 + j)
        Next
        IpAddrs(i) = s
    Next
       
    For i = 0 To UBound(IpAddrs)
        If IpAddrs(i) <> "127.0.0.1" And Not isLocalIP(IpAddrs(i)) Then
            GetExternalIp = IpAddrs(i)
        End If
    Next
End Function
 
Private Function isLocalIP(sIP As String)  'rfc1918
    On Error GoTo ErrorHandler
    '10.0.0.0        -   10.255.255.255  (10/8 prefix)
    '172.16.0.0      -   172.31.255.255  (172.16/12 prefix)
    '192.168.0.0     -   192.168.255.255 (192.168/16 prefix)
 
    If StrBeginWith(sIP, "192.168.") Then
        isLocalIP = True
    ElseIf StrBeginWith(sIP, "10.") Then
        isLocalIP = True
    ElseIf StrBeginWith(sIP, "172.") Then
        Dim oct() As String
        oct = Split(sIP, ".")
        If UBound(oct) > 0 Then
            If CLng(oct(1)) >= 16 And CLng(oct(1)) <= 31 Then
                isLocalIP = True
            End If
        End If
    End If
    Exit Function
ErrorHandler:
    WriteC "Error in isLocalIP: " & Err.Number & " - " & Err.Description, cErr
End Function
 
Public Function StrBeginWith(Text As String, BeginPart As String) As Boolean
    StrBeginWith = (StrComp(Left$(Text, Len(BeginPart)), BeginPart, 1) = 0)
End Function
 
Private Sub WriteC(ByVal txt As String, Optional ByVal cHandle As Long)
    Dim dwWritten As Long
    txt = txt & vbNewLine
    WriteFile IIf(cHandle = 0, cOut, cHandle), StrPtr(StrConv(txt, vbFromUnicode)), Len(txt), dwWritten, 0&
    If cHandle = cErr Then Debug.Print txt
End Sub