如何提高纯真IP数据库（qqwry.dat）导出文本的速度

[renhuu]

本人是VB初学者，最近在尝试将网上流行的qqwry.dat数据库转为txt文本，手头有几份代码，其中delphi的速度非常快，三十多万条的数据可在两三秒钟之内导出完毕，VB的则非常慢，要一分多钟，相差太远了，问了不少人，都说VB代码执行效率低，没办法，我尝试在原代码基础上，改用先读入byte()数组，然后在内存中再进行处理的办法，最后的时间减少到二十多秒，虽比原来的时间有所缩短，但还是距delphi的差太远，在此，把我改写的完整的代码贴上，请各位VB高手帮帮忙，看看能不能进一步缩短时间，难道VB的速度真的差delphi太远吗。


由于提示代码过长，请下载附件源码察看

[renhuu]

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Sub Command1_Click()
Dim Fn As Integer '文件记录号
Dim StrFile As String '文件路径
Dim i As Double '循环记录
Dim IpBegin As Double '第一条索引
Dim IpEnd As Double '最后一条索引
Dim IpBeginArray(1 To 4) As Byte '第一条索引字节
Dim IpEndArray(1 To 4) As Byte '最后一条索引字节
Dim IpAllNum As Long '记录总数
Dim IpDataBegin As Double '起始Ip
Dim IpDataEnd As Double '结束Ip
Dim IpData1Array(1 To 4) As Byte '起始Ip地址数据
Dim IpData2Array(1 To 4) As Byte '结束Ip地址数据
Dim DataSeek As Double
Dim DataSeekArray(1 To 3) As Byte
Dim IpFlag As Byte '模式
Dim IpAddr1 As String '国家
Dim IpAddr2 As String '地区
Dim IpSeek As Double
Dim IpSeekArray(1 To 3) As Byte
Dim AddrSeek1 As Double '国家地址偏移
Dim AddrSeek1Array(1 To 3) As Byte '国家地址偏移数据
Dim AddrSeek2 As Double '地区地址偏移
Dim AddrSeek2Array(1 To 3) As Byte '地区地区偏移数据
Dim Temp(1024) As Byte '1k 字节空间
Dim Curr As Integer

Dim AllData() As Byte '读入内存的所有的资料
Dim MemNum As Long '内存中的位置,要设为长整数
Dim TempData() As String '解压后临时放入的数组
Dim IpString As String '最后生成的全部字符串

On Error GoTo Err_

StrFile = App.Path & "\qqwry.dat"
If Dir(StrFile) = "" Then MsgBox "当前目录下没qqwry.dat文件": End '检查QQWry.Dat文件是否存在

Fn = FreeFile

ReDim AllData(1 To FileLen(StrFile)) '重定义数组的数量
Open StrFile For Binary Access Read As #Fn '打开QQWRY.DAT文件

Get #Fn, , AllData()
CopyMemory IpBeginArray(1), AllData(1), 3
CopyMemory IpEndArray(1), AllData(5), 3
IpBegin = UnPack(IpBeginArray) '第一个索引
IpEnd = UnPack(IpEndArray) '最后一个索引

IpAllNum = CLng((IpEnd - IpBegin) / 7 + 1) '每组Ip段占7个字节 计算有多少组Ip段
m_Count = IpAllNum '返回给属性记录总数
ReDim TempData(0 To IpAllNum - 1) '重定义临时放解压后的文本字符串数组

[renhuu]

For i = 0 To IpAllNum - 1

If i > 0 Then IpBegin = IpBegin + 7 '第一条记录从0开始
CopyMemory IpData1Array(1), AllData(IpBegin + 1), 4 '获取起始Ip地址
IpDataBegin = UnPack(IpData1Array) '起始Ip地址

CopyMemory DataSeekArray(1), AllData(IpBegin + 5), 3
DataSeek = UnPack(DataSeekArray)
CopyMemory IpData2Array(1), AllData(DataSeek + 1), 4 '获取结束Ip地址
IpDataEnd = UnPack(IpData2Array) '结束Ip地址

CopyMemory IpFlag, AllData(DataSeek + 5), 4 '模式
MemNum = DataSeek + 5
If IpFlag = 1 Then
CopyMemory IpSeekArray(1), AllData(MemNum + 1), 4
IpSeek = UnPack(IpSeekArray)
CopyMemory IpFlag, AllData(IpSeek + 1), 3
MemNum = IpSeek + 1

