VB6打开文件速度慢

哎你是从哪里冒出来的9号呢 2008-07-08 03:04:49

如题，我用VB做上位机，于单片机232通讯，但是用VB打开HEX文件时，速度很慢，才10多K的一个HEX文件，居然花了差不多一分钟，以下是VB代码，请各位DX拍砖！

'模块级变量，用于本窗体所有过程
Private Slave_Is_Ready As Byte
Private Write_Is_Doing As Byte
Private Timer1_Ovf_Count As Integer

'一些进制转换函数
'字符串转十六进制
Function String_To_Hex(a As String)
Dim b As String
Dim Data As Integer
b = Mid(a, 1, 1)

'取高4位
If Asc(b) > 64 And Asc(b) < 71 Then 'A-F
String_To_Hex = (Asc(b) - 55) * 16
ElseIf Asc(b) > 47 And Asc(b) < 58 Then '0-9
String_To_Hex = (Asc(b) - 48) * 16
End If
'取低4位
b = Mid(a, 2, 1)
If Asc(b) > 64 And Asc(b) < 71 Then 'A-F
String_To_Hex = String_To_Hex + (Asc(b) - 55)
ElseIf Asc(b) > 47 And Asc(b) < 58 Then '0-9
String_To_Hex = String_To_Hex + (Asc(b) - 48)
End If
String_To_Hex = Hex(String_To_Hex)
End Function

'字符串转十进制数
Function String_To_Dec(a As String)
Dim b As String
Dim Data As Integer
b = Mid(a, 1, 1)

'取高4位
If Asc(b) > 64 And Asc(b) < 71 Then 'A-F
String_To_Dec = (Asc(b) - 55) * 16
ElseIf Asc(b) > 47 And Asc(b) < 58 Then '0-9
String_To_Dec = (Asc(b) - 48) * 16
End If
'取低4位
b = Mid(a, 2, 1)
If Asc(b) > 64 And Asc(b) < 71 Then 'A-F
String_To_Dec = String_To_Dec + (Asc(b) - 55)
ElseIf Asc(b) > 47 And Asc(b) < 58 Then '0-9
String_To_Dec = String_To_Dec + (Asc(b) - 48)
End If
End Function

'菜单事件

'菜单关于
Private Sub about_Click()
Dim Ret_Val As Integer
Ret_Val = MsgBox("Bootloader Ver1.0.0", 4096, "关于")
End Sub

'命令按钮控件

'清除发送文本框按钮
Private Sub Cmd_ClrSendbox_Click()
Sendbox.Text = ""
End Sub

'打开文件按钮
Private Sub Cmd_Openfile_Click()
Dim File_Name As String
Dim Read_Buff As String
Dim Data_String As String
Dim Total_Bytes As Integer
'先清空文本框显示的内容
Sendbox.Text = ""
Total_Bytes = 0

'打开文件
Dlg_Openfile.CancelError = True
On Error GoTo ErrHandler
Dlg_Openfile.Filter = "十六进制文件(*.hex)|*.hex" '| 所有文件(*.*) | *.* " '设置文件过滤器
Dlg_Openfile.FilterIndex = 3 '指定默认过滤器
Dlg_Openfile.Flags = &H4& '对话框含有帮助按钮
Dlg_Openfile.ShowOpen '显示对话框
File_Name = Dlg_Openfile.FileName

'显示待写入数据
Open File_Name For Input As #1
While Not EOF(1)
Line Input #1, Read_Buff 'line input #1, 变量名从#1文件中读出一行并赋值给变量

Data_String = Mid(Read_Buff, 2, 2)
Length = String_To_Dec(Data_String) '取本行字节数
Total_Bytes = Total_Bytes + Length
For i = 0 To Length - 1 Step 1
If i = Length - 1 Then
Sendbox.Text = Sendbox.Text + Mid(Read_Buff, 10 + i * 2, 2) + vbCrLf
Else
Sendbox.Text = Sendbox.Text + Mid(Read_Buff, 10 + i * 2, 2) + " "
End If
Next i

