Информационный сервер для программистов: Исходники со всего света. Паскальные исходники со всего света
  Powered by Поисковый сервер Яndex: Найдется ВСЁ!
На Главную Исходники Форум Информер Страны мира
   Базы Данных    >>    dbaseiii
   
 
 Simple dBase III Unit with Memo Fields Support  Unknown 31.03.1989

Простой модуль для работы с базами данных dBase III (.dbf). Поддерживает работу с Memo-полями (.DBT файлы).



1k 
 

unit dbaseiii; { unit including procedures for accessing DBaseIII files} interface uses Crt; Procedure OpenDBFData; Procedure OpenDBFMemo; Procedure ReadDBFRecord(I : Longint); Procedure WriteDBFRecord; Procedure ReadDBFMemo(BlockNumber : integer); Procedure WriteDBFMemo(var BlockNumberString : string); Procedure CloseDBFData; Procedure CloseDBFMemo; const DBFMaxRecordLength = 4096; DBFMemoBlockLength = 512; DBFMaxMemoLength = 4096; type DBFHeaderRec = Record HeadType : byte; Year : byte; Month : byte; Day : byte; RecordCount : longint; HeaderLength : integer; RecordSize : integer; Garbage : array[1..20] of byte; end; type DBFFieldRec = Record FieldName : array[1..11] of char; FieldType : char; Spare1, Spare2 : integer; Width : byte; Dec : byte; WorkSpace : array[1..14] of byte; end; var DBFFileName : string; DBFDataFile : File; DBFDataFileAvailable : boolean; DBFBuffer : array [1..DBFMaxRecordLength] of char; DBFHeading : DBFHeaderRec; DBFField : DBFFieldRec; DBFFieldCount : integer; DBFFieldContent : array [1..128] of string; DBFNames : array [1..128] of string[10]; DBFLengths : array [1..128] of byte; DBFTypes : array [1..128] of char; DBFDecimals : array [1..128] of byte; DBFContentStart : array [1..128] of integer; DBFMemoFile : File; DBFMemoFileAvailable : boolean; DBFMemoBuffer : Array [1..DBFMemoBlockLength] of byte; DBFMemo : Array [1..DBFMaxMemoLength] of char; DBFMemoLength : integer; DBFMemoEnd : boolean; DBFMemoBlock : integer; DBFDeleteField : char; DBFFieldStart : integer; DBFRecordNumber : longint; (****************************************************************) implementation (****************************************************************) Procedure ReadDBFHeader; var RecordsRead : integer; begin BlockRead (DBFDataFile, DBFHeading, SizeOf(DBFHeading), RecordsRead); end; (*****************************************************************) Procedure ProcessField (F : DBFFieldRec; I : integer); var J : integer; begin with F do begin DBFNames [I] := ''; J := 1; while (J<11) and (FieldName[J] <> #0) do begin DBFNames[I] := DBFNames[I] + FieldName [J]; J := J + 1; end; DBFLengths [I] := Width; DBFTypes [I] := FieldType; DBFDecimals [I] := Dec; DBFContentStart [I] := DBFFieldStart; DBFFieldStart := DBFFieldStart + Width; end; end; (***************************************************************) Procedure ReadFields; var I : integer; RecordsRead : integer; begin Seek(DBFDataFile,32); I := 1; DBFFieldStart := 2; DBFField.FieldName[1] := ' '; while (DBFField.FieldName[1] <> #13) do begin BlockRead(DBFDataFile,DBFField.FieldName[1],1); if (DBFField.FieldName[1] <> #13) then begin BlockRead(DBFDataFile, DBFField.FieldName[2], SizeOf(DBFField) - 1, RecordsRead); ProcessField (DBFField, I); I := I + 1; end; end; DBFFieldCount := I - 1; end; (***********************************************************) Procedure OpenDBFData; begin DBFDataFileAvailable := false; Assign(DBFDataFile, DBFFileName+'.DBF'); {$I-} Reset(DBFDataFile,1); If IOResult<>0 then exit; {$I+} DBFDataFileAvailable := true; Seek(DBFDataFile,0); ReadDBFHeader; ReadFields; end; (******************************************************************) Procedure CloseDBFData; begin if DBFDataFileAvailable then Close(DBFDataFile); end; (*******************************************************************) Procedure OpenDBFMemo; begin DBFMemoFileAvailable := false; Assign(DBFMemoFile, DBFFileName+'.DBT'); {$I-} Reset(DBFMemoFile,1); If IOResult<>0 then exit; {$I+} DBFMemoFileAvailable := true; Seek(DBFMemoFile,0); end; (*******************************************************************) Procedure CloseDBFMemo; begin If DBFMemoFileAvailable then close(DBFMemoFile); end; (*******************************************************************) Procedure GetDBFFields; var I : byte; J : integer; Response : string; begin DBFDeleteField := DBFBuffer[1]; For I:=1 to DBFFieldCount do begin DBFFieldContent[I] := ''; For J := DBFContentStart[I] to DBFContentStart [I] + DBFLengths[I] -1 do DBFFieldContent[I] := DBFFieldContent[I] + DBFBuffer[J]; For J := 1 to DBFLengths[I] do if DBFFieldContent[J]=#0 then DBFFieldContent[J]:=#32; end; end; (********************************************************************) Procedure ReadDBFRecord (I : Longint); var RecordsRead : integer; begin Seek(DBFDataFile, DBFHeading.HeaderLength + DBFHeading.RecordSize * (I - 1)); BlockRead (DBFDataFile, DBFBuffer, DBFHeading.RecordSize, RecordsRead); GetDBFFields; end; (********************************************************************) Procedure ReadDBFMemo(BlockNumber : integer); var I : integer; RecordsRead : word; begin DBFMemoLength := 0; DBFMemoEnd := false; If not DBFMemoFileAvailable then begin DBFMemoEnd := true; exit; end; FillChar(DBFMemo[1],DBFMaxMemoLength,#0); Seek(DBFMemoFile,BlockNumber*DBFMemoBlockLength); repeat BlockRead(DBFMemoFile, DBFMemoBuffer, DBFMemoBlockLength, RecordsRead); For I := 1 to RecordsRead do begin DBFMemoLength := DBFMemoLength + 1; DBFMemo[DBFMemoLength] := chr(DBFMemoBuffer[I] and $7F); If (DBFMemoBuffer[I] = $1A) or (DBFMemoBuffer[I] = $00) then begin DBFMemoEnd := true; DBFMemoLength := DBFMemoLength - 1; exit; end; end; until DBFMemoEnd; end; (*******************************************************************) Procedure WriteDBFMemo {(var BlockNumberString : string)}; var K : integer; ReturnCode : integer; begin Val(BlockNumberString,DBFMemoBlock,ReturnCode); If ReturnCode>0 then DBFMemoBlock := 0; If DBFMemoBlock>0 then begin Writeln; ReadDBFMemo(DBFMemoBlock); If DBFMemoLength=0 then exit; For K := 1 to DBFMemoLength do Write(DBFMemo[K]); WriteLn; end; end; (****************************************************************) Procedure WriteDBFRecord; var J : byte; begin For J := 1 to DBFFieldCount do begin Write(DBFNames[J]); GoToXY(12,J); WriteLn(DBFFieldContent[J]); if DBFTypes[J]='M' then WriteDBFMemo(DBFFieldContent[J]); end; end; (*******************************************************************) begin end.