ipcls.cls

此小程序可以根据IP地址

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "IPCLS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

    ' ============================================
    ' 变量声名
    ' ============================================
    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
        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
    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