Wend
Close #1
Data_String = Str(Total_Bytes)
Mesg_Clew.Caption = "总共 " + Data_String + " 字节"
ErrHandler:
Exit Sub
End Sub

'打开串口按钮
Private Sub Open_Comm_Click()
If Open_Comm.Caption = "打开串口" Then
'获取串口设置参数
'一定要首先关闭通信端口才能进行设置

'获得波特率
MSComm1.Settings = Combo_Baudrate.Text
'取得端口号
Select Case Combo_Comm.Text
Case "COM1"
MSComm1.CommPort = 1
Case "COM2"
MSComm1.CommPort = 2
Case "COM3"
MSComm1.CommPort = 3
Case "COM4"
MSComm1.CommPort = 4
Case "COM5"
MSComm1.CommPort = 5
Case "COM6"
MSComm1.CommPort = 6
Case "COM7"
MSComm1.CommPort = 7
Case "COM8"
MSComm1.CommPort = 8
End Select
'一定不要忘了开通信端口
MSComm1.PortOpen = True

'上位机指示状况改变
Combo_Baudrate.Enabled = False
Combo_Comm.Enabled = False
Cmd_Write.Enabled = True
Open_Comm.MaskColor = &HFF&
Open_Comm.Caption = "关闭串口"
Shape1.FillColor = &HC0&
ElseIf Open_Comm.Caption = "关闭串口" Then
'关闭通信端口
MSComm1.PortOpen = False
Combo_Baudrate.Enabled = True
Combo_Comm.Enabled = True
Cmd_Write.Enabled = False
Shape1.FillColor = &HC000&
Open_Comm.Caption = "打开串口"
End If
End Sub

'烧写程序按钮
'
Private Sub Cmd_Write_Click()
'首先发送一个字符'w'或者'W'到下位机，等待下位机发回"W"字符
MSComm1.Output = "W"
If Slave_Is_Ready Then

End If

' Slave_Is_Ready = 0
' Do While Slave_Is_Ready = 0
' If Timer1_Ovf_Count >= 100 Then '5s的超时允许
' Timer1_Ovf_Count = 0
' Exit Do
' End If
' Loop
'
' Write_Is_Doing = 1
' Do While Write_Is_Doing = 1
' If Timer1_Ovf_Count >= 3600 Then '3分钟的超时允许
' Timer1_Ovf_Count = 0
' Exit Do
' End If
' Loop

End Sub

'窗体初始化
Private Sub Form_Load()
'初始化界面
'初始化下拉菜单
Combo_Baudrate.AddItem "2400"
Combo_Baudrate.AddItem "4800"
Combo_Baudrate.AddItem "9600"
Combo_Baudrate.AddItem "19200"
Combo_Baudrate.AddItem "38400"
Combo_Baudrate.AddItem "56000"
Combo_Baudrate.AddItem "57600"
Combo_Baudrate.AddItem "115200"
Combo_Comm.AddItem "COM1"
Combo_Comm.AddItem "COM2"
Combo_Comm.AddItem "COM3"
Combo_Comm.AddItem "COM4"
Combo_Comm.AddItem "COM5"
Combo_Comm.AddItem "COM6"
Combo_Comm.AddItem "COM7"
Combo_Comm.AddItem "COM8"
'初始化命令按钮
Cmd_Write.Enabled = False
'初始化输出框

'初始化定时器
Timer1.Enabled = True
'初始化串口
MSComm1.InputLen = 1 '设置一次从接收缓冲区读取字节数，0表示一次读取所有数据
MSComm1.InputMode = comInputModeText '设置input属性，以文本方式取回传入的数据
MSComm1.InBufferSize = 512 '设置或返回接收缓冲区的字节数
MSComm1.InBufferCount = 0
MSComm1.OutBufferSize = 512 '
MSComm1.OutBufferCount = 0
MSComm1.RThreshold = 1 '设置为1，则接收缓冲区每收到一个字符都会使MSComm控件触发OnComm事件；设置为0，则不产生OnComm事件
MSComm1.SThreshold = 1 '设置为1，则当传输缓冲区完全空时，数据传输事件不会产生OnComm事件；设置为0，则不会产生OnComm事件

