VB 一个获得自己外网 IP 地址的程序代码

Option Explicit

'一个获得自己外网 IP 地址的程序代码。

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3

Private Const scUserAgent = "Microsoft Internet Explorer 6.0"
Private Const INTERNET_FLAG_RELOAD = &H80000000

Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Public Function GetWebSoundCode(ByVal URL As String) As String
    Dim hOpen                 As Long
    Dim hOpenUrl              As Long
    Dim bDoLoop               As Boolean
    Dim bRet                  As Boolean
    Dim sReadBuffer           As String * 2048
    Dim lNumberOfBytesRead    As Long
    Dim sBuffer               As String

    '调用时 URL 参数一定要带“http://”前缀.
    If Left$(LCase$(URL), 7) <> "http://" Then URL = "http://" & URL

    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    hOpenUrl = InternetOpenUrl(hOpen, URL, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)

    bDoLoop = True
    While bDoLoop
        sReadBuffer = vbNullString
        bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
        sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
        If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
    Wend

    GetWebSoundCode = sBuffer

    If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
End Function

Public Function GetIP1() As String
    On Error GoTo SoErr
    Dim strSoundCode As String, intStrCount As Integer

    strSoundCode = GetWebSoundCode("http://web.sunsen.net/")

    '没有获取源码跳出函数。
    If Len(strSoundCode) < 10 Then Exit Function

    '获取 IP 地址。
    GetIP1 = Mid$(strSoundCode, InStr(strSoundCode, "您现在的IP是:") + 8)
    GetIP1 = Mid$(GetIP1, 1, InStr(GetIP1, "<") - 1)

    '获取地理位置。
    strSoundCode = Mid$(strSoundCode, InStr(strSoundCode, "欢迎来自") + 4)
    strSoundCode = Mid$(strSoundCode, 1, InStr(strSoundCode, "的朋友") - 1)

    GetIP1 = GetIP1 & strSoundCode

    intStrCount = lstrlen(GetIP1)

    If intStrCount < 32 Then
        GetIP1 = GetIP1 & String$(32 - intStrCount, Chr$(32))
    Else
        For intStrCount = 1 To intStrCount
            If lstrlen(GetIP1) < 33 Then Exit For
            GetIP1 = Mid$(GetIP1, 1, Len(GetIP1) - 1)
        Next
    End If
    Exit Function
SoErr:
    'MsgBox "程序运行时发生错误，错误信息如下：" & vbCrLf & _
        "=========================================" & vbCrLf & _
        "错误号：" & Err.Number & vbCrLf & _
        "错误描述：" & Err.Description & vbCrLf & _
        "错误源：" & Err.Source & vbCrLf & _
        "变量 GetIP1 = " & GetIP1, , "GetIP1 中有错误发生！"
    GetIP1 = ""
    Exit Function
End Function

Public Function GetIP2() As String
    On Error GoTo SoErr
    Dim strSoundCode As String, strLineArray() As String, intStrCount As Integer

    '获取 IP 地址。
    strSoundCode = GetWebSoundCode("http://archive.apnic.net/templates/ipv6man/")
    strSoundCode = Mid$(strSoundCode, InStr(strSoundCode, Chr$(39)) + 1)
    GetIP2 = Mid$(strSoundCode, 1, InStr(strSoundCode, Chr$(39)) - 1)

    '确保获得的是一个 IP 地址。
    strLineArray = Split(GetIP2, Chr$(46))
    intStrCount = UBound(strLineArray)
    If intStrCount < 3 Then Err.Raise 666 '产生一个自定义错误号的错误。
    Erase strLineArray '释放数组所用内存。

    '获取地理位置。
    strSoundCode = GetWebSoundCode("http://submit.apnic.net/cgi-bin/jwhois.pl")
    strLineArray = Split(strSoundCode, vbCrLf)
    strSoundCode = ""
    For intStrCount = 0 To UBound(strLineArray)
        If InStr(1, strLineArray(intStrCount), "country:", vbTextCompare) > 0 Then
            strSoundCode = strLineArray(intStrCount)
            Exit For
        End If
    Next

    GetIP2 = GetIP2 & Chr$(9) & strSoundCode

    intStrCount = lstrlen(GetIP2)

    If intStrCount < 32 Then
        GetIP2 = GetIP2 & String$(32 - intStrCount, Chr$(32))
    Else
        For intStrCount = 1 To intStrCount
            If lstrlen(GetIP2) < 33 Then Exit For
            GetIP2 = Mid$(GetIP2, 1, Len(GetIP2) - 1)
        Next
    End If
    Exit Function
