今天上午想一想重写过了代码,不解释了。
程序代码:
Option Explicit
'FTEDIT '数据是否修改标志。
'无数据;
'已读数据:读盘,并且数据未修改,修改过数据保存后会设置为这个状态;
'数据已修改:修改过数据未存盘。
'这个状态也会分别设置每条数据的状态
Const 文件标志字符 = "FD" '限定为2字节长度,如果修改,需要修改结构定义和保存时的位置
'数据文件
Public Type FileTypeHand '文件头结构
文件标志 As String * 2 '1-2,FD
索引开始地址 As Long '3-6
索引大小 As Long '7-10
数据区开始地址 As Long '11-14
数据区大小 As Long '15-18
文件总大小 As Long '19-22
End Type
Public Type FileTIndexType '索引项的结构
起始地址 As Long
长度 As Long
End Type
Public Type FileTIndex '索引区结构
总项数 As Long
有效项数 As Long
索引项() As FileTIndexType
End Type
Public Enum 标志状态
无数据 = 0
已读数据 = 1
数据已修改 = 2
End Enum
Public Type FileTData '数据保存结构
D As String '数据
B As 标志状态
End Type
Public FTH As FileTypeHand '文件头
Public FTI As FileTIndex '索引区
Public FTD() As FileTData '文件所有的数据
Public FTEDIT As 标志状态 '文件是否修改
Public Function OpenFile(FileName As String, Optional 错误提示 As Boolean = False)
Dim s As String
s = Trim(FileName)
If Len(s) = 0 Then
OpenFile = -1
If 错误提示 Then MsgBox "文件名为空", vbCritical, "错误"
Exit Function
End If
If Len(Dir(s)) = 0 Then
OpenFile = -2
If 错误提示 Then MsgBox "文件不存在", vbCritical, "错误"
Exit Function
End If
Dim i As Long
Dim Fr As Long
Fr = FreeFile
With FTH
Open s For Binary As #Fr
Get #Fr, , .文件标志
If .文件标志 <> 文件标志字符 Then
OpenFile = -3
Close #Fr
If 错误提示 Then MsgBox "文件格式错误", vbCritical, "错误"
Exit Function
End If
Get #Fr, , .索引开始地址
Get #Fr, , .索引大小
Get #Fr, , .数据区开始地址
Get #Fr, , .数据区大小
Get #Fr, , .文件总大小
If LOF(Fr) <> .文件总大小 Then
OpenFile = -4
Close #Fr
If 错误提示 Then MsgBox "文件长度错误", vbCritical, "错误"
Exit Function
End If
End With
With FTI
Get #Fr, FTH.索引开始地址, .总项数
Get #Fr, , .有效项数
ReDim .索引项(.总项数)
For i = 1 To .有效项数
Get #Fr, , .索引项(i).起始地址
Get #Fr, , .索引项(i).长度
Next i
ReDim FTD(FTI.总项数)
For i = 1 To .有效项数
If .索引项(i).起始地址 > 0 Then
Seek #Fr, .索引项(i).起始地址
FTD(i).D = Input(.索引项(i).长度, Fr)
FTD(i).B = 已读数据
End If
Next i
End With
Close #Fr
FTEDIT = 已读数据
End Function
Public Function savedall(FileName As String, Optional 错误提示 As Boolean = False)
Dim s As String
s = Trim(FileName)
If Len(s) = 0 Then
savedall = -1
If 错误提示 Then MsgBox "文件名为空", vbCritical, "错误"
Exit Function
End If
Dim i As Long
Dim s1 As String
Dim dtj As Long
s1 = App.Path
If Right(s1, 1) = "\" Then
s1 = s1 & "tmp.tmp"
Else
s1 = s1 & "\tmp.tmp"
End If
If Dir(s1) <> "" Then Kill s1 '如果存在同名临时文件,删掉
Dim Fr As Long
Fr = FreeFile
Open s1 For Binary As #Fr
With FTH
Put #Fr, , 文件标志字符
.索引开始地址 = Len(FTH) + 1
.索引大小 = FTI.总项数 * 8
.数据区开始地址 = .索引开始地址 + .索引大小
Put #Fr, , .索引开始地址
Put #Fr, , .索引大小
Put #Fr, , .数据区开始地址
End With
With FTI
dtj = 0
Seek #Fr, FTH.数据区开始地址
For i = 1 To .有效项数
If FTD(i).B <> 无数据 Then
.索引项(i).起始地址 = Seek(Fr)
.索引项(i).长度 = Len(FTD(i).D)
dtj = dtj + .索引项(i).长度
Put #Fr, , FTD(i).D
End If
FTD(i).B = 已读数据 '已保存的数据,设置为未修改
Next i
Seek #Fr, FTH.索引开始地址
Put #Fr, , .总项数
Put #Fr, , .有效项数
For i = 1 To .总项数
Put #Fr, , .索引项(i).起始地址
Put #Fr, , .索引项(i).长度
Next i
End With
FTH.数据区大小 = dtj
FTH.文件总大小 = Len(FTH) + FTH.索引大小 + FTH.数据区大小
Put #Fr, 15, FTH.数据区大小
Put #Fr, 19, FTH.文件总大小
Close #Fr
FTEDIT = 已读数据
If Len(Dir(s)) <> 0 Then '原文件存在,删掉
Kill s
End If
Name s1 As s '临时文件改名为数据文件名
End Function
Public Sub setdata(Cs As String, index As Long)
'给数据区设置数据,会修改标志会
If index > FTI.总项数 Then
FTI.总项数 = index + 20 '预留多少空位位置
ReDim Preserve FTI.索引项(FTI.总项数)
ReDim Preserve FTD(FTI.总项数)
End If
FTD(index).D = Cs
FTD(index).B = 数据已修改
If index > FTI.有效项数 Then
FTI.有效项数 = index
End If
FTEDIT = 数据已修改
End Sub
测试代码:
程序代码:
Private Sub Command1_Click()
Call setdata("11111111", 1)
Call setdata("22222222", 2)
Call setdata("33333333", 4) '这行特意跳格保存了
If savedall("e:\d.dat", True) <> 0 Then
MsgBox "保存过程中出现错误"
End If
End Sub
Private Sub Command2_Click()
If OpenFile("e:\d.dat", True) = 0 Then
MsgBox "读取成功"
Else
MsgBox "读取错误"
End If
End Sub
[此贴子已经被作者于2018-11-2 11:21编辑过]