VB调用纯真IP QQWry 地区信息

' ============================================
' 变量声名
' ============================================
Public Country As String, LocalStr As String, Buf As String, OffSet
Private StartIP As Single, EndIP As Single, CountryFlag As Single
Public QQWryFile As String
Public FirstStartIP As Single, LastStartIP As Single, RecordCount As Long
Private Stream As Object, EndIPOff As Single
' ============================================
' 类模块初始化
' ============================================
Private Sub Class_Initialize()
    On Error Resume Next
    Country = ""
    LocalStr = ""
    StartIP = 0
    EndIP = 0
    CountryFlag = 0
    FirstStartIP = 0
    LastStartIP = 0
    EndIPOff = 0
    QQWryFile = App.Path & "\QQWry.Dat" 'QQ IP库路径
End Sub
' ============================================
' IP地址转换成整数
' ============================================
Function Iptoint(IP) As Single
    Dim IPArray, I, Iptoint1 As Single, Iptoint2 As Single, Iptoint3 As Single, Iptoint4 As Single
    IPArray = Split(IP, ".", -1)
    For I = 0 To 3
        If Not IsNumeric(IPArray(I)) Then IPArray(I) = 0
        If CInt(IPArray(I)) < 0 Then IPArray(I) = Abs(CInt(IPArray(I)))
        If CInt(IPArray(I)) > 255 Then IPArray(I) = 255
    Next
   Iptoint = CInt(IPArray(3)) + CLng(IPArray(2) * 256) + CLng(IPArray(1) * 256 * 256) + CSng(IPArray(0) * 256 * 256 * 256)
End Function
' ============================================
' 整数逆转IP地址
' ============================================
Function IntToIP(IntValue) As String
Dim p1 As Single, p2 As Single, p3 As Single, p4 As Single
    p4 = IntValue - Fix(IntValue / 256) * 256  'd段
    IntValue = (IntValue - p4) / 256
    p3 = IntValue - Fix(IntValue / 256) * 256  'c段
    IntValue = (IntValue - p3) / 256
    p2 = IntValue - Fix(IntValue / 256) * 256  'b段
    IntValue = (IntValue - p2) / 256
    p1 = IntValue 'a段
    IntToIP = CStr(p1) & "." & CStr(p2) & "." & CStr(p3) & "." & CStr(p4)
End Function
' ============================================
' 获取开始IP位置
' ============================================
Private Function GetStartIP(RecNo) As Single
Dim fa(3) As Single, la(3) As Single
    OffSet = FirstStartIP + RecNo * 7
    Stream.Position = OffSet
    Buf = Stream.Read(7)
           
    fa(0) = AscB(MidB(Buf, 1, 1))
    fa(1) = AscB(MidB(Buf, 2, 1)): fa(1) = fa(1) * 256
    fa(2) = AscB(MidB(Buf, 3, 1)): fa(2) = fa(2) * 256: fa(2) = fa(2) * 256
    fa(3) = AscB(MidB(Buf, 4, 1)): fa(3) = fa(3) * 256: fa(3) = fa(3) * 256: fa(3) = fa(3) * 256
    StartIP = fa(0) + fa(1) + fa(2) + fa(3)
   
   
    la(0) = AscB(MidB(Buf, 5, 1))
    la(1) = AscB(MidB(Buf, 6, 1)): la(1) = la(1) * 256
    la(2) = AscB(MidB(Buf, 7, 1)): la(2) = la(2) * 256: la(2) = la(2) * 256
    EndIPOff = la(0) + la(1) + la(2)
    GetStartIP = StartIP
End Function
' ============================================
' 获取结束IP位置
' ============================================
Private Function GetEndIP() As Single
Dim fa(3) As Single
    Stream.Position = EndIPOff
    Buf = Stream.Read(5)
    fa(0) = AscB(MidB(Buf, 1, 1))
    fa(1) = AscB(MidB(Buf, 2, 1))
    fa(2) = AscB(MidB(Buf, 3, 1))
    fa(3) = AscB(MidB(Buf, 4, 1))
    EndIP = fa(0) + CLng(fa(1) * 256) + CLng(fa(2) * 256 * 256) + _
    CSng(fa(3) * 256 * 256 * 256)
   
    CountryFlag = AscB(MidB(Buf, 5, 1))
    GetEndIP = EndIP
End Function
' ============================================
' 获取地域信息，包含国家和和省市
' ============================================
Private Sub GetCountry(IP)
    If (CountryFlag = 1 Or CountryFlag = 2) Then
        Country = GetFlagStr(EndIPOff + 4)
        If CountryFlag = 1 Then
            LocalStr = GetFlagStr(Stream.Position)
            ' 以下用来获取数据库版本信息
            If IP >= Iptoint("255.255.255.0") And IP <= Iptoint("255.255.255.255") Then
                LocalStr = GetFlagStr(EndIPOff + 21)
                Country = GetFlagStr(EndIPOff + 12)
            End If
        Else
            LocalStr = GetFlagStr(EndIPOff + 8)
        End If
    Else
        Country = GetFlagStr(EndIPOff + 4)
        LocalStr = GetFlagStr(Stream.Position)
    End If
    ' 过滤数据库中的无用信息
    Country = Trim(Country)
    LocalStr = Trim(LocalStr)
    If InStr(Country, "CZ88.NET") Then Country = "未知"
    If InStr(LocalStr, "CZ88.NET") Then LocalStr = "未知"
