1: Const BlockSize = 1024 2: Dim Rec(2) As String 3: 4: Function ByteToValue (ByteNumber As String) As Long 5: For q = 1 To Len(ByteNumber) 6: wrk$ = Hex$(Asc(Mid$(ByteNumber, q, 1))) 7: ot$ = ot$ + String(2 - Len(wrk$), "0") + wrk$ 8: Next q 9: ByteToValue = Val("&H" & ot$) 10: End Function 11: 12: Function CountRecords (RecordFile As String) 13: xx = FreeFile 14: Open RecordFile & ".IDX" For Binary As #xx 15: CountRecords = LOF(xx) / 4 16: Close #xx 17: End Function 18: 19: Sub DeleteRecord (RecordNumber, RecordFile As String) 20: Dim FourByte As String * 4 21: Dim ThreeByte As String * 3 22: Dim TwoByte As String * 2 23: Dim TransferBlock As String * BlockSize 24: xx = FreeFile 25: Open RecordFile & ".IDX" For Binary As #xx: xy = FreeFile 26: Open RecordFile & ".REC" For Binary As #xy 27: Get #xx, ((RecordNumber - 1) * 4) + 1, FourByte 28: Location = ByteToValue(FourByte) 29: Get #xy, Location, ThreeByte 30: Length = ByteToValue(ThreeByte) 31: xz = FreeFile 32: Open "TMP.JNK" For Output As #xz: Print #xz, ""; : Close #xz 33: Open "TMP.JNK" For Binary As #xz 34: For q = 1 To LOF(xy) 35: Get #xy, q, TransferBlock 36: If q + Len(TransferBlock) > LOF(xy) Then g$ = Left$(TransferBlock, LOF(xy) - q + 1) Else g$ = TransferBlock 37: If (q + Len(g$) > Location And q < Location) Then f$ = Left$(g$, Location - q) 38: If (q + Len(g$) > Length + Location And q < Location + Length) Then b$ = Right$(g$, Len(g$) - ((Location + Length) - q)) 39: g$ = f$ + b$ 40: Put #xz, , g$ 41: q = q + Len(TransferBlock) - 1 42: g$ = "": b$ = "": f$ = "" 43: Next q 44: Close #xx, xy, #xz 45: Kill RecordFile & ".REC" 46: Name "TMP.JNK" As RecordFile & ".REC" 47: RewriteIDX RecordFile 48: End Sub 49: 50: Function GetEntry (RecordNumber, EntryNumber, RecordFile As String) As String 51: Dim Byte4 As String * 4 52: Dim Byte3 As String * 3 53: Dim Byte1 As String * 1 54: Dim TransferBlock As String * BlockSize 55: xx = FreeFile: Open RecordFile & ".IDX" For Binary As #xx 56: xy = FreeFile: Open RecordFile & ".REC" For Binary As #xy 57: NumRec = LOF(xx) / 4 58: If RecordNumber > NumRec Then Close #xx, #xy: Exit Function 59: q = RecordNumber 60: Get #xx, ((q - 1) * 4) + 1, Byte4 61: LocOfRecord = ByteToValue(Byte4) 62: Get #xy, LocOfRecord + 5, Byte1 63: Get #xy, LocOfRecord, Byte3 64: LengthOfRecord = ByteToValue(Byte3) 65: NumOfEntries = ByteToValue(Byte1) 66: If EntryNumber <= NumOfEntries Then 67: Get #xy, LocOfRecord + 6 + ((EntryNumber - 1) * 3), Byte3 68: EntryStart = ByteToValue(Byte3) + LocOfRecord - 1 69: If NumOfEntries > EntryNumber Then Get #xy, LocOfRecord + 6 + ((EntryNumber) * 3), Byte3: EntryEnd = ByteToValue(Byte3) + LocOfRecord - 1 Else EntryEnd = LengthOfRecord + LocOfRecord 70: LengthOfEntry = EntryEnd - EntryStart 71: For x = 0 To LengthOfEntry 72: Get #xy, EntryStart + x, TransferBlock 73: If x + Len(TransferBlock) > LengthOfEntry Then g$ = g$ + Left$(TransferBlock, LengthOfEntry - x) Else g$ = g$ + TransferBlock 74: x = x + Len(TransferBlock) - 1 75: Next x 76: GetEntry = g$ 77: g$ = "" 78: End If 79: Close #xx, #xy 80: 81: End Function 82: 83: Sub GetEntryFromEach (EntryNumber, EntryData() As String, RecordFile As String) 84: Dim Byte4 As String * 4 85: Dim Byte3 As String * 3 86: Dim Byte1 As String * 1 87: Dim TransferBlock As String * BlockSize 88: xx = FreeFile: Open RecordFile & ".IDX" For Binary As #xx 89: xy = FreeFile: Open RecordFile & ".REC" For Binary As #xy 90: NumArray = (UBound(EntryData) - LBound(EntryData)) + 1 91: NumRec = LOF(xx) / 4 92: For q = 1 To Switch(NumRec <= NumArray, NumRec, NumArray < NumRec, NumArray) 93: Get #xx, ((q - 1) * 4) + 1, Byte4 94: LocOfRecord = ByteToValue(Byte4) 95: Get #xy, LocOfRecord + 5, Byte1 96: Get #xy, LocOfRecord, Byte3 97: LengthOfRecord = ByteToValue(Byte3) 98: NumOfEntries = ByteToValue(Byte1) 99: If EntryNumber <= NumOfEntries Then 100: Get #xy, LocOfRecord + 6 + ((EntryNumber - 1) * 3), Byte3 101: EntryStart = ByteToValue(Byte3) + LocOfRecord - 1 102: If NumOfEntries > EntryNumber Then Get #xy, LocOfRecord + 6 + ((EntryNumber) * 3), Byte3: EntryEnd = ByteToValue(Byte3) + LocOfRecord - 1 Else EntryEnd = LengthOfRecord + LocOfRecord 103: LengthOfEntry = EntryEnd - EntryStart 104: For x = 0 To LengthOfEntry 105: Get #xy, EntryStart + x, TransferBlock 106: If x + Len(TransferBlock) > LengthOfEntry Then g$ = g$ + Left$(TransferBlock, LengthOfEntry - x) Else g$ = g$ + TransferBlock 107: x = x + Len(TransferBlock) - 1 108: Next x 109: EntryData(LBound(EntryData) + (q - 1)) = g$ 110: g$ = "" 111: End If 112: Next q 113: Close #xx, #xy 114: End Sub 115: 116: Sub LoadRecord (RecordNumber, RecordData() As String, RecordFile As String) 117: Dim Byte4 As String * 4 118: Dim Byte3 As String * 3 119: Dim Byte2 As String * 2 120: Dim Byte1 As String * 1 121: Dim TransferBlock As String * BlockSize 122: xx = FreeFile 123: Open RecordFile & ".IDX" For Binary As #xx 124: If LOF(xx) < RecordNumber * 4 Then Close #xx: Exit Sub 125: Get #xx, ((RecordNumber - 1) * 4) + 1, Byte4 126: Close #xx 127: Location = ByteToValue(Byte4) 128: Open RecordFile & ".REC" For Binary As #xx 129: Get #xx, Location, Byte3 130: Length = ByteToValue(Byte3) 131: Get #xx, Location + 3, Byte2 132: RecNum = ByteToValue(Byte2) 133: If RecNum <> RecordNumber Then Close #xx: Exit Sub 134: Get #xx, Location + 5, Byte1 135: NumEntries = ByteToValue(Byte1) 136: n1 = (UBound(RecordData) - LBound(RecordData)) + 1 137: n2 = NumEntries 138: OffSet = LBound(RecordData) - 1 139: For q = 1 To Switch(n1 <= n2, n1, n2 < n1, n2) 140: Get #xx, (Location + 6) + ((q - 1) * 3), Byte3 141: LocOfEntry = ByteToValue(Byte3) 142: If q <> NumEntries Then Get #xx, (Location + 6) + ((q) * 3), Byte3: LocOfNextEntry = ByteToValue(Byte3) Else LocOfNextEntry = Length + 1 143: EntryLength = LocOfNextEntry - LocOfEntry 144: For x = 0 To EntryLength 145: ReadLoc = ((Location + LocOfEntry) - 1) + x 146: Get #xx, ReadLoc, TransferBlock 147: If x + Len(TransferBlock) > EntryLength Then g$ = g$ + Left$(TransferBlock, EntryLength - x) Else g$ = g$ + TransferBlock 148: x = x + Len(TransferBlock) 149: Next x 150: RecordData(OffSet + q) = g$ 151: g$ = "" 152: Next q 153: Close #xx 154: End Sub 155: 156: Function RecordExists (RecordNumber, RecordFile As String) As Integer 157: Dim FourByte As String * 4 158: Dim TwoByte As String * 2 159: xx = FreeFile 160: Open RecordFile & ".IDX" For Binary As #xx: xy = FreeFile 161: If LOF(xx) / 4 < RecordNumber Or RecordNumber <= 0 Then Close #xx: RecordExists = 0: Exit Function 162: Open RecordFile & ".REC" For Binary As #xy 163: Get #xx, Int((RecordNumber - 1) * 4) + 1, FourByte 164: Close #xx 165: Location = ByteToValue(FourByte) 166: If Location > LOF(xy) Then Close #xy: RecordExists = 0: Exit Function 167: Get #xy, Location + 3, TwoByte 168: RecNum = ByteToValue(TwoByte) 169: If RecNum = RecordNumber Then RecordExists = -1 Else RecordExists = 0 170: Close #xy 171: End Function 172: 173: Sub RewriteIDX (RecordFile As String) 174: Dim FourByte As String * 4 175: Dim ThreeByte As String * 3 176: Dim TwoByte As String * 2 177: xy = FreeFile 178: Open RecordFile & ".REC" For Binary As #xy: xz = FreeFile 179: Open "TMP.JK1" For Binary As #xz 180: For q = 1 To LOF(xy) 181: Get #xy, q, ThreeByte 182: Get #xy, q + 3, TwoByte 183: RecNum = ByteToValue(TwoByte) 184: Length = ByteToValue(ThreeByte) 185: Location$ = ValueToByte(q, 4) 186: Put #xz, ((RecNum - 1) * 4) + 1, Location$ 187: q = q + Length - 1 188: Next q 189: Close #xy, #xz 190: Open RecordFile & ".IDX" For Output As #xy: Print #xy, ""; : Close #xy 191: Kill RecordFile & ".IDX" 192: Name "TMP.JK1" As RecordFile & ".IDX" 193: End Sub 194: 195: Sub SaveRecord (RecordNumber, RecordData() As String, RecordFile As String) 196: Dim Byte4 As String * 4 197: Dim Byte3 As String * 3 198: Dim Byte2 As String * 2 199: Dim Byte1 As String * 1 200: xx = FreeFile: Open RecordFile & ".IDX" For Binary As #xx: xy = FreeFile 201: NumberOfRecords = LOF(xx) / 4 202: Close #xx 203: If RecordNumber < 0 Or RecordNumber > NumberOfRecords Then Adding = 0: RecordNumber = NumberOfRecords + 1 Else Adding = 1 204: If Adding = 1 Then DeleteRecord RecordNumber, RecordFile 205: Open RecordFile & ".REC" For Binary As #xx 206: Location = LOF(xx) + 1 207: NumEntries = (UBound(RecordData) - LBound(RecordData)) + 1 208: NumEnt$ = ValueToByte(NumEntries, 1) 209: RecNumb$ = ValueToByte(RecordNumber, 2) 210: Put #xx, Location + 3, RecNumb$ 211: Put #xx, Location + 5, NumEnt$ 212: EntryOffset = Location + 6 + (NumEntries * 3) 213: For q = LBound(RecordData) To UBound(RecordData) 214: Byte3 = ValueToByte(7 + (NumEntries * 3) + DataSoFar, 3) 215: Put #xx, EntryOffset + DataSoFar, RecordData(q) 216: Put #xx, Location + 6 + (cnt * 3), Byte3 217: cnt = cnt + 1 218: DataSoFar = DataSoFar + Len(RecordData(q)) 219: Next q 220: TotalLength$ = ValueToByte(DataSoFar + (NumEntries * 3) + 6, 3) 221: Put #xx, Location, TotalLength$ 222: Close #xx 223: RewriteIDX RecordFile 224: End Sub 225: 226: Function ValueToByte (Number, Length As Integer) As String 227: wrk$ = Hex$(Number) 228: wrk$ = String(Len(wrk$) Mod 2, "0") + wrk$ 229: For q = 1 To Len(wrk$) Step 2 230: ot$ = ot$ + Chr$(Val("&H" + Mid$(wrk$, q, 2))) 231: Next q 232: ValueToByte = String(Length - Len(ot$), Chr$(0)) + ot$ 233: End Function 234: |