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