【VB.NET】利用纯真IP数据库查询IP地址及信息_.NET_编程开发_程序员俱乐部

几年前从某个博客抄来的，已经忘记原地址了，如果需要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)