授人于鱼,不如授人于渔
早已停用QQ了
Option Explicit Dim No() As Long '原始序号 Dim No2() As Long '新序号 Dim NoIndex As Long '当前显示的序号 Private Sub Command1_Click() '方法一:一键修改,第一种实现方法 'Call 顺序写入("C:\Users\CC\Desktop\记录.txt") '方法一:第二种实现方法,可以删 顺序写入 代码,提高代码复用性 Call 读序号("C:\Users\CC\Desktop\记录.txt", No()) Dim i As Long For i = 1 To UBound(No) No(i) = i '按顺序排序号 Next i Call 保存顺序("C:\Users\CC\Desktop\记录.txt", No()) End Sub Private Sub Command2_Click() '上一条 No2(NoIndex) = Val(Text1.Text) Call 显示序号(-1) End Sub Private Sub Command3_Click() '下一条 No2(NoIndex) = Val(Text1.Text) Call 显示序号(1) End Sub Private Sub Command4_Click() '方法二初始化程序 Call 读序号("C:\Users\CC\Desktop\记录.txt", No()) NoIndex = 1 ReDim No2(UBound(No)) Dim i As Long For i = 1 To UBound(No) No2(i) = No(i) Next i Call 显示序号 End Sub Private Sub Command5_Click() '方法二和方法三保存结果 Call 保存顺序("C:\Users\CC\Desktop\记录.txt", No2()) End Sub '--------------------------------------------------- Public Sub 顺序写入(Filename As String) '文件保存,修改NO序号为顺序号 '方法一的第一种实现方法 Dim i As Long Dim h1 As Long, h2 As Long Dim p As String Dim s As String p = App.Path If Right(p, 1) <> "\" Then p = p & "\" If Dir(Filename) = "" Then MsgBox "原文件不存在", vbCritical, "错误" Exit Sub End If h1 = FreeFile Open Filename For Input As h1 h2 = FreeFile Open p & "~tmp.txt" For Output As h2 Do While Not EOF(h1) Line Input #h1, s If Left(Trim(s), 4) = "NO: " Then '复制你的,含空格?? i = i + 1 s = "NO: " & i End If Print #h2, s Loop Close #h1 Close #h2 Kill Filename '删旧文件 Name p & "~tmp.txt" As Filename '重命名为目标文件,Name 可以在不同驱动器之间移动文件以完成重命名 MsgBox "完成" End Sub Public Sub 读序号(Filename As String, order() As Long) '读文件里的顺序 '使用一次性读文件的方式 If Dir(Filename) = "" Then MsgBox "原文件不存在", vbCritical, "错误" Exit Sub End If Dim i As Long, j As Long Dim s As String Dim h As Long Dim m() As String Dim n() As Long h = FreeFile Open Filename For Binary As #h '打开文件 '直接读整个文件的所有的内容,按字节读,并转换为 Unicode 的VB默认字符串类型 s = StrConv(InputB$(LOF(h), #h), vbUnicode) Close #h m = Split(s, vbCrLf) 'Windows 平台,没做 Linux 平台兼容 For i = 0 To UBound(m) m(i) = Trim(m(i)) If Left(m(i), 4) = "NO: " Then j = j + 1 End If Next i ReDim order(j) j = 0 For i = 0 To UBound(m) m(i) = Trim(m(i)) If Left(m(i), 4) = "NO: " Then j = j + 1 order(j) = Val(Mid(m(i), 5)) End If Next i End Sub Public Sub 显示序号(Optional 位移 As Long = 0) On Error Resume Next If IsError(UBound(No)) Then Exit Sub '发现错误时不显示 End If On Error GoTo 0 NoIndex = NoIndex + 位移 If NoIndex > UBound(No) Then NoIndex = 1 End If If NoIndex < 1 Then NoIndex = UBound(No) End If Label1.Caption = No(NoIndex) '原始值 Text1.Text = No2(NoIndex) '修改后的值 End Sub Public Sub 保存顺序(Filename As String, order() As Long) Dim i As Long Dim h1 As Long, h2 As Long Dim p As String Dim s As String p = App.Path If Right(p, 1) <> "\" Then p = p & "\" If Dir(Filename) = "" Then MsgBox "原文件不存在", vbCritical, "错误" Exit Sub End If h1 = FreeFile Open Filename For Input As h1 h2 = FreeFile Open p & "~tmp.txt" For Output As h2 Do While Not EOF(h1) Line Input #h1, s If Left(Trim(s), 4) = "NO: " Then '复制你的,含空格?? i = i + 1 s = "NO: " & order(i) '仅此与顺序文件不同 End If Print #h2, s Loop Close #h1 Close #h2 Kill Filename '删旧文件 Name p & "~tmp.txt" As Filename '重命名为目标文件,Name 可以在不同驱动器之间移动文件以完成重命名 MsgBox "完成" End Sub