pascal/kolmck
pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity
kolmck/Addons/KOLmdvDBF.pas

1293 lines
45 KiB
ObjectPascal
Raw Blame History

unit KOLmdvDBF;
// Êîìïîíåíò mdvDBF - ïðÿìîé äîñòóï ê DBF-ôàéëàì (ñ memo) áåç èñïîëüçîâàíèÿ äîïîëíèòåëüíîãî ÏÎ.
// E-Mail: dominiko-m@yandex.ru
// http://www.mdvkol.narod.ru/
// Àâòîð: Ìàòâååâ Äìèòðèé
// - Èñòîðèÿ -
// Äàòà: 01.03.2007 Âåðñèÿ: 1.03
{
[+] - äîáàâèë ìåòîä NewDbf
[*] - Ïîïðàâèë ñèãíàòóðó ìåìî-ïîëåé äëÿ dBaseIV
}
// Äàòà: 26.09.2005 Âåðñèÿ: 1.02
{
[+] - äîáàâèë íåñêîëüêî âñïîìîãàòåëüíûõ ìåòîäîâ
}
// Äàòà: 07.12.2004 Âåðñèÿ: 1.01
{
[+] - äîáàâèë ñèãíàòóðó ìåìî-ïîëåé
}
// Äàòà: 02.12.2004 Âåðñèÿ: 1.00
{Ñòàðòîâàÿ âåðñèÿ}
interface
uses Windows, KOL;
const
DBF_FoxBASE = $02;
DBF_FoxBASE_ = $FB;
DBF_dBaseIIIplus = $03;
DBF_dBaseIIIplusMemo = $83;
DBF_dBaseIV = $04;
DBF_dBaseIVSQLtable = $43;
DBF_dBaseIVSQLsystem = $63;
DBF_dBaseIVSQLtableMemo = $CB;
DBF_dBaseIVMemo = $8B;
DBF_dBaseV = $05;
DBF_FoxPro2xMemo = $F5;
DBF_VisualFoxPro = $30;
DBF_VisualFoxProInc = $31;
MsDos_US_437 = $01;
MsDos_Mazovia_Polish_620 = $69;
MsDos_Greek_737 = $6A;
MsDos_International_850 = $02;
MsDos_Eastern_European_852 = $64;
MsDos_Turkish_857 = $6B;
MsDos_Icelandic_861 = $67;
MsDos_Nordic_865 = $66;
MsDos_Russian_866 = $65;
MsDos_Kamenicky_Czech_895 = $68;
Windows_Thai_874 = $7C;
Windows_Japanese_932 = $7B;
Windows_Chinese_PRC_Singapore_936 = $7A;
Windows_Korean_949 = $79;
Windows_Chinese_HongKongSAR_Taiwan_950 = $78;
Windows_Eastern_European_1250 = $C8;
Windows_Russian_1251 = $C9;
Windows_ANSI_1252 = $03;
Windows_Greek_1253 = $CB;
Windows_Turkish_1254 = $CA;
Windows_Hebrew_1255 = $7D;
Windows_Arabic_1256 = $7E;
Windows_Standard_Macintosh_10000 = $04;
Windows_Greek_Macintosh_10006 = $98;
Windows_Russian_Macintosh_10007 = $96;
Windows_Macintosh_EE_10029 = $97;
type
TYYMMDD = array [1..3] of Byte;
TDBFHeader = packed record
DBFType: Byte; // Òèï ôàéëà (DBF_xxx)
LastUpdated: TYYMMDD; // Äàòà ïîñëåäíåãî îáíîâëåíèÿ â ôîðìàòå YYMMDD
RecordCount: DWord; // Êîëè÷åñòâî çàïèñåé â òàáëèöå
HeaderLength: Word; // Êîëè÷åñòâî áàéò, çàíèìàåìûõ çàãîëîâêîì
RecordLength: Word; // Êîëè÷åñòâî áàéò, çàíèìàåìûõ çàïèñüþ
Reserved_1: array [1..16] of Byte; // 3-Çàðåçåðâèðîâàííàÿ îáëàñòü; 13 - Çàðåçåðâèðîâàíî äëÿ ñåòåâîé âåðñèè dBASE III PLUS
TableFlags: Byte; // $01 - file has a structural .cdx; $02 - file has a Memo field; $04 - file is a database (.dbc). This byte can contain the sum of any of the above values. For example, the value 0x03 indicates the table has a structural .cdx and a Memo field.
CodePage: Byte; // Êîäîâàÿ ñòðàíèöà
Reserved_2: Word; // Çàðåçåðâèðîâàííàÿ îáëàñòü
end;
TFieldName = array [1..11] of Char;
TDBFField = packed record
FieldName: TFieldName; // Íàçâàíèå ïîëÿ
FieldType: Char; // Òèï ïîëÿ (C – Character; Y – Currency; N – Numeric; F – Float; D – Date; T – DateTime; B – Double; I – Integer; L – Logical; M – Memo; G – General; C – Character (binary); M – Memo (binary); P – Picture;
Address: DWord; // Àäðåñ ïîëÿ â çàïèñè
FieldLength: Byte; // Äëèíà ïîëÿ (â áàéòàõ)
Decimals: Byte; // Äëèíà äåñÿòè÷íîé ÷àñòè
FieldFlags: Byte; // Ôëàã ïîëÿ ($01 - System Column (not visible to user); $02 - Column can store null values; $04 - Binary column (for CHAR and MEMO only); $06($02+$04) - When a field is NULL and binary (Integer, Currency, and Character/Memo fields); $0C - Column is autoincrementing;
AutoIncNext: DWord; // Ñëåäóþùåå çíà÷åíèå äëÿ Àâòîèíêðèìåíòà
AutoIncStep: Byte; // Øàã Àâòîèíêðèìåíòà
Reserved3 : array[1..7] of Byte; // Çàðåçåðâèðîâàííàÿ îáëàñòü
IndexFlag : Byte; // Ôëàã MDX-ïîëÿ: $01 åñëè ïîëå èìååò ìåòêó èíäåêñà â MDX-ôàéëå, $00 - íåò.
end;
TFPTHeader = packed record
NextFree: DWord; // * Location of next free block
Unused: Word; // Unused
BlockSize: Word; // * Block size (bytes per block)
Unused_2: array [0..503] of Byte;
end;
TDBTHeader = packed record
NextFree: DWord; // Location of next free block
Reserved1: DWord;
DbfFileName: array [1..9] of Char; // Name parent DBF table
reserved2: array [1..3] of Char;
BlockSize: Word;
end;
TMemoBlockHeader = packed record
BlockSignature: DWord; // * Block signature (indicates the type of data in the block) (0 – picture (picture field type); 1 – text (memo field type))
Length: DWord; // * Length of memo (in bytes)
//08–n Memo text (n = length)
end;
PRecordBuffer = ^TRecordBuffer;
TRecordBuffer = array[0..0] of Byte;
PDBFFields = ^TDBFFields;
TDBFFields = array [0..0] of TDBFField;
TFieldType = (ftUnknown, ftCharacter, ftCurrency, ftNumeric,
ftFloat, ftDate, ftDateTime, ftBinary,
ftInteger, ftLogical, ftMemo, ftGeneral,
ftCharacterBin, ftMemoBin, ftPicture);
TDbfErrors = (eNoErrors, eUnknownError, eFileNotExist, eFileOpen, eDBFHeader, eAppendRecord, eReadRecord, eWriteRecord, eReadField, eWriteField, eInvalidValue);
TOnDbfEvent = procedure(Sender: PObj; var Allowed: Boolean) of object;
TMemoType = (mtUnknown, mtFoxPro, mtdBaseIV, mtdBase);
PmdvDBF = ^TmdvDBF;
TKOLmdvDBF = PmdvDBF;
TmdvDBF = object(TObj)
private
FDBFHeader: TDBFHeader;
FDBFFields: PDBFFields;
FRecordBuffer: PRecordBuffer;
FFieldsCount: Integer;
FFPTHeader: TFPTHeader;
FDBTHeader: TDBTHeader;
FHasMemo: Boolean;
FActive, FAutoUpdate, FReadOnly, FDBFModified, FRecordModified: Boolean;
FFileName: String;
FFileNameMemo: String;
FDBFStream, FDBFMemoStream: PStream;
FCurrentRecord: DWord;
FBOF, FEOF: Boolean;
FError: TDbfErrors;
FOnScroll, FOnDelete, FOnAppend: TOnDbfEvent;
function InvertDWord(var Value: DWord): DWord;
function ReadFields: Boolean;
procedure ReadRecord;
procedure WriteRecord;
procedure SetDate(var ADate: TYYMMDD);
function GetLastUpdated: TDateTime;
function GetHasMemo: Boolean;
function GetMemoInfo(Index: Integer; var ABlockNum, ABlockSize, ABlockCount, ASize: DWord): TMemoType;
procedure SetActive(const Value: Boolean);
procedure SetFileName(const Value: String);
function GetError: TDbfErrors;
function GetFieldName(Index: Integer): String;
function GetFieldNumber(NameField: String): Integer;
function GetFieldType(Index: Integer): TFieldType;
function GetFieldDecimals(Index: Integer): Byte;
function GetFieldLength(Index: Integer): Byte;
procedure SetCurrentRecord(const Value: DWord);
function GetIsDelete: Boolean;
procedure SetIsDelete(const Value: Boolean);
function GetFieldIsString(Index: Integer): Boolean;
function GetFieldIsBoolean(Index: Integer): Boolean;
function GetFieldIsDateTime(Index: Integer): Boolean;
function GetFieldIsFloat(Index: Integer): Boolean;
function GetFieldIsInteger(Index: Integer): Boolean;
function GetAsText(Index: Integer): String;
function GetAsString(Index: Integer): String;
function GetAsBoolean(Index: Integer): Boolean;
function GetAsDateTime(Index: Integer): TDateTime;
function GetAsFloat(Index: Integer): Double;
function GetAsInteger(Index: Integer): Integer;
procedure SetString(Index: Integer; Value: String);
procedure SetAsText(Index: Integer; Value: String);
procedure SetAsString(Index: Integer; const Value: String);
procedure SetAsBoolean(Index: Integer; const Value: Boolean);
procedure SetAsDateTime(Index: Integer; const Value: TDateTime);
procedure SetAsFloat(Index: Integer; const Value: Double);
procedure SetAsInteger(Index: Integer; const Value: Integer);
function GetFieldIsNull(Index: Integer): Boolean;
function GetFieldIsMemo(Index: Integer): Boolean;
function GetMemoAsString(Index: Integer): String;
procedure SetMemoAsString(Index: Integer; Value: String);
function GetAsBooleanByName(AFieldName: String): Boolean;
function GetAsDateTimeByName(AFieldName: String): TDateTime;
function GetAsFloatByName(AFieldName: String): Double;
function GetAsIntegerByName(AFieldName: String): Integer;
function GetAsStringByName(AFieldName: String): String;
function GetAsTextByName(AFieldName: String): String;
procedure SetAsBooleanByName(AFieldName: String; const Value: Boolean);
procedure SetAsDateTimeByName(AFieldName: String; const Value: TDateTime);
procedure SetAsFloatByName(AFieldName: String; const Value: Double);
procedure SetAsIntegerByName(AFieldName: String; const Value: Integer);
procedure SetAsStringByName(AFieldName: String; const Value: String);
procedure SetAsTextByName(AFieldName: String; const Value: String);
function GetMemoAsStringByName(AFieldName: String): String;
procedure SetMemoAsStringByName(AFieldName: String; const Value: String);
public
destructor Destroy; virtual;
property DBFType: Byte read FDBFHeader.DBFType; // Òèï ôàéëà (DBF_xxx)
property LastUpdated: TDateTime read GetLastUpdated; // Äàòà ïîñëåäíåãî îáíîâëåíèÿ
property RecordLength: Word read FDBFHeader.RecordLength; // Êîëè÷åñòâî áàéòîâ, çàíèìàåìûõ çàïèñüþ
property HasMemo: Boolean read GetHasMemo;
property CodePage: Byte read FDBFHeader.CodePage;
property FieldsCount: Integer read FFieldsCount;
property FieldName[Index: Integer]: String read GetFieldName;
property FieldNumber[NameField: String]: Integer read GetFieldNumber;
property FieldType[Index: Integer]: TFieldType read GetFieldType;
property FieldLength[Index: Integer]: Byte read GetFieldLength;
property FieldDecimals[Index: Integer]: Byte read GetFieldDecimals;
property RecordCount: DWord read FDBFHeader.RecordCount; // Êîëè÷åñòâî çàïèñåé â òàáëèöå
property CurrentRecord: DWord read FCurrentRecord write SetCurrentRecord;
property BOF: Boolean read FBOF;
property EOF: Boolean read FEOF;
procedure First;
procedure Last;
procedure Next;
procedure Prev;
function Locate(AFieldName, AValue: String): Boolean; overload;
function Locate(AFieldNames, AValues: array of String): Boolean; overload;
function MaxOfField(AFieldName: String): Integer;
procedure Append;
procedure Post;
property IsDelete: Boolean read GetIsDelete write SetIsDelete;
procedure RefreshRecord;
procedure PackDBF;
{ DescriptionDBF format:
<CodePage>#2<BlockSize>#1
<FieldName1>#2<FieldType1>#2<FieldLength1>#2<Decimals1>#1
<FieldName2>#2<FieldType2>#2<FieldLength2>#2<Decimals2>#1
...
<FieldNameN>#2<FieldTypeN>#2<FieldLengthN>#2<DecimalsN>#1
BlockSize: recommend values 64, 128, 256, 512, 1024, 2048;
FieldName: max length: 10
FieldType: 'C' - Character; 'N' - Numeric; 'D' - Date; 'B' - Binary; 'L' - Logical, 'M' - Memo
FieldLength: 'C' - 1..254; 'N' - 1..20; 'D' - 8; 'L' - 1; 'M' - 10; 'B' - 10
Decimals: 'C' - 0; 'N' - 0..FieldLength-1; 'D' - 0; 'L' - 0; 'M' - 0; 'B' - 0
}
function NewDbf(AFileName: String; DescriptionDBF: String): Boolean;
property FieldIsString[Index: Integer]: Boolean read GetFieldIsString;
property FieldIsInteger[Index: Integer]: Boolean read GetFieldIsInteger;
property FieldIsFloat[Index: Integer]: Boolean read GetFieldIsFloat;
property FieldIsDateTime[Index: Integer]: Boolean read GetFieldIsDateTime;
property FieldIsBoolean[Index: Integer]: Boolean read GetFieldIsBoolean;
property FieldIsNull[Index: Integer]: Boolean read GetFieldIsNull;
property AsText[Index: Integer]: String read GetAsText write SetAsText;
property AsString[Index: Integer]: String read GetAsString write SetAsString;
property AsInteger[Index: Integer]: Integer read GetAsInteger write SetAsInteger;
property AsFloat[Index: Integer]: Double read GetAsFloat write SetAsFloat;
property AsDateTime[Index: Integer]: TDateTime read GetAsDateTime write SetAsDateTime;
property AsBoolean[Index: Integer]: Boolean read GetAsBoolean write SetAsBoolean;
property AsTextByName[FieldName: String]: String read GetAsTextByName write SetAsTextByName;
property AsStringByName[FieldName: String]: String read GetAsStringByName write SetAsStringByName;
property AsIntegerByName[FieldName: String]: Integer read GetAsIntegerByName write SetAsIntegerByName;
property AsFloatByName[FieldName: String]: Double read GetAsFloatByName write SetAsFloatByName;
property AsDateTimeByName[FieldName: String]: TDateTime read GetAsDateTimeByName write SetAsDateTimeByName;
property AsBooleanByName[FieldName: String]: Boolean read GetAsBooleanByName write SetAsBooleanByName;
procedure GetValue(Index: Integer; var Value);
procedure SetValue(Index: Integer; var Value);
property FieldIsMemo[Index: Integer]: Boolean read GetFieldIsMemo;
property MemoAsString[Index: Integer]: String read GetMemoAsString write SetMemoAsString;
property MemoAsStringByName[FieldName: String]: String read GetMemoAsStringByName write SetMemoAsStringByName;
function GetMemoValue(Index: Integer; var Value: Pointer): DWord;
procedure SetMemoValue(Index: Integer; Value: Pointer; ACount: DWord; ASigna: DWord = 0);
{ ??????? ftUnknown, ftCharacterBin, ftMemoBin, ftCurrency, ftInteger, }
property Active: Boolean read FActive write SetActive;
property AutoUpdate: Boolean read FAutoUpdate write FAutoUpdate;
Property DBFModified: boolean read FDBFModified;
property FileName: String read FFileName write SetFileName;
property FileNameMemo: String read FFileNameMemo write FFileNameMemo;
property Error: TDbfErrors read GetError;
property OnScroll: TOnDbfEvent read FOnScroll write FOnScroll;
property OnDelete: TOnDbfEvent read FOnDelete write FOnDelete;
property OnAppend: TOnDbfEvent read FOnAppend write FOnAppend;
end;
function NewmdvDBF(AFileName: String; AutoUpdate: Boolean; ReadOnly: Boolean = False): TKOLmdvDBF;
implementation
function NewmdvDBF(AFileName: String; AutoUpdate: Boolean; ReadOnly: Boolean = False): TKOLmdvDBF;
begin
New(Result, Create);
Result.FAutoUpdate:= AutoUpdate;
Result.FFileName:= AFileName;
Result.FReadOnly:= ReadOnly;
end;
{ TmdvDBF }
procedure TmdvDBF.Append;
var Allowed: Boolean;
begin
if not FActive or FReadOnly then Exit;
if FAutoUpdate then Post;
Allowed:= True;
if Assigned(FOnAppend) then FOnAppend(@Self, Allowed);
if not Allowed then Exit;
FDBFHeader.RecordCount:= FDBFHeader.RecordCount + 1;
try
FDBFStream.Seek(0, spBegin); FDBFStream.Write(FDBFHeader, SizeOf(FDBFHeader));
FCurrentRecord:= FDBFHeader.RecordCount-1;
FillMemory(FRecordBuffer, FDBFHeader.RecordLength, $20);
FRecordModified:= True;
Post;
except
FError:= eAppendRecord;
FDBFHeader.RecordCount:= FDBFHeader.RecordCount-1;
end;
end;
destructor TmdvDBF.Destroy;
begin
Active:= False;
inherited;
end;
procedure TmdvDBF.First;
begin
SetCurrentRecord(0);
FBOF:= FCurrentRecord=0; FEOF:= False;
end;
function TmdvDBF.GetAsBoolean(Index: Integer): Boolean;
begin
Result:= False;
try
if not FieldIsString[Index] then Exit;
Result:= (AsText[Index][1] in ['T', 't', 'Y', 'y'])
except
FError:= eReadField;
end;
end;
function TmdvDBF.GetAsDateTime(Index: Integer): TDateTime;
var SS, S: String;
begin
Result:= 0;
try
if not FieldIsDateTime[Index] then Exit;
SetLength(S, 14);
FillMemory(PChar(S), 14, Byte('0'));
SS:= AsText[Index];
Move(SS[1], S[1], Length(SS));
Result:= Str2DateTimeFmt('yyyyMMddHHmmss', S);
except
FError:= eReadField;
end;
end;
function TmdvDBF.GetAsFloat(Index: Integer): Double;
begin
Result:= 0;
try
if not FieldIsFloat[Index] then Exit;
Result:= Str2Double(Trim(AsText[Index]));
except
FError:= eReadField;
end;
end;
function TmdvDBF.GetAsInteger(Index: Integer): Integer;
begin
Result:= 0;
try
if not FieldIsInteger[Index] then Exit;
Result:= Str2Int(Trim(AsText[Index]));
except
FError:= eReadField;
end;
end;
function TmdvDBF.GetAsString(Index: Integer): String;
var S: String;
D: TDateTime;
begin
Result:= '';
try
if not FieldIsString[Index] then Exit;
S:= AsText[Index];
case FieldType[Index] of
ftCharacter: Result:= TrimRight(S);
ftDate, ftDateTime: begin
D:= AsDateTime[Index];
Result:= Date2StrFmt('dd.MM.yyyy', D);
if FieldType[Index] = ftDateTime then
Result:= Result + Time2StrFmt(' HH:mm:ss', D);
end;
ftLogical: if S[1] in ['T', 't', 'Y', 'y', 'F', 'f', 'N', 'n'] then Result:= S[1] else Result:= 'F';
ftFloat, ftNumeric: begin
Result:= Double2Str(AsFloat[Index]);
end;
end;
except
FError:= eReadField;
end;
end;
function TmdvDBF.GetError: TDbfErrors;
begin
Result:= FError;
FError:= eNoErrors;
end;
function TmdvDBF.GetFieldDecimals(Index: Integer): Byte;
begin
Result:= FDBFFields[Index].Decimals;
end;
function TmdvDBF.GetFieldIsBoolean(Index: Integer): Boolean;
begin
Result:= FieldType[Index] = ftLogical;
end;
function TmdvDBF.GetFieldIsDateTime(Index: Integer): Boolean;
begin
Result:= FieldType[Index] in [ftDate, ftDateTime];
end;
function TmdvDBF.GetFieldIsFloat(Index: Integer): Boolean;
begin
Result:= FieldType[Index] in [ftFloat, ftNumeric];
end;
function TmdvDBF.GetFieldIsInteger(Index: Integer): Boolean;
begin
Result:= (FieldType[Index] in [ftFloat, ftNumeric])and(FDBFFields[Index].Decimals = 0);
end;
function TmdvDBF.GetFieldIsMemo(Index: Integer): Boolean;
begin
Result:= FieldType[Index] in [ftMemo, ftGeneral, ftBinary, ftPicture];
end;
function TmdvDBF.GetFieldIsNull(Index: Integer): Boolean;
begin
Result:= ((FDBFFields[Index].FieldFlags and $02) = $02);
end;
function TmdvDBF.GetFieldIsString(Index: Integer): Boolean;
begin
Result:= FieldType[Index] in [ftCharacter, ftDate, ftLogical, ftFloat, ftNumeric, ftDateTime];
end;
function TmdvDBF.GetFieldLength(Index: Integer): Byte;
begin
Result:= FDBFFields[Index].FieldLength;
end;
function TmdvDBF.GetFieldName(Index: Integer): String;
begin
Result:= FDBFFields[Index].FieldName;
end;
function TmdvDBF.GetFieldNumber(NameField: String): Integer;
var i: Integer;
begin
Result:= -1;
for i:= 0 to FFieldsCount-1 do
if String(PChar(@FDBFFields[i].FieldName)) = NameField then begin
Result:= i; Break;
end;
end;
function TmdvDBF.GetFieldType(Index: Integer): TFieldType;
begin
case FDBFFields[Index].FieldType of
'C': if (FDBFFields[Index].FieldFlags and $04)=$04 then Result:= ftCharacterBin else Result:= ftCharacter;
'Y': Result:= ftCurrency;
'N': Result:= ftNumeric;
'F': Result:= ftFloat;
'D': Result:= ftDate;
'T': Result:= ftDateTime;
'B': Result:= ftBinary;
'I': Result:= ftInteger;
'L': Result:= ftLogical;
'M': if (FDBFFields[Index].FieldFlags and $04)=$04 then Result:= ftMemoBin else Result:= ftMemo;
'G': Result:= ftGeneral;
'P': Result:= ftPicture;
else Result:= ftUnknown;
end;
end;
function TmdvDBF.GetHasMemo: Boolean;
begin
Result:= FDBFHeader.TableFlags and $02 = $02;
end;
function TmdvDBF.InvertDWord(var Value: DWord): DWord;
type TB = array[0..3] of Byte;
begin
TB(Result)[0]:= TB(Value)[3];
TB(Result)[1]:= TB(Value)[2];
TB(Result)[2]:= TB(Value)[1];
TB(Result)[3]:= TB(Value)[0];
end;
function TmdvDBF.GetIsDelete: Boolean;
begin
Result:= False;
if not FActive then Exit;
Result:= (FRecordBuffer^[0] = $2A)
end;
function TmdvDBF.GetLastUpdated: TDateTime;
begin
EncodeDate(FDBFHeader.LastUpdated[1], FDBFHeader.LastUpdated[2], FDBFHeader.LastUpdated[3], Result);
end;
function TmdvDBF.GetMemoAsString(Index: Integer): String;
var P: Pointer;
Sz: DWord;
begin
Sz:= GetMemoValue(Index, P);
SetLength(Result, Sz);
if Sz > 0 then begin
Move(P^, Result[1], Sz);
DisposeMem(P);
end;
end;
function TmdvDBF.GetMemoValue(Index: Integer; var Value: Pointer): DWord;
var BlockNum, BlockSize, BlockCount: DWord;
k: Integer;
MemoType: TMemoType;
begin
Value:= nil; Result:= 0;
MemoType:= GetMemoInfo(Index, BlockNum, BlockSize, BlockCount, Result);
if (BlockCount = 0) or (BlockNum = 0) or (MemoType = mtUnknown) then Exit;
case MemoType of
mtFoxPro, mtdBaseIV: begin
FDBFMemoStream.Seek(BlockNum * BlockSize+SizeOf(TMemoBlockHeader), spBegin);
Value:= AllocMem(Result);
FDBFMemoStream.Read(Value^, Result);
end;
mtdBase: begin
FDBFMemoStream.Seek(BlockNum * BlockSize, spBegin);
Result:= 0;
repeat
inc(Result, BlockSize); ReallocMem(Value, Result+1);
FDBFMemoStream.Read(PChar(Value)[Result-512], BlockSize);
PChar(Value)[Result+1]:= #0;
k:= Pos(#$1A, PChar(Value));
if k>0 then begin
Result:= k-1;
ReallocMem(Value, Result);
Break;
end;
until FDBFMemoStream.Position >= FDBFMemoStream.Size;
end;
end;
end;
procedure TmdvDBF.GetValue(Index: Integer; var Value);
begin
try
Move(FRecordBuffer^[FDBFFields[Index].Address], Value, FDBFFields[Index].FieldLength);
except
FError:= eReadField;
end;
end;
procedure TmdvDBF.Last;
begin
SetCurrentRecord(FDBFHeader.RecordCount-1);
FBOF:= False; FEOF:= FCurrentRecord = FDBFHeader.RecordCount-1;
end;
procedure TmdvDBF.Next;
begin
SetCurrentRecord(FCurrentRecord+1);
FBOF:= False; FEOF:= FCurrentRecord = FDBFHeader.RecordCount-1;
end;
procedure TmdvDBF.Post;
begin
if FRecordModified then WriteRecord;
end;
procedure TmdvDBF.Prev;
begin
SetCurrentRecord(FCurrentRecord-1);
FBOF:= FCurrentRecord=0; FEOF:= False;
end;
function TmdvDBF.ReadFields: Boolean;
var DBFField: TDBFField;
Addr: DWord;
begin
try
Result:= True;
FFieldsCount:= 0;
FDBFFields:= AllocMem(SizeOf(TDBFField)*((FDBFHeader.HeaderLength - SizeOf(TDBFHeader)) div SizeOf(TDBFField)));
FDBFStream.Seek(SizeOf(TDBFHeader), spBegin); FHasMemo:= False;
Addr:= 1;
repeat
FDBFStream.Read(DBFField, SizeOf(TDBFField));
if DBFField.FieldName[1] <> #13 then begin
if DBFField.Address = 0 then DBFField.Address:= Addr;
FDBFFields[FFieldsCount]:= DBFField;
FHasMemo:= FHasMemo or FieldIsMemo[FFieldsCount];
inc(FFieldsCount);
end;
inc(Addr, DBFField.FieldLength);
until DBFField.FieldName[1] = #13;
except
Result:= False;
FError:= eDBFHeader;
end;
end;
procedure TmdvDBF.ReadRecord;
Begin
if not FActive then Exit;
try
FDBFStream.Seek(FDBFHeader.HeaderLength + FCurrentRecord*FDBFHeader.RecordLength, spBegin);
FDBFStream.Read(FRecordBuffer^, FDBFHeader.RecordLength);
FRecordModified := False;
except
FError:= eReadRecord;
end;
end;
procedure TmdvDBF.RefreshRecord;
begin
if not FActive then Exit;
ReadRecord;
end;
procedure TmdvDBF.SetActive(const Value: Boolean);
const ReadWrite: array [Boolean] of DWord = (ofOpenReadWrite, ofOpenRead);
// Stream: PStream;
begin
if Value = FActive then Exit;
if Value then begin
if not FileExists(FFileName) then begin FError:= eFileNotExist; Exit; end;
FDBFStream:= NewFileStream(FFileName, ReadWrite[FReadOnly] or ofShareDenyNone or{ofShareDenyWrite or }ofOpenExisting);
if FDBFStream.Handle = 0 then begin FError:= eFileOpen; Exit; end;
{FDBFStream:= NewMemoryStream;
Stream:= NewReadFileStream(FFileName);
FDBFStream.Size:= Stream.Size;
Stream.Read(FDBFStream.Memory^, Stream.Size);
Stream.Free;}
FDBFStream.Read(FDBFHeader, SizeOf(TDBFHeader));
if not ReadFields then Exit;
FRecordBuffer:= AllocMem(FDBFHeader.RecordLength);
if FHasMemo then begin
if not FileExists(FFileNameMemo) then begin
FFileNameMemo:= ChangeFileExt(FFileName, '.fpt');
if not FileExists(FFileNameMemo) then begin
FFileNameMemo:= ChangeFileExt(FFileName, '.dbt');
if not FileExists(FFileNameMemo) then begin
FFileNameMemo:= '';
end;
end;
end;
if FFileNameMemo <> '' then begin
FDBFMemoStream:= NewFileStream(FFileNameMemo, ReadWrite[FReadOnly] {or ofShareDenyWrite }or ofShareDenyNone or ofOpenExisting);
{FDBFMemoStream:= NewMemoryStream;
Stream:= NewReadFileStream(FFileNameMemo);
FDBFMemoStream.Size:= Stream.Size;
Stream.Read(FDBFMemoStream.Memory^, Stream.Size);
Stream.Free;}
if FDBFHeader.DBFType in [DBF_FoxPro2xMemo, DBF_VisualFoxPro, DBF_VisualFoxProInc] then FDBFMemoStream.Read(FFPTHeader, SizeOf(TFPTHeader))
else FDBFMemoStream.Read(FDBTHeader, SizeOf(TDBTHeader));
end
else FHasMemo:= False;
end;
FCurrentRecord:= 0; FDBFModified:= False; FRecordModified:= False;
FEOF:= False; FBOF:= False;
FActive := True;
end
else begin
if FAutoUpdate then Post;
if FDBFModified and not FReadOnly then begin
SetDate(FDBFHeader.LastUpdated);
FDBFStream.Seek(0, spBegin); FDBFStream.Write(FDBFHeader, SizeOf(TDBFHeader));
end;
DisposeMem(Pointer(FDBFFields));
DisposeMem(Pointer(FRecordBuffer));
FDBFStream.Free;
if FHasMemo then FDBFMemoStream.Free;
FFileNameMemo:= '';
FActive := False;
end
end;
procedure TmdvDBF.SetAsBoolean(Index: Integer; const Value: Boolean);
begin
if Value then AsString[Index]:= 'T' else AsString[Index]:= 'F';
end;
procedure TmdvDBF.SetAsDateTime(Index: Integer; const Value: TDateTime);
begin
AsString[Index]:= Date2StrFmt('yyyyMMdd', Value)+Time2StrFmt('HHmmss', Value);
end;
procedure TmdvDBF.SetAsFloat(Index: Integer; const Value: Double);
begin
AsString[Index]:= Double2Str(Value);
end;
procedure TmdvDBF.SetAsInteger(Index: Integer; const Value: Integer);
begin
AsString[Index]:= Int2Str(Value);
end;
procedure TmdvDBF.SetAsString(Index: Integer; const Value: String);
var S, SS, I: String;
ValidValue: Boolean;
lI, lp, lF, k: Integer;
D: TDateTime;
begin
try
S:= Value;
ValidValue:= False;
case FieldType[Index] of
ftCharacter: begin
ValidValue:= True;
end;
ftDate, ftDateTime: begin
D:= Str2DateTimeFmt('yyyyMMddHHmmss', Value); S:= Value;
ValidValue:= (Value = Date2StrFmt('yyyyMMdd', D)+Time2StrFmt('HHmmss', D));
end;
ftLogical: begin
ValidValue:= (Length(Value)=1);
if ValidValue then ValidValue:= Value[1] in ['T', 't', 'Y', 'y', 'F', 'f', 'N', 'n'];
end;
ftFloat, ftNumeric: begin
SS:= Trim(Value);
ValidValue:= Double2Str((Str2Double(SS))) = SS;
if ValidValue then begin
lP:= FDBFFields[Index].FieldLength - FDBFFields[Index].Decimals;
lI:= FDBFFields[Index].FieldLength - FDBFFields[Index].Decimals - 1;
lF:= FDBFFields[Index].Decimals;
if FDBFFields[Index].Decimals = 0 then begin
lI:= FDBFFields[Index].FieldLength; lF:= 0; lP:= 0;
end;
if FDBFFields[Index].FieldLength <= FDBFFields[Index].Decimals then begin
lI:= 0; lF:= FDBFFields[Index].FieldLength; lP:= 0;
end;
if lP > 0 then S:= '.' else S:='';
I:= Parse(SS, '.');
lP:= Min(Length(I), lI);
SetLength(I, lP);
for k:= lP to lI-1 do I:= ' '+I;
lP:= Min(Length(SS), lF);
SetLength(SS, lP);
for k:= lP to lF-1 do SS:= SS+'0';
S:= I+S+SS;
end;
end;
end;
if ValidValue then begin
FillMemory(@(FRecordBuffer^[FDBFFields[Index].Address]), FDBFFields[Index].FieldLength, Byte(' '));
SetString(Index, S);
end
else FError:= eInvalidValue;
except
FError:= eWriteField;
end;
end;
procedure TmdvDBF.SetCurrentRecord(const Value: DWord);
var Allowed: Boolean;
begin
if not FActive then Exit;
Allowed:= True;
if Assigned(FOnScroll) then FOnScroll(@Self, Allowed);
if not Allowed then Exit;
if FAutoUpdate then Post;
FCurrentRecord := Max(0, Min(FDBFHeader.RecordCount-1, Value));
ReadRecord;
end;
procedure TmdvDBF.SetFileName(const Value: String);
begin
if FFileName <> Value then begin
Active:= False;
FFileName := Value;
end;
end;
procedure TmdvDBF.SetIsDelete(const Value: Boolean);
const DelFlag: array [Boolean] of Byte = ($20, $2A);
var Allowed: Boolean;
begin
if not FActive then Exit;
Allowed:= True;
if Assigned(FOnDelete) then FOnDelete(@Self, Allowed);
if not Allowed then Exit;
FRecordBuffer^[0] := DelFlag[Value];
FRecordModified:= True;
end;
procedure TmdvDBF.SetMemoAsString(Index: Integer; Value: String);
begin
SetMemoValue(Index, PChar(Value), Length(Value), 1);
end;
procedure TmdvDBF.SetMemoValue(Index: Integer; Value: Pointer; ACount: DWord; ASigna: DWord = 0);
var BSize, BlockNum, BlockSize, BlockCount, Size, mh: DWord;
MemoType: TMemoType;
MemoBlockHeader: TMemoBlockHeader;
S: String;
begin
if FReadOnly then Exit;
MemoType:= GetMemoInfo(Index, BlockNum, BlockSize, BlockCount, Size);
if (BlockCount = 0) or (MemoType = mtUnknown) then Exit;
if MemoType <> mtdBase then mh:= SizeOf(TMemoBlockHeader) else mh:= 1;
BSize:= Size+mh;
BSize:= (BSize div BlockSize)*BlockSize + BlockSize*DWord(Ord((BSize mod BlockSize)>0));
if (BlockNum = 0) or (BSize < ACount + mh) then begin
BSize:= ACount + mh;
BSize:= (BSize div BlockSize)*BlockSize + BlockSize*DWord(Ord((BSize mod BlockSize)>0));
BlockNum:= BlockCount;
BlockCount:= BlockCount + BSize div BlockSize;
end;
FDBFMemoStream.Size:= BlockCount * BlockSize;
FDBFMemoStream.Seek(0, spBegin);
if MemoType = mtFoxPro then begin
MemoBlockHeader.Length:= InvertDWord(ACount);
MemoBlockHeader.BlockSignature:= InvertDWord(ASigna);
FFPTHeader.NextFree:= InvertDWord(BlockCount);
FDBFMemoStream.Write(FFPTHeader, SizeOf(TFPTHeader));
end
else begin
MemoBlockHeader.Length:= ACount + 8;
if MemoType = mtdBaseIV then MemoBlockHeader.BlockSignature:= $08FFFF
else MemoBlockHeader.BlockSignature:= ASigna;
FDBTHeader.NextFree:= BlockCount;
FDBFMemoStream.Write(FDBTHeader, SizeOf(TDBTHeader));
end;
if FDBFFields[Index].FieldLength = 4 then
SetValue(Index, BlockNum)
else begin
S:= Int2Str(BlockNum);
for mh:= Length(S)+1 to FDBFFields[Index].FieldLength do S:= ' '+S;
SetValue(Index, S[1]);
end;
Post;
case MemoType of
mtFoxPro, mtdBaseIV: begin
FDBFMemoStream.Seek(BlockNum * BlockSize, spBegin);
FDBFMemoStream.Write(MemoBlockHeader, SizeOf(TMemoBlockHeader));
FDBFMemoStream.Write(Value^, ACount);
end;
mtdBase: begin
FDBFMemoStream.Seek(BlockNum * BlockSize, spBegin);
FDBFMemoStream.Write(Value^, ACount);
S:= #$1A;
FDBFMemoStream.Write(S[1], 1);
end;
end;
end;
procedure TmdvDBF.SetString(Index: Integer; Value: String);
begin
try
Move(Value[1], FRecordBuffer^[FDBFFields[Index].Address], Min(Length(Value), FDBFFields[Index].FieldLength));
FDBFModified:= True;
FRecordModified:= True;
except
FError:= eWriteField;
end;
end;
procedure TmdvDBF.SetValue(Index: Integer; var Value);
begin
try
Move(Value, FRecordBuffer^[FDBFFields[Index].Address], FDBFFields[Index].FieldLength);
FDBFModified:= True;
FRecordModified:= True;
except
FError:= eWriteField;
end;
end;
procedure TmdvDBF.WriteRecord;
Begin
if not FActive or FReadOnly then Exit;
try
FDBFStream.Seek(FDBFHeader.HeaderLength + FCurrentRecord*FDBFHeader.RecordLength, spBegin);
FDBFStream.Write(FRecordBuffer^, FDBFHeader.RecordLength);
FRecordModified := False;
FDBFModified:= True;
except
FError:= eWriteRecord;
end;
end;
function TmdvDBF.GetAsText(Index: Integer): String;
begin
Result:= '';
try
if not FieldIsString[Index] then Exit;
SetLength(Result, FDBFFields[Index].FieldLength);
Move(FRecordBuffer^[FDBFFields[Index].Address], Result[1], FDBFFields[Index].FieldLength);
except
FError:= eReadField;
end;
end;
procedure TmdvDBF.SetAsText(Index: Integer; Value: String);
begin
try
FillMemory(@(FRecordBuffer^[FDBFFields[Index].Address]), FDBFFields[Index].FieldLength, Byte(' '));
SetValue(Index, Value[1]);
except
FError:= eWriteField;
end;
end;
function TmdvDBF.GetMemoInfo(Index: Integer; var ABlockNum, ABlockSize, ABlockCount, ASize: DWord): TMemoType;
var S: String;
MemoBlockHeader: TMemoBlockHeader;
begin
ABlockNum:=0; ABlockSize:=0; ABlockCount:=0; ASize:= 0;
Result:= mtUnknown;
if not FieldIsMemo[Index] then Exit;
if FDBFFields[Index].FieldLength = 4 then
Move(FRecordBuffer^[FDBFFields[Index].Address], ABlockNum, 4)
else begin
SetLength(S, FDBFFields[Index].FieldLength);
Move(FRecordBuffer^[FDBFFields[Index].Address], S[1], FDBFFields[Index].FieldLength);
ABlockNum:= Str2Int(Trim(S));
end;
if FDBFHeader.DBFType in [DBF_FoxPro2xMemo, DBF_VisualFoxPro, DBF_VisualFoxProInc] then Result:= mtFoxPro;
if FDBFHeader.DBFType in [DBF_dBaseIV, DBF_dBaseIVSQLtable, DBF_dBaseIVSQLsystem, DBF_dBaseIVSQLtableMemo, DBF_dBaseIVMemo, DBF_dBaseV] then Result:= mtdBaseIV;
if FDBFHeader.DBFType in [DBF_FoxBASE, DBF_FoxBASE_, DBF_dBaseIIIplus, DBF_dBaseIIIplusMemo] then Result:= mtdBase;
ABlockSize:= 512;
ABlockCount:= FDBTHeader.NextFree;
ASize:= 0;
if Result = mtFoxPro then begin
ABlockSize:= System.Swap(FFPTHeader.BlockSize);
ABlockCount:= InvertDWord(FFPTHeader.NextFree);
end;
if Result = mtdBaseIV then begin
ABlockSize:= FDBTHeader.BlockSize;
end;
if ABlockSize = 0 then ABlockSize:= 512;
if ABlockNum = 0 then Exit;
FDBFMemoStream.Seek(ABlockNum * ABlockSize, spBegin);
FDBFMemoStream.Read(MemoBlockHeader, SizeOf(TMemoBlockHeader));
if Result = mtFoxPro then ASize:= InvertDWord(MemoBlockHeader.Length);
if Result = mtdBaseIV then ASize:= MemoBlockHeader.Length - 8;
end;
procedure TmdvDBF.PackDBF;
var ReadPos, WritePos, Rec, RecCount: DWord;
begin
if FReadOnly then Exit;
Post;
ReadPos:= FDBFHeader.HeaderLength; WritePos:= FDBFHeader.HeaderLength;
Rec:= 0; RecCount:= 0;
while Rec < FDBFHeader.RecordCount do begin
FDBFStream.Seek(ReadPos, spBegin);
FDBFStream.Read(FRecordBuffer^, FDBFHeader.RecordLength);
inc(ReadPos, FDBFHeader.RecordLength);
inc(Rec);
if FRecordBuffer^[0] <> $2A then begin
FDBFStream.Seek(WritePos, spBegin);
FDBFStream.Write(FRecordBuffer^, FDBFHeader.RecordLength);
inc(WritePos, FDBFHeader.RecordLength);
inc(RecCount);
end
else FDBFModified:= True;
end;
FDBFStream.Size:= WritePos;
FDBFHeader.RecordCount := RecCount;
FDBFStream.Seek(0, spBegin);
FDBFStream.Write(FDBFHeader, SizeOf(TDBFHeader));
CurrentRecord:= 0;
end;
function TmdvDBF.Locate(AFieldName, AValue: String): Boolean;
var i, FieldNum: Integer;
begin
Result:= False;
FieldNum:= FieldNumber[AFieldName];
if FieldNum<0 then Exit;
for i:= 0 to RecordCount-1 do begin
CurrentRecord:= i;
if IsDelete then Continue;
Result:= AsString[FieldNum] = AValue;
if Result then Break;
end;
end;
function TmdvDBF.Locate(AFieldNames, AValues: array of String): Boolean;
var i, j: Integer;
FieldNums: array of Integer;
begin
Result:= False;
SetLength(FieldNums, Min(Length(AFieldNames), Length(AValues)));
try
for j:= Low(FieldNums) to High(FieldNums) do begin
FieldNums[j]:= FieldNumber[AFieldNames[j]];
if FieldNums[j]<0 then Exit;
end;
for i:= 0 to RecordCount-1 do begin
CurrentRecord:= i;
if IsDelete then Continue;
Result:= True;
for j:= Low(FieldNums) to High(FieldNums) do
Result:= Result and (AsString[FieldNums[j]] = AValues[j]);
if Result then Break;
end;
finally
SetLength(FieldNums, 0);
end;
end;
function TmdvDBF.GetAsBooleanByName(AFieldName: String): Boolean;
begin
Result:= AsBoolean[FieldNumber[AFieldName]];
end;
function TmdvDBF.GetAsDateTimeByName(AFieldName: String): TDateTime;
begin
Result:= AsDateTime[FieldNumber[AFieldName]];
end;
function TmdvDBF.GetAsFloatByName(AFieldName: String): Double;
begin
Result:= AsFloat[FieldNumber[AFieldName]];
end;
function TmdvDBF.GetAsIntegerByName(AFieldName: String): Integer;
begin
Result:= AsInteger[FieldNumber[AFieldName]];
end;
function TmdvDBF.GetAsStringByName(AFieldName: String): String;
begin
Result:= AsString[FieldNumber[AFieldName]];
end;
function TmdvDBF.GetAsTextByName(AFieldName: String): String;
begin
Result:= AsText[FieldNumber[AFieldName]];
end;
procedure TmdvDBF.SetAsBooleanByName(AFieldName: String; const Value: Boolean);
begin
AsBoolean[FieldNumber[AFieldName]]:= Value;
end;
procedure TmdvDBF.SetAsDateTimeByName(AFieldName: String; const Value: TDateTime);
begin
AsDateTime[FieldNumber[AFieldName]]:= Value;
end;
procedure TmdvDBF.SetAsFloatByName(AFieldName: String; const Value: Double);
begin
AsFloat[FieldNumber[AFieldName]]:= Value;
end;
procedure TmdvDBF.SetAsIntegerByName(AFieldName: String; const Value: Integer);
begin
AsInteger[FieldNumber[AFieldName]]:= Value;
end;
procedure TmdvDBF.SetAsStringByName(AFieldName: String; const Value: String);
begin
AsString[FieldNumber[AFieldName]]:= Value;
end;
procedure TmdvDBF.SetAsTextByName(AFieldName: String; const Value: String);
begin
AsText[FieldNumber[AFieldName]]:= Value;
end;
function TmdvDBF.GetMemoAsStringByName(AFieldName: String): String;
begin
Result:= MemoAsString[FieldNumber[AFieldName]];
end;
procedure TmdvDBF.SetMemoAsStringByName(AFieldName: String; const Value: String);
begin
MemoAsString[FieldNumber[AFieldName]]:= Value;
end;
function TmdvDBF.MaxOfField(AFieldName: String): Integer;
var i, FieldNum, k: Integer;
begin
Result:= 0;
FieldNum:= FieldNumber[AFieldName];
k:= CurrentRecord;
if FieldNum<0 then Exit;
for i:= 0 to RecordCount-1 do begin
CurrentRecord:= i;
if IsDelete then Continue;
Result:= Max(Result, AsInteger[FieldNum]);
end;
CurrentRecord:= k;
end;
function TmdvDBF.NewDbf(AFileName: String; DescriptionDBF: String): Boolean;
var IsMemo: Boolean;
i, _FieldsCount, _RecordLength, _BlockSize: Word;
_CodePage: Byte;
_DBFHeader: TDBFHeader;
_DBFFields: PDBFFields;
_DBTHeader: TDBTHeader;
S, SS: String;
Addr: DWord;
Stream: PStream;
begin
Active:= False;
Result:= False;
S:= Parse(DescriptionDBF, #1);
_CodePage:= Str2Int(Parse(S, #2));
_BlockSize:= Str2Int(S);
_FieldsCount:= 0; S:= DescriptionDBF;
while S <> '' do begin
Parse(S, #1); Inc(_FieldsCount);
end;
if (_FieldsCount = 0) or (_FieldsCount > 255) then Exit;
GetMem(_DBFFields, _FieldsCount*SizeOf(TDBFField));
try
IsMemo:= False;
i:= 0; Addr:= 1; _RecordLength:= 1;
while DescriptionDBF <> '' do begin
S:= Parse(DescriptionDBF, #1);
FillChar(_DBFFields^[i], SizeOf(TDBFFields), 0);
with _DBFFields[i] do begin
// Íàçâàíèå ïîëÿ
SS:= Parse(S, #2);
if (SS = '') or (Length(SS) > 10) then Exit;
Move(SS[1], FieldName, Length(SS));
// Òèï ïîëÿ 'C' - Character; 'N' - Numeric; 'D' - Date; 'B' - Binary; 'L' - Logical, 'M' - Memo
SS:= Parse(S, #2);
if (SS = '') or (Length(SS) <> 1) then Exit;
FieldType:= SS[1];
// Äëèíà ïîëÿ (â áàéòàõ)
FieldLength:= Str2Int(Parse(S, #2));
case FieldType of
'C': if (FieldLength = 0) or (FieldLength > 254) then Exit;
'N': if (FieldLength = 0) or (FieldLength > 20) then Exit;
'D': FieldLength:= 8;
'L': FieldLength:= 1;
'B', 'M': begin
FieldLength:= 10;
IsMemo:= True;
end;
else Exit;
end;
// Äëèíà äåñÿòè÷íîé ÷àñòè
SS:= Parse(S, #2);
if FieldType = 'N' then
Decimals:= Max(0, Min(FieldLength-1, Str2Int(SS)));
// Ôëàã ïîëÿ
// if FieldType in ['B', 'M'] then FieldFlags:= $04;
// if FieldType = 'C' then FieldFlags:= FieldFlags or $02;
Address:= Addr;
inc(_RecordLength, FieldLength);
inc(Addr, FieldLength);
end;
inc(i);
end;
FillChar(_DBFHeader, SizeOf(_DBFHeader), 0);
with _DBFHeader do begin
if IsMemo then DBFType:= DBF_dBaseIVMemo else DBFType:= DBF_dBaseIV; // Òèï ôàéëà (DBF_xxx)
SetDate(LastUpdated); // Äàòà ïîñëåäíåãî îáíîâëåíèÿ â ôîðìàòå YYMMDD
RecordCount:= 0; // Êîëè÷åñòâî çàïèñåé â òàáëèöå
HeaderLength:= SizeOf(_DBFHeader) + _FieldsCount * SizeOf(TDBFField) + 1; // Êîëè÷åñòâî áàéò, çàíèìàåìûõ çàãîëîâêîì
RecordLength:= _RecordLength; // Êîëè÷åñòâî áàéò, çàíèìàåìûõ çàïèñüþ
//Reserved_1: array [1..16] of Byte; // 3-Çàðåçåðâèðîâàííàÿ îáëàñòü; 13 - Çàðåçåðâèðîâàíî äëÿ ñåòåâîé âåðñèè dBASE III PLUS
if IsMemo then TableFlags:= $02; // $01 - file has a structural .cdx; $02 - file has a Memo field; $04 - file is a database (.dbc). This byte can contain the sum of any of the above values. For example, the value 0x03 indicates the table has a structural .cdx and a Memo field.
CodePage:= _CodePage; // Êîäîâàÿ ñòðàíèöà
//Reserved_2: Word; // Çàðåçåðâèðîâàííàÿ îáëàñòü
end;
Stream:= NewWriteFileStream(AFileName);
Stream.Size:= 0;
Stream.Write(_DBFHeader, SizeOf(_DBFHeader));
for i:= 0 to _FieldsCount-1 do
Stream.Write(_DBFFields[i], SizeOf(TDBFFields));
S:= #$0D#$1A;
Stream.Write(S[1], 2);
Stream.Free;
if IsMemo then begin
_BlockSize:= Max(_BlockSize, SizeOf(_DBTHeader));
FillChar(_DBTHeader, SizeOf(_DBTHeader), 0);
with _DBTHeader do begin
NextFree:= 512 div _BlockSize + Ord(512 mod _BlockSize > 0);
BlockSize:= _BlockSize;
end;
end;
Stream:= NewWriteFileStream(ChangeFileExt(AFileName, '.dbt'));
Stream.Size:= 0;
Stream.Write(_DBTHeader , SizeOf(_DBTHeader));
Stream.Size:= _DBTHeader.NextFree*_DBTHeader.BlockSize;
Stream.Free;
finally
FreeMem(_DBFFields);
end;
FFileName:= AFileName;
Active:= True;
Result:= True;
end;
procedure TmdvDBF.SetDate(var ADate: TYYMMDD);
var Y, M, D: Word;
begin
DecodeDate(Now, Y, M, D);
ADate[1]:= Lo(Y mod 100); ADate[2]:= Lo(M); ADate[3]:= Lo(D);
end;
end.
Reference in New Issue View Git Blame Copy Permalink