SoErr:
    'MsgBox "程序运行时发生错误，错误信息如下：" & vbCrLf & _
        "=========================================" & vbCrLf & _
        "错误号：" & Err.Number & vbCrLf & _
        "错误描述：" & Err.Description & vbCrLf & _
        "错误源：" & Err.Source & vbCrLf & _
        "变量 GetIP = " & GetIP2, , "GetIP2 中有错误发生！"
    GetIP2 = ""
    Exit Function
End Function

Public Function GetIP3() As String
    On Error GoTo SoErr
    Dim strSoundCode As String, strLineArray() As String, intStrCount As Integer

    '获取 IP 地址。
    GetIP3 = GetWebSoundCode("http://www.ip138.com/ip2city.asp")
    GetIP3 = Mid$(GetIP3, InStr(GetIP3, Chr$(91)) + 1)
    GetIP3 = Mid$(GetIP3, 1, InStr(GetIP3, Chr$(93)) - 1)

    '确保获得的是一个 IP 地址。
    strLineArray = Split(GetIP3, Chr$(46))
    intStrCount = UBound(strLineArray)
    If intStrCount < 3 Then Err.Raise 666 '产生一个自定义错误号的错误。

    GetIP3 = GetIP3 & Chr$(9) & strSoundCode

    intStrCount = lstrlen(GetIP3)

    If intStrCount < 32 Then
        GetIP3 = GetIP3 & String$(32 - intStrCount, Chr$(32))
    Else
        For intStrCount = 1 To intStrCount
            If lstrlen(GetIP3) < 33 Then Exit For
            GetIP3 = Mid$(GetIP3, 1, Len(GetIP3) - 1)
        Next
    End If
    Exit Function
SoErr:
    'MsgBox "程序运行时发生错误，错误信息如下：" & vbCrLf & _
        "=========================================" & vbCrLf & _
        "错误号：" & Err.Number & vbCrLf & _
        "错误描述：" & Err.Description & vbCrLf & _
        "错误源：" & Err.Source & vbCrLf & _
        "变量 GetIP = " & GetIP3, , "GetIP3 中有错误发生！"
    GetIP3 = ""
    Exit Function
End Function

Public Function GetIP4() As String
    On Error GoTo SoErr
    Dim strLineArray() As String, intStrCount As Integer

    '获取 IP 地址。
    GetIP4 = GetWebSoundCode("http://vbnet.mvps.org/resources/tools/getpublicip.shtml")
    GetIP4 = Mid$(GetIP4, InStr(GetIP4, Chr$(39)) + 1)
    GetIP4 = Mid$(GetIP4, 1, InStr(GetIP4, Chr$(39)) - 1)

    '确保获得的是一个 IP 地址。
    strLineArray = Split(GetIP4, Chr$(46))
    intStrCount = UBound(strLineArray)
    If intStrCount < 3 Then Err.Raise 666 '产生一个自定义错误号的错误。

    GetIP4 = GetIP4 & Chr$(9)

    intStrCount = lstrlen(GetIP4)

    If intStrCount < 32 Then
        GetIP4 = GetIP4 & String$(32 - intStrCount, Chr$(32))
    Else
        For intStrCount = 1 To intStrCount
            If lstrlen(GetIP4) < 33 Then Exit For
            GetIP4 = Mid$(GetIP4, 1, Len(GetIP4) - 1)
        Next
    End If
    Exit Function
SoErr:
    'MsgBox "程序运行时发生错误，错误信息如下：&#