End Sub

'串口MSComm事件
Private Sub MSComm1_OnComm()
'MSComm控件把17个事件归并为一个事件OnComm，用属性CommEvent的17个值来区分不同触发
Dim i As Integer
Select Case MSComm1.CommEvent
Case comEvReceive

Select Case MSComm1.Input

Case "W":
'下位机请求上位机发送数据块
'一个数据块格式： 0x01 + 数据块编号＋数据块编号反码＋128字节数据＋2字节的CRC校验码
'以下是将原始数据转成十六进制发送出去，这样做觉得VB真的恶心
'开始发送数据块

Case " ":
Case Else
End Select

Case Else
End Select
End Sub

Private Sub Timer1_Timer()
Time_Disp.Caption = Now
End Sub

...全文

534 26 打赏收藏转发到动态举报

写回复

用AI写文章

26 条回复

切换为时间正序

请发表友善的回复…

发表回复

tbage2008 2012-07-07

打赏
举报

学习了...

AddDark 2011-10-18

打赏
举报

占位留名，需时便取

橘子皮... 2011-07-21

打赏
举报

可有这样的读写文件的模块？？？

可西哥 2008-07-10

打赏
举报

哈,老马提到偶,偶也改了改代码



Public Sub Main()

    Debug.Print GetHexText2("C:\test.dat")

    

End Sub

Private Function GetHexText(ByVal theFileName As String) As String()

    Dim Buff As String, LineBuff() As String, OutBuff() As String

    Dim tmpI As Long, tmpJ As Long, tmpK As Long, tmpStr() As String

    

    Open theFileName For Binary As #1

        Buff = Space(LOF(1))             '一次性读入.只要文件不大于50M的话就比较快

        Get #1, , Buff

    Close #1

    

    ReDim OutBuff(0)

    LineBuff = Split(Buff, vbCrLf)        '先按行拆分

    

    For tmpI = 0 To UBound(LineBuff)            '对每行进行循环处理

        If Len(LineBuff(tmpI)) > 12 Then        '有效行应该不会小于12个字符

            ReDim tmpStr(15)

            ReDim Preserve OutBuff(UBound(OutBuff) + 1)

            tmpK = 0



            Buff = Mid(LineBuff(tmpI), 9, 32)   '从第9个字符开始的32个字符,貌似也不变

            For tmpJ = 1 To 31 Step 2

                tmpStr(tmpK) = Mid(Buff, tmpJ, 2)    '每两个字符放到一个数组元素中去

                tmpK = tmpK + 1

            Next tmpJ

            OutBuff(UBound(OutBuff)) = Join(tmpStr, " ")     '用JOIN一次性填好

        End If

    Next tmpI

    GetHexText = OutBuff

End Function



Private Function GetHexText2(ByVal theFileName As String) As String

    Dim Buff() As Byte          '原始数据

        Dim lngLen As Long      '数据长度

        Dim OutBuff() As Byte   '目标数组

    Dim tmpI As Long            '源数据指针

        Dim tmpJ As Long        '临时变量

        Dim tmpK As Long        '复制到目标位置指针

        Dim tmpStr() As String



    Open theFileName For Binary As #1

        lngLen = LOF(1) - 1

        ReDim Buff(lngLen)              '一次性读入.只要文件不大于50M的话就比较快

        Get #1, , Buff

    Close #1

    

    ReDim OutBuff(lngLen)           '估计生成的数据跟原始的差不多,因为中间有加空格

    tmpI = 0

    tmpK = 0

    Do While tmpI <= lngLen '对数据进行处理

        '判断是否一行的开始，判断":"号

        If Buff(tmpI) = 58 Then

            '跳过前面8位的地址

            tmpI = tmpI + 9

            '开始复制8个数据,一个数据占2位

            For tmpJ = 1 To 16 Step 2

                OutBuff(tmpK) = Buff(tmpI)

                OutBuff(tmpK + 1) = Buff(tmpI + 1)

                OutBuff(tmpK + 2) = 32          '加一个空格

                tmpI = tmpI + 2                         '源指针移2

                tmpK = tmpK + 3                         '目标指针向后移3

            Next

            '加个回车换行

            OutBuff(tmpK) = 10

            OutBuff(tmpK + 1) = 13

            tmpK = tmpK + 2

            '直接到下一行

            Call GoNextLine(Buff, tmpI)

        Else

            '不是":"号,再继续找

            tmpI = tmpI + 1

        End If

    Loop

    GetHexText2 = StrConv(OutBuff, vbUnicode)

