【VB.NET】利用纯真IP数据库查询IP地址及信息

几年前从某个博客抄来的，已经忘记原地址了，如果需要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(-) '设置写权限，禁止读权限

        ' 尝试回收内存中的数据库
        If data IsNot Nothing Then
            data = Nothing
            GC.Collect()
        End If
        ' 读取数据
        data = IO.File.ReadAllBytes(dataPath)
        fsinoffiset = )) + ()) << ) + ()) << ) + ()) << )
        lsinoffiset = )) + ()) << ) + ()) << ) + ()) << )
        ipCount = (lsinoffiset - fsinoffiset) /  + 

        rwl.ReleaseWriterLock()

         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()
         Then Return Nothing

        ) As IPLocation

            ipls(i) = Query(ips(i))
        Next
        Return ipls
    End Function

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

        rwl.AcquireReaderLock(-) '设置读权限

        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

        )
            middle = (
            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
        ))
        endIpOff = CUInt(data(leftOffset + )) + (CUInt(data(leftOffset + )) << ) + (CUInt(data(leftOffset + )) << )
        )) << ) + (CUInt(data(leftOffset + )) << ) + (CUInt(data(leftOffset + )) << )
    End Function
    Private Shared Function GetEndIp(ByVal endIpOff As UInteger, ByRef countryFlag As Integer) As UInteger
        countryFlag = data(endIpOff + )
        )) << ) + (CUInt(data(endIpOff + )) << ) + (CUInt(data(endIpOff + )) << )
    End Function

    Private Shared Function GetCountry(ByVal endIpOff As UInteger, ByVal countryFlag As Integer, ByRef local As String) As String
        Dim country As String = ""

        Select Case countryFlag
            ,
                country = GetFlagStr(offset, countryFlag, endIpOff)
                offset = endIpOff +
                local = , "", 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

        Do

            flag = data(offset)
              Then Exit Do
             Then
                countryFlag =
                endIpOff = offset -
            End If
            offset = CUInt(data(offset + )) + (CUInt(data(offset + )) << ) + (CUInt(data(offset + )) << )
        Loop
         Then Return ""
        Return GetStr(offset)
    End Function

    Private Shared Function GetStr(ByRef offset As UInteger) As String
        , highByte
        )
        Do
            lowByte = data(offset) : offset +=
             Then Return sb.ToString
            If lowByte > &H7F Then
                highByte = data(offset) : offset +=
                 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
        )) + (CUInt(bs()) << ) + (CUInt(bs()) << ) + (CUInt(bs()) << )
    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)