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