End Function





'定位到下一行

Private Sub GoNextLine(dat() As Byte, ByRef i As Long)

        Dim lngT As Long

        

        lngT = UBound(dat)

        

        Do While i < lngT

            If dat(i) = &HD Then

                If i + 1 <= lngT Then

                    If dat(i + 1) = &HA Then

                        i = i + 1

                        Exit Do

                    End If

                End If

            End If

            i = i + 1

        Loop



End Sub

GetHexText2是偶的函数
没有大文件,让老马帮偶测测

嗷嗷叫的老马 2008-07-10

打赏
举报

最新测试结果........真的好快-_-

服啊,N次倒在XMXOXO的剑下-_-

Option Explicit



Private Declare Function GetTickCount Lib "kernel32.dll" () As Long



Public Sub Main()

    Dim i As String, J As Long

    

    J = GetTickCount

    i = GetHexText("d:\temp\1.txt")         '我的方法,8秒左右

    MsgBox GetTickCount - J

    Debug.Print i

    

    J = GetTickCount

    i = GetHexText2("d:\temp\1.txt")        'XMXOXO的方法,1.6秒左右-_-

    MsgBox GetTickCount - J

    Debug.Print i

End Sub



Private Function GetHexText(ByVal theFileName As String) As String

    Dim Buff As String, LineBuff() As String, OutBuff() As String

    Dim tmpI As Long, tmpJ As Long, tmpK As Long, tmpStr() As String

    

    Open theFileName For Binary As #1

        Buff = Space(LOF(1))             '一次性读入.只要文件不大于50M的话就比较快

        Get #1, , Buff

    Close #1

    

    ReDim OutBuff(0)

    LineBuff = Split(Buff, vbCrLf)        '先按行拆分

    

    For tmpI = 0 To UBound(LineBuff)            '对每行进行循环处理

        If Len(LineBuff(tmpI)) > 12 Then        '有效行应该不会小于12个字符

            ReDim tmpStr(15)

            ReDim Preserve OutBuff(UBound(OutBuff) + 1)

            tmpK = 0



            Buff = Mid(LineBuff(tmpI), 9, 32)   '从第9个字符开始的32个字符,貌似也不变

            For tmpJ = 1 To 31 Step 2

                tmpStr(tmpK) = Mid(Buff, tmpJ, 2)    '每两个字符放到一个数组元素中去

                tmpK = tmpK + 1

            Next tmpJ

            OutBuff(UBound(OutBuff)) = Join(tmpStr, " ")     '用JOIN一次性填好

        End If

    Next tmpI

    GetHexText = Join(OutBuff, vbCrLf)

End Function

                                                '*************  可爱的分割条

                                                