End Sub
' ============================================
' 获取IP地址标识符
' ============================================
Private Function GetFlagStr(OffSet) As String
    Dim Flag As Integer, f(2) As Single
    Flag = 0
    Do While (True)
        Stream.Position = OffSet
        Flag = AscB(Stream.Read(1))
        If (Flag = 1 Or Flag = 2) Then
            Buf = Stream.Read(3)
            If (Flag = 2) Then
                CountryFlag = 2
                EndIPOff = OffSet - 4
            End If
            f(0) = AscB(MidB(Buf, 1, 1))
            f(1) = AscB(MidB(Buf, 2, 1)): f(1) = f(1) * 256
            f(2) = AscB(MidB(Buf, 3, 1)): f(2) = f(2) * 256: f(2) = f(2) * 256
            OffSet = f(0) + f(1) + f(2)
            Else
            Exit Do
        End If
    Loop
   
    If (OffSet < 12) Then
        GetFlagStr = ""
    Else
        Stream.Position = OffSet
        GetFlagStr = GetStr()
    End If
End Function
' ============================================
' 获取字串信息
' ============================================
Private Function GetStr() As String
    Dim c As Integer
    GetStr = ""
    Do While (True)
        c = AscB(Stream.Read(1))
        If (c = 0) Then Exit Do
       
        '如果是双字节，就进行高字节在结合低字节合成一个字符
        If c > 127 Then
            If Stream.EOS Then Exit Do
            GetStr = GetStr & Chr(AscW(ChrB(AscB(Stream.Read(1))) & ChrB(c)))
        Else
            GetStr = GetStr & Chr(c)
        End If
    Loop
End Function
' ============================================
' 核心函数，执行IP搜索
' ============================================
Public Function QQWry(DotIP) As Integer
 On Error GoTo hrr
    Dim IP As Single, nRet As Integer
    Dim RangB As Long, RangE As Long, RecNo As Long
    Dim fa(3) As Long, la(3) As Long
    IP = Iptoint(DotIP)
   
    Set Stream = CreateObject("Adodb.Stream")
    Stream.Mode = 3
    Stream.Type = 1
    Stream.Open
    Stream.LoadFromFile QQWryFile
    Stream.Position = 0
    Buf = Stream.Read(8)
    fa(0) = AscB(MidB(Buf, 1, 1))
    fa(1) = AscB(MidB(Buf, 2, 1))
    fa(2) = AscB(MidB(Buf, 3, 1))
    fa(3) = AscB(MidB(Buf, 4, 1))
   
    FirstStartIP = fa(0) + CLng(fa(1) * 256) + CLng(fa(2) * 256 * 256) + _
    CSng(fa(3) * 256 * 256 * 256)
   
    la(0) = AscB(MidB(Buf, 5, 1))
    la(1) = AscB(MidB(Buf, 6, 1))
    la(2) = AscB(MidB(Buf, 7, 1))
    la(3) = AscB(MidB(Buf, 8, 1))
   
    LastStartIP = la(0) + CLng(la(1) * 256) + CLng(la(2) * 256 * 256) + _
    CSng(la(3) * 256 * 256 * 256)
  
 
    RecordCount = Int((LastStartIP - FirstStartIP) / 7)
    ' 在数据库中找不到任何IP地址
    If (RecordCount <= 1) Then
        Country = "未知"
        QQWry = 2
        Exit Function
    End If
   
    RangB = 0
    RangE = RecordCount
   
    Do While (RangB < (RangE - 1))
        RecNo = Int((RangB + RangE) / 2)
        Call GetStartIP(RecNo)
        If (IP = StartIP) Then
            RangB = RecNo
            Exit Do
        End If
        If (IP > StartIP) Then
            RangB = RecNo
        Else
            RangE = RecNo
        End If
    Loop
   
    Call GetStartIP(RangB)
    Call GetEndIP

    If (StartIP <= IP) And (EndIP >= IP) Then
        ' 没有找到
        nRet = 0
    Else
        ' 正常
        nRet = 3
    End If
    Call GetCountry(IP)

    QQWry = nRet
   
hrr:
End Function
  ' ============================================
  ' 检查IP地址合法性
  ' ============================================
Public Function IsIp(IP) As Boolean
  Dim varparts
  varparts = Split(IP, ".")
  If UBound(varparts) <> 3 Then
  IsIp = False
  Exit Function
  End If
  For I = 0 To 3
      If Val(varparts(I)) > 255 Or Val(varparts(I)) < 0 Then
      IsIp = False
      Exit Function
      Else
      IsIp = True
      End If
  Next I
End Function

Private Sub Class_Terminate()
    On Error Resume Next
    Stream.Close
    If Err Then Err.Clear
    Set Stream = Nothing
End Sub

'以下测试把IP转换成城市地区：
Private Sub Form_Load()
    Dim IP As New QQWry
    Call IP.QQWry("116.28.255.11")
    MsgBox IP.Country & " " & IP.LocalStr
End Sub