End If
If IpFlag = 2 Then
CopyMemory AddrSeek1Array(1), AllData(MemNum + 1), 4 '获取国家记录偏移数据
CopyMemory IpFlag, AllData(MemNum + 4), 4

If IpFlag = 2 Then
MemNum = MemNum + 5
CopyMemory AddrSeek2Array(1), AllData(MemNum), 4 '获取地区记录偏移数据
AddrSeek2 = UnPack(AddrSeek2Array) '地区记录偏移
MemNum = AddrSeek2 + 1 '重定向到地区记录

Else
MemNum = MemNum + 4 '定位
End If
Curr = 0
Do
CopyMemory Temp(Curr), AllData(MemNum + Curr), 4
'Get #Fn, , Temp(Curr)
Curr = Curr + 1
Loop Until Temp(Curr - 1) = 0

IpAddr2 = Trim(StrConv(Temp, vbUnicode)) '取得地区记录
AddrSeek1 = UnPack(AddrSeek1Array) '国家记录偏移
MemNum = AddrSeek1 + 1 '重定向到国家记录

Curr = 0
Do
CopyMemory Temp(Curr), AllData(MemNum + Curr), 4
Curr = Curr + 1
Loop Until Temp(Curr - 1) = 0
IpAddr1 = Trim(StrConv(Temp, vbUnicode)) '取得国家记录

Else
Curr = 0
Do
CopyMemory Temp(Curr), AllData(MemNum + Curr), 4
Curr = Curr + 1
Loop Until Temp(Curr - 1) = 0

IpAddr1 = Trim(StrConv(Temp, vbUnicode)) '取得地区记录

MemNum = MemNum + Curr
CopyMemory IpFlag, AllData(MemNum), 4

If IpFlag = 2 Then
CopyMemory AddrSeek2Array(1), AllData(MemNum + 1), 4 '获取地区记录偏移数据
AddrSeek2 = UnPack(AddrSeek2Array) '地区记录偏移
MemNum = AddrSeek2 + 1 '重定向到地区记录
End If
Curr = 0
Do
CopyMemory Temp(Curr), AllData(MemNum + Curr), 4
Curr = Curr + 1
Loop Until Temp(Curr - 1) = 0
IpAddr2 = Trim(StrConv(Temp, vbUnicode)) '取得国家记录

End If


IpAddr1 = Mid(IpAddr1, 1, InStr(IpAddr1, Chr(0)) - 1) '去除0结尾
IpAddr2 = Mid(IpAddr2, 1, InStr(IpAddr2, Chr(0)) - 1) '去除0结尾
'把每一段ip资料放入一个数组元素中
TempData(i) = GetStrIP(IpDataBegin) & vbTab & GetStrIP(IpDataEnd) & vbTab & IpAddr1 & vbTab & IpAddr2 & vbCrLf
If (i Mod 10000) = 0 Then DoEvents '移交系统控制权

Next i '循环下一记录

IpString = Replace(Join(TempData), " ", "") '把所有的数组都合并成一个字符串

Open App.Path & "\ipdata.txt" For Output As #2 '写入文件
Print #2, IpString
Close #2
Close #Fn '关闭文件
Err_:
Close #Fn

MsgBox "完成"

End Sub

[renhuu]

Private Function UnPack(MyArray() As Byte) As Double
Dim n As Integer
Dim m As Integer
Dim num As Double
m = 0
For n = LBound(MyArray) To UBound(MyArray)
num = MyArray(n) * 256 ^ m + num
m = m + 1
Next n
UnPack = num
End Function
Private Function GetStrIP(ByVal StrIp As String) As String '转换整数IP为文本IP
Dim Ip(0 To 4) As Double
Ip(0) = CDbl(StrIp)
Ip(1) = Fix(Ip(0) / 16777216)
Ip(2) = Fix((Ip(0) - Ip(1) * 16777216) / 65536)
Ip(3) = Fix((Ip(0) - Ip(1) * 16777216 - Ip(2) * 65536) / 256)
Ip(4) = Fix(Ip(0) - Ip(1) * 16777216 - Ip(2) * 65536 - Ip(3) * 256)
GetStrIP = CStr(Ip(1)) & "." & CStr(Ip(2)) & "." & CStr(Ip(3)) & "." & CStr(Ip(4))
End Function

[leohdr]

老大，可不可以把你的这个程序发我一份啊，[e-mail] [e-mail]