Private Function GetHexText2(ByVal theFileName As String) As String

    Dim Buff() As Byte          '原始数据

        Dim lngLen As Long      '数据长度

        Dim OutBuff() As Byte   '目标数组

        Dim tmpI As Long        '源数据指针

        Dim tmpJ As Long        '临时变量

        Dim tmpK As Long        '复制到目标位置指针

        Dim lngDats As Long     '数据个数

        



    Open theFileName For Binary As #1

        lngLen = LOF(1) - 1

        ReDim Buff(lngLen)              '一次性读入.只要文件不大于50M的话就比较快

        Get #1, , Buff

    Close #1

    

    ReDim OutBuff(lngLen)           '估计生成的数据跟原始的差不多,因为中间有加空格

    tmpI = 0

    tmpK = 0

    lngDats = 0

    Do While tmpI <= lngLen '对数据进行处理

        '判断是否一行的开始，判断":"号

        If Buff(tmpI) = 58 Then

            '跳过前面8位的地址

            tmpI = tmpI + 9

            '开始复制8个数据,一个数据占2位

            For tmpJ = 1 To 16 Step 2

                OutBuff(tmpK) = Buff(tmpI)

                OutBuff(tmpK + 1) = Buff(tmpI + 1)

                OutBuff(tmpK + 2) = 32          '加一个空格

                tmpI = tmpI + 2                 '源指针移2

                tmpK = tmpK + 3                 '目标指针向后移3

                lngDats = lngDats + 1

            Next

            '输出多少个数据后需要换行?

            If lngDats Mod 16 = 0 Then

                '加个回车换行

                OutBuff(tmpK) = &HD

                OutBuff(tmpK + 1) = &HA

                tmpK = tmpK + 2

            End If

            '直接到下一行

            Call GoNextLine(Buff, tmpI)

        Else

            '不是":"号,再继续找

            tmpI = tmpI + 1

        End If

    Loop

    ReDim Preserve OutBuff(tmpK)

    GetHexText2 = StrConv(OutBuff, vbUnicode)

End Function



'定位到下一行

Private Sub GoNextLine(dat() As Byte, ByRef i As Long)

        Dim lngT As Long

        

        lngT = UBound(dat)

        

        Do While i < lngT

            If dat(i) = &HD Then

                If i + 1 <= lngT Then

                    If dat(i + 1) = &HA Then

                        i = i + 1

                        Exit Do

                    End If

                End If

            End If

            i = i + 1

        Loop

End Sub

可西哥 2008-07-10

打赏
举报

老马要求还挺高,差一点都不行,又改了改:



Private Function GetHexText2(ByVal theFileName As String) As String

    Dim Buff() As Byte          '原始数据

        Dim lngLen As Long      '数据长度

        Dim OutBuff() As Byte   '目标数组

        Dim tmpI As Long        '源数据指针

        Dim tmpJ As Long        '临时变量

        Dim tmpK As Long        '复制到目标位置指针

        Dim lngDats As Long     '数据个数

        



    Open theFileName For Binary As #1

        lngLen = LOF(1) - 1

        ReDim Buff(lngLen)              '一次性读入.只要文件不大于50M的话就比较快

        Get #1, , Buff

    Close #1

    

    ReDim OutBuff(lngLen)           '估计生成的数据跟原始的差不多,因为中间有加空格

    tmpI = 0

    tmpK = 0

    lngDats = 0

    Do While tmpI <= lngLen '对数据进行处理

        '判断是否一行的开始，判断":"号

        If Buff(tmpI) = 58 Then

            '跳过前面8位的地址

            tmpI = tmpI + 9

            '开始复制8个数据,一个数据占2位

            For tmpJ = 1 To 16 Step 2

                OutBuff(tmpK) = Buff(tmpI)

                OutBuff(tmpK + 1) = Buff(tmpI + 1)

                OutBuff(tmpK + 2) = 32          '加一个空格

                tmpI = tmpI + 2                 '源指针移2

                tmpK = tmpK + 3                 '目标指针向后移3

                lngDats = lngDats + 1

            Next

            '输出多少个数据后需要换行?

            If lngDats Mod 16 = 0 Then

                '加个回车换行

                OutBuff(tmpK) = &HD

                OutBuff(tmpK + 1) = &HA

                tmpK = tmpK + 2

            End If

            '直接到下一行

            Call GoNextLine(Buff, tmpI)

        Else

            '不是":"号,再继续找

            tmpI = tmpI + 1

        End If

    Loop

    ReDim Preserve OutBuff(tmpK)

    GetHexText2 = StrConv(OutBuff, vbUnicode)

