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(3As Single, la(3As Single
    OffSet 
= FirstStartIP + RecNo * 7
    Stream.Position 
= OffSet
    Buf 
= Stream.Read(7)
           
    fa(
0= AscB(MidB(Buf, 11))
    fa(
1= AscB(MidB(Buf, 21)): fa(1= fa(1* 256
    fa(
2= AscB(MidB(Buf, 31)): fa(2= fa(2* 256: fa(2= fa(2* 256
    fa(
3= AscB(MidB(Buf, 41)): 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, 51))
    la(
1= AscB(MidB(Buf, 61)): la(1= la(1* 256
    la(
2= AscB(MidB(Buf, 71)): 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(3As Single
    Stream.Position 
= EndIPOff
    Buf 
= Stream.Read(5)
    fa(
0= AscB(MidB(Buf, 11))
    fa(
1= AscB(MidB(Buf, 21))
    fa(
2= AscB(MidB(Buf, 31))
    fa(
3= AscB(MidB(Buf, 41))
    EndIP 
= fa(0+ CLng(fa(1* 256+ CLng(fa(2* 256 * 256+ _
    
CSng(fa(3* 256 * 256 * 256)
   
    CountryFlag 
= AscB(MidB(Buf, 51))
    GetEndIP 
= EndIP
End Function
' ============================================
'
 获取地域信息,包含国家和和省市
'
 ============================================
Private Sub GetCountry(IP)
    
If (CountryFlag = 1 Or CountryFlag = 2Then
        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(2As Single
    Flag 
= 0
    
Do While (True)
        Stream.Position 
= OffSet
        Flag 
= AscB(Stream.Read(1))
        
If (Flag = 1 Or Flag = 2Then
            Buf 
= Stream.Read(3)
            
If (Flag = 2Then
                CountryFlag 
= 2
                EndIPOff 
= OffSet - 4
            
End If
            f(
0= AscB(MidB(Buf, 11))
            f(
1= AscB(MidB(Buf, 21)): f(1= f(1* 256
            f(
2= AscB(MidB(Buf, 31)): 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 < 12Then
        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 = 0Then 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(3As Long, la(3As 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, 11))
    fa(
1= AscB(MidB(Buf, 21))
    fa(
2= AscB(MidB(Buf, 31))
    fa(
3= AscB(MidB(Buf, 41))
   
    FirstStartIP 
= fa(0+ CLng(fa(1* 256+ CLng(fa(2* 256 * 256+ _
    
CSng(fa(3* 256 * 256 * 256)
   
    la(
0= AscB(MidB(Buf, 51))
    la(
1= AscB(MidB(Buf, 61))
    la(
2= AscB(MidB(Buf, 71))
    la(
3= AscB(MidB(Buf, 81))
   
    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 <= 1Then
        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

 

 

 

posted @ 2010-06-30 11:17  遥望星空  阅读(829)  评论(0编辑  收藏  举报