幾年前從某個博客抄來的，已經忘記原地址了，如果需要C#版的，可以在博客園搜到吧。
我因為自己用，所以轉換為了VBNET代碼，而且也放置了很久，今天無意間翻出來，就分享給大家吧。

首先，先下載 純真數據庫，名稱應該是 QQWry.dat 。
之後將數據庫文件復制到程序的主目錄即可。

Imports System.IO
Imports System.Text
Imports System.Text.RegularExpressions
Imports System.Net
Imports System.Net.Sockets


‘‘‘ <summary>IP地址查詢
 
</summary>
Public NotInheritable Class IPQuery


    ‘‘‘ <summary>IP地址描述</summary>
    Public Structure IPLocation
        Sub New(ByVal i As String, ByVal c As String, ByVal l As String)
            IP = i
            Country = c
            Local = l
        End Sub
        ‘‘‘
 
 <summary>IP地址</summary>
        Dim IP As String
        ‘‘‘ <summary>地域\國家\機構</summary>
        Dim Country As String
        ‘‘‘ <summary>地域描述</summary>
        Dim Local As String


        ‘‘‘ <summary>返回完整名稱</summary>
        Overloads Function
 
 ToString() As String
            Return Me.Country & Me.Local
        End Function
        ‘‘‘ <param name="ls">連接字符</param>
        Overloads Function ToString(ByVal ls As String) As String
            Return Me.Country & ls & Me.Local
        End Function

        ‘ 強制轉換
        Public Shared Widening Operator CType(ByVal o As IPLocation) As String
            Return o.ToString
        End Operator

    End Structure


    Shared encoding As Encoding = encoding.GetEncoding("GB2312")

    Shared ipCount As Integer
    Shared fsinoffiset As Integer
    Shared lsinoffiset As Integer
    Shared data As Byte()
    ‘ 加強線程訪問安全
    Shared rwl As New Threading.ReaderWriterLock

    ‘‘‘ <summary>刷新IP數據庫</summary>
    Shared Sub ReIPData(ByVal dataPath As String)
        rwl.AcquireWriterLock(-1) ‘設置寫權限，禁止讀權限

        ‘ 嘗試回收內存中的數據庫
        If data IsNot Nothing Then
            data = Nothing
            GC.Collect()
        End If
        ‘ 讀取數據
        data = IO.File.ReadAllBytes(dataPath)
        fsinoffiset = CInt(data(0)) + (CInt(data(1)) << 8) + (CInt(data(2)) << 16) + (CInt(data(3)) << 24)
        lsinoffiset = CInt(data(4)) + (CInt(data(5)) << 8) + (CInt(data(6)) << 16) + (CInt(data(7)) << 24)
        ipCount = (lsinoffiset - fsinoffiset) / 7 + 1

        rwl.ReleaseWriterLock()

        If ipCount <= 1 Then Throw New ApplicationException("提供的IP數據錯誤！")
    End Sub

    Shared Sub New()
        ‘ TODO 替換為自己的數據庫地址
        ReIPData(Application.StartupPath & "\QQWry.dat")
    End Sub

    ‘‘‘ <summary>返回數據庫中IP紀錄總數</summary>
    Shared ReadOnly Property Count() As Integer
        Get
            Return ipCount
        End Get
    End Property

    ‘‘‘ <summary>查詢一組IP地址</summary>
    Shared Function QueryAll(ByVal ParamArray ips As String()) As IPLocation()
        If ips Is Nothing OrElse ips.Length = 0 Then Return Nothing

        Dim ipls(ips.Length - 1) As IPLocation
        For i As Integer = 0 To ips.Length - 1
            ipls(i) = Query(ips(i))
        Next
        Return ipls
    End Function

    ‘‘‘ <summary>查詢IP地址</summary>
    Shared Function Query(ByVal ip As String) As IPLocation

        rwl.AcquireReaderLock(-1) ‘設置讀權限

        Dim ads As IPAddress = IPAddress.Parse(ip)
        If ads.AddressFamily <> AddressFamily.InterNetwork Then Throw New ArgumentException("不支持非IPV4協議")
        If IPAddress.IsLoopback(ads) Then
            rwl.ReleaseReaderLock()
            Return New IPLocation(ip, "本機或保留地址", "")
        End If

        ‘Dim intIp As UInteger = CUInt(IPAddress.HostToNetworkOrder(CInt(ads.Address)))
        Dim intIp As UInteger = m_ip2uint(ads.ToString)

        Dim iplon As IPLocation : iplon.IP = ip

        Dim right As UInteger = ipCount
        Dim left, middle, startIp, endIpOff, endIp As UInteger
        Dim countryFlag As Integer = 0

        While left < (right - 1)
            middle = (right + left) / 2
            startIp = GetStartIp(middle, endIpOff)
            If intIp = startIp Then
                left = middle
                Exit While
            End If
            If intIp > startIp Then
                left = middle
            Else
                right = middle
            End If
        End While

        startIp = GetStartIp(left, endIpOff)
        endIp = GetEndIp(endIpOff, countryFlag)
        If startIp <= intIp And endIp >= intIp Then
            Dim local As String = ""
            iplon.Country = GetCountry(endIpOff, countryFlag, local)
            If local = " CZ88.NET" Then local = "" ‘優化 用於去除部分IP地址返回的廣告數據
            iplon.Local = local
        Else
            iplon.Country = "未知地區"
            iplon.Local = "" ‘"火星網友"
        End If

        rwl.ReleaseReaderLock()

        Return iplon
    End Function

    Private Shared Function GetStartIp(ByVal left As UInteger, ByRef endIpOff As UInteger) As UInteger
        Dim leftOffset As Integer = CInt(fsinoffiset + (left * 7))
        endIpOff = CUInt(data(leftOffset + 4)) + (CUInt(data(leftOffset + 5)) << 8) + (CUInt(data(leftOffset + 6)) << 16)
        Return CUInt(data(leftOffset)) + (CUInt(data(leftOffset + 1)) << 8) + (CUInt(data(leftOffset + 2)) << 16) + (CUInt(data(leftOffset + 3)) << 24)
    End Function
    Private Shared Function GetEndIp(ByVal endIpOff As UInteger, ByRef countryFlag As Integer) As UInteger
        countryFlag = data(endIpOff + 4)
        Return CUInt(data(endIpOff)) + (CUInt(data(endIpOff + 1)) << 8) + (CUInt(data(endIpOff + 2)) << 16) + (CUInt(data(endIpOff + 3)) << 24)
    End Function

    Private Shared Function GetCountry(ByVal endIpOff As UInteger, ByVal countryFlag As Integer, ByRef local As String) As String
        Dim country As String = ""
        Dim offset As UInteger = endIpOff + 4
        Select Case countryFlag
            Case 1, 2
                country = GetFlagStr(offset, countryFlag, endIpOff)
                offset = endIpOff + 8
                local = IIf(countryFlag = 1, "", GetFlagStr(offset, countryFlag, endIpOff))
            Case Else
                country = GetFlagStr(offset, countryFlag, endIpOff)
                local = GetFlagStr(offset, countryFlag, endIpOff)
        End Select
        Return country
    End Function

    Private Shared Function GetFlagStr(ByRef offset As UInteger, ByRef countryFlag As Integer, ByRef endIpOff As UInteger) As String
        Dim flag As Integer = 0
        Do

            flag = data(offset)
            If flag <> 1 And flag <> 2 Then Exit Do
            If flag = 2 Then
                countryFlag = 2
                endIpOff = offset - 4
            End If
            offset = CUInt(data(offset + 1)) + (CUInt(data(offset + 2)) << 8) + (CUInt(data(offset + 3)) << 16)
        Loop
        If offset < 12 Then Return ""
        Return GetStr(offset)
    End Function

    Private Shared Function GetStr(ByRef offset As UInteger) As String
        Dim lowByte As Byte = 0, highByte As Byte = 0
        Dim sb As New StringBuilder(16)
        Do
            lowByte = data(offset) : offset += 1
            If lowByte = 0 Then Return sb.ToString
            If lowByte > &H7F Then
                highByte = data(offset) : offset += 1
                If highByte = 0 Then Return sb.ToString
                sb.Append(encoding.GetString(New Byte() {lowByte, highByte}))
            Else
                sb.Append(ChrW(lowByte))
            End If
        Loop
    End Function

    ‘‘‘ <summary>將ip地址轉換為uint</summary>
    Private Shared Function m_ip2uint(ByVal ip As String) As UInteger
        Dim bs As Byte() = IPAddress.Parse(ip).GetAddressBytes
        Return CUInt(bs(3)) + (CUInt(bs(2)) << 8) + (CUInt(bs(1)) << 16) + (CUInt(bs(0)) << 24)
    End Function

End Class

如果你要設置自定義的數據庫位置，記得修改 Shared Sub New 這個方法，或者幹脆刪除它，自己調用 ReIPData 來設置數據庫的地址。

使用方法很簡單，如下：

Dim iploca = IPQuery.Query("127.0.0.1")
Dim ipdesc = String.Format("IP {0} 的詳細地址為: {1} - {2}", iploca.IP, iploca.Country, iploca.Local)

【VB.NET】利用純真IP數據庫查詢IP地址及信息