End Function





'定位到下一行

Private Sub GoNextLine(dat() As Byte, ByRef i As Long)

        Dim lngT As Long

        

        lngT = UBound(dat)

        

        Do While i < lngT

            If dat(i) = &HD Then

                If i + 1 <= lngT Then

                    If dat(i + 1) = &HA Then

                        i = i + 1

                        Exit Do

                    End If

                End If

            End If

            i = i + 1

        Loop



End Sub

嗷嗷叫的老马 2008-07-09

打赏
举报

Private Sub Command1_Click()
Dim I() As String, J As Long

I = GetHexText("D:\calendar.hex")
text1.text=join(i,vbcrlf)
End Sub

看看速度怎样

哎你是从哪里冒出来的9号呢 2008-07-09

打赏
举报

帅，成了，很快！

哎你是从哪里冒出来的9号呢 2008-07-08

打赏
举报

呵呵，真的不错，myjian，不过你的代码是把内容打开再输出到立即窗口，我用下面这种方法把内容输入到文本框，但是效果跟之前的差不多了，一个字慢
这就是我的代码
Private Sub Command1_Click()
Dim I() As String, J As Long

I = GetHexText("D:\calendar.hex")
For J = 1 To UBound(I)
Text1.Text = Text1.Text & I(J) & vbCrLf
Next J
End Sub

lingshao0909 2008-07-08

打赏
举报

学习了，以后肯定有用的着的时候，呵呵。虽然来这里混了不久，还是学到了很多东西啊

哎你是从哪里冒出来的9号呢 2008-07-08

打赏
举报

哇噻，是吗？太棒了，我试下去

嗷嗷叫的老马 2008-07-08

打赏
举报

测试了一个12.3M的文件,用你那段文件片断不断复制而成.

我这里花了约7.3秒,应该还未做到最优,但于你的应用,是足够了吧.

记得以前XMXOXO处理一个70M的文件,最快花了4.5秒......

嗷嗷叫的老马 2008-07-08

打赏
举报

'添加一个按钮,改一下你HEX文件的路径,就可以测试了.在我这里速度还可以.

Option Explicit



Private Sub Command1_Click()

    Dim I() As String, J As Long

    

    I = GetHexText("D:\temp\1.txt")

    For J = 1 To UBound(I)

        Debug.Print I(J)

    Next J

End Sub



Private Function GetHexText(ByVal theFileName As String) As String()

    Dim Buff As String, LineBuff() As String, OutBuff() As String

    Dim tmpI As Long, tmpJ As Long, tmpK As Long, tmpStr() As String

    

    Open theFileName For Binary As #1

        Buff = Space(LOF(1))             '一次性读入.只要文件不大于50M的话就比较快

        Get #1, , Buff

    Close #1

    

    ReDim OutBuff(0)

    LineBuff = Split(Buff, vbCrLf)        '先按行拆分

    

    For tmpI = 0 To UBound(LineBuff)            '对每行进行循环处理

        If Len(LineBuff(tmpI)) > 12 Then        '有效行应该不会小于12个字符

            ReDim tmpStr(15)

            ReDim Preserve OutBuff(UBound(OutBuff) + 1)

            tmpK = 0



            Buff = Mid(LineBuff(tmpI), 9, 32)   '从第9个字符开始的32个字符,貌似也不变

            For tmpJ = 1 To 31 Step 2

                tmpStr(tmpK) = Mid(Buff, tmpJ, 2)    '每两个字符放到一个数组元素中去

                tmpK = tmpK + 1

            Next tmpJ

            OutBuff(UBound(OutBuff)) = Join(tmpStr, " ")     '用JOIN一次性填好

        End If

    Next tmpI

    GetHexText = OutBuff

End Function