miaozk2006

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 "³ÌÐòÔËÐÐʱ·¢Éú´íÎ󣬴íÎóÐÅÏ¢ÈçÏ£º" & vbCrLf & _
        "=========================================" & vbCrLf & _
        "´íÎóºÅ£º" & Err.Number & vbCrLf & _
        "´íÎóÃèÊö£º" & Err.Description & vbCrLf & _
        "´íÎóÔ´£º" & Err.Source & vbCrLf & _
        "±äÁ¿ GetIP = " & GetIP4, , "GetIP4 ÖÐÓдíÎó·¢Éú£¡"
    GetIP4 = ""
    Exit Function
End Function

'e.g:
Private Sub Command1_Click()
    Dim strIP As String
    strIP = GetIP1()
    If Len(strIP) < 11 Then strIP = "ÎÞ·¨µÃµ½ÍâÍøIPµØÖ·"
    Text1.Text = strIP
End Sub

Private Sub Command2_Click()
    Dim strIP As String
    strIP = GetIP2()
    If Len(strIP) < 11 Then strIP = "ÎÞ·¨µÃµ½ÍâÍøIPµØÖ·"
    Text2.Text = strIP
End Sub
Private Sub Command3_Click()
    Dim strIP As String
    strIP = GetIP3()
    If Len(strIP) < 11 Then strIP = "ÎÞ·¨µÃµ½ÍâÍøIPµØÖ·"
    Text3.Text = strIP
End Sub
Private Sub Command4_Click()
    Dim strIP As String
    strIP = GetIP4()
    If Len(strIP) < 11 Then strIP = "ÎÞ·¨µÃµ½ÍâÍøIPµØÖ·"
    Text4.Text = strIP
End Sub