Экономия памяти с дублирующими значениями в таблице

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

{

Often there are lots of duplicate strings in a program,

for example take the following database:

Author Title

aaa xxx

aaa yyy

aaa zzz

Suppose you want to read it into your program and

create one record or class per line:

}

while not Table.EOF do

begin

author := Table[‘Author’];

title := Table[‘Title’];

MyClass := TMyClass(author, title);

StoreItSomewhere(MyClass);

Table.Next;

end;

{

You end up with three different strings containting the same author.

No problem with that as long as there are only three of them.

Now suppose you have got a database of 100,000 entries and lots of

duplicate author names.

If you do the above again you will end up with a huge memory overhead

due to fragmentation of the free memory on the heap.

In addition to that freeing the objects will result in a noticable delay

of the program while the memory manager is busy merging free memory blocks.

On the other hand, Delphi’s AnsiStrings use reference counting so it

would be possible to assign the same string to many string variables

without copying the contents:

}

Author := ‘aaa’;

for i:=0 to 100000 do

begin

MyClass := TMyClass(Author);

StoreItSomewhere(MyClass);

end;

{

This will create 100000 strings containting ‘aaa’,

but store the actual contents only once,

because they are assigned the same string constant.

It would be nice to do the same with the above database example,

wouldn’t it? But how do we get Delphi to realize that

the content is really the same?

Answer: A StringList

}

authors := TStringList.Create;

authors.Sorted := true;

authors.Duplicates := dupIgnore;

while not Table.EOF do

begin

author := Table[‘Author’];

title := Table[‘Title’];

authors.Add(author);

authors.Search(author, Idx);

author := authors[Idx];

MyClass := TMyClass(author, title);

StoreItSomewhere(MyClass);

Table.Next;

end;

authors.free;

{

This will only keep one string of each author’s name and assign

it to all other occurences, even after the StringList has been freed again.

The wonders of reference counting!

I admit that the above example looks a bit odd. Nobody would load

such a database into memory. But I had a similar problem today and by using

the trick above I managed to reduce the memory usage of my program from 120 megabytes to 10

(basically nothing, given that it started out with 8 mb).

}

{/codecitation}

Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

// Только для не SQL-ых, т.е не промышленных БД (dBase, Paradox ..)

// Путь нужно задавать только АНГЛИЙСКИМИ буквами

procedure QuickCopyTable(T: TTable; DestTblName: string; Overwrite: boolean);

var

DBType: DBIName;

WasOpen: boolean;

NumCopied: word;

begin

WasOpen := T.Active;

if not WasOpen then

T.Open;

Check(DbiGetProp(hDBIObj(T.Handle),drvDRIVERTYPE, @DBType,SizeOf(DBINAME), NumCopied));

Check(DbiCopyTable(T.DBHandle, Overwrite, PChar(T.TableName),DBType, PChar(DestTblName)));

T.Active := WasOpen;

end;

{/codecitation}

Таблицы в памяти

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: grisha@mira.com

4 Mb — это не память. Это склероз

Вот пример InMemoryTable. Свободен для использования, модификации и всего остального. Ну и как в отношении других вещей: я не даю никаких гарантий. Я не несу никакой ответственности за ущерб, который может причинить код. Позвольте, я повторю это:

ВНИМАНИЕ! ДАННЫЙ КОД НЕ ПРЕДУСМАТРИВАЕТ НИКАКИХ ГАРАНТИЙ!

ИСПОЛЬЗУЙТЕ ЕГО НА СВОЙ СТРАХ И РИСК — ВЫ ЕДИНСТВЕННЫЙ ЧЕЛОВЕК, ОТВЕТСТВЕННЫЙ ЗА ЛЮБОЙ УЩЕРБ, КОТОРЫЙ МОЖЕТ ПОВЛЕЧЬ ЗА СОБОЙ ИСПОЛЬЗОВАНИЕ ДАННОГО КОДА — — Я ВАС ПРЕДУПРЕДИЛ!

Благодарю Steve Garland за предоставленную помощь. Он создал свой собственный «in-memory» табличный компонент, который послужил мне толчком для написания сего кода.

InMemory-таблицы являются характеристикой Borland Database Engine (BDE). InMemory-таблицы создаются в RAM и удаляются при их закрытии. Работают они значительно быстрее и очень полезны в случае, если вам нужны быстрые операции в небольших таблицах. Данный пример использует вызов функции BDE DbiCreateInMemoryTable. Данный объект должен работать наподобии простой регулярной таблицы, за исключением того, что InMemory-таблицы не поддерживают некоторые характеристики (типа проверка целостности, вторичные индексы и BLOB-поля), и в настоящее время данный код не содержит механизма обработки ошибок. Вероятно, вы получите ошибку при попытке создания memo-поля. Если у вас есть любые замечания, шлите их по адресу grisha@mira.com.

unit Inmem;

interface

uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;

type

TInMemoryTable = class(TTable)

private

hCursor: hDBICur;

procedure EncodeFieldDesc(var FieldDesc: FLDDesc;

const Name: string; DataType: TFieldType; Size: Word);

function CreateHandle: HDBICur; override;

public

procedure CreateTable;

end;

implementation

{ Эта функция виртуальная, так что я смог перекрыть ее.

В оригинальном VCL-коде для TTable эта функция реально

открывает таблицу, но, поскольку мы уже имеем дескриптор

таблицы, то мы просто возвращаем его }

function TInMemoryTable.CreateHandle;

begin

Result := hCursor;

end;

{ Эта функция получена ее простым копированием из исходного

кода VCL. Я должен был это сделать, поскольку это было

объявлено в секции private компонента TTable, поэтому отсюда

у меня не было к этому досупа. }

procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;

const Name: string; DataType: TFieldType; Size: Word);

const

TypeMap: array[TFieldType] of Byte = (

fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,

fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,

fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);

begin

with FieldDesc do

begin

AnsiToNative(Locale, Name, szName, SizeOf(szName) — 1);

iFldType := TypeMap[DataType];

case DataType of

ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:

iUnits1 := Size;

ftBCD:

begin

iUnits1 := 32;

iUnits2 := Size;

end;

end;

case DataType of

ftCurrency:

iSubType := fldstMONEY;

ftBlob:

iSubType := fldstBINARY;

ftMemo:

iSubType := fldstMEMO;

ftGraphic:

iSubType := fldstGRAPHIC;

end;

end;

end;

{ Вот кухня, где все это происходит. Я скопировал эту

функцию из исходников VCL и затем изменил ее для

использования DbiCreateInMemoryTable вместо DbiCreateTable.

Поскольку InMemory-таблицы не поддерживают индексы,

я удалил весь соответствующий код. }

procedure TInMemoryTable.CreateTable;

var

I: Integer;

pFieldDesc: pFLDDesc;

szTblName: DBITBLNAME;

iFields: Word;

Dogs: pfldDesc;

begin

CheckInactive;

if FieldDefs.Count = 0 then

for I := 0 to FieldCount — 1 do

with Fields[I] do

if not Calculated then

FieldDefs.Add(FieldName, DataType, Size, Required);

pFieldDesc := nil;

SetDBFlag(dbfTable, True);

try

AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) — 1);

iFields := FieldDefs.Count;

pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));

for I := 0 to FieldDefs.Count — 1 do

with FieldDefs[I] do

begin

EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name,

DataType, Size);

end;

{ тип драйвера nil, т.к. поля логические }

Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc,

nil, nil, pFieldDesc));

{ здесь hCursor получает свое значение }

Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc,

hCursor));

finally

if pFieldDesc nil then

FreeMem(pFieldDesc, iFields *

SizeOf(FLDDesc));

SetDBFlag(dbfTable, False);

end;

end;

end.

{Данный код взят из файлов помощи Ллойда!}

{/codecitation}

Существует ли средство для вывода определения структуры таблицы

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Nomadic

Для этого существует утилита DB2LOOK. Она находится в SQLLIB\MISC.

Пример использования:

CONNECT TO SAMPLE USER xxx USING yyy

DB2LOOK -d SAMPLE -u xxx -e -t employee

Вывод может быть перенаправлен в файл. Полный синтаксис выдаётся по команде:

DB2LOOK ?

{/codecitation}

Создание таблицы с автоинкрементальным полем

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Допустим у вас имеется форма с кнопкой. Щелчок на кнопке с помощью DbiCreateTable должен создать таблицу Paradox с автоинкрементальным (приращиваемым) полем.

unit Autoinc;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, DBTables, DB, ExtCtrls, DBCtrls, Grids, DBGrids, StdCtrls,

DbiTypes, DbiErrs, DBIProcs;

const

szTblName = ‘CR8PXTBL’; { Имя создаваемой таблицы. }

szTblType = szPARADOX; { Используемый тип таблицы. }

{ При создании таблицы используется полное описание поля }

const

fldDes: array[0..1] of FLDDesc = (

({ Поле 1 — AUTOINC }

iFldNum: 1; { Номер поля }

szName: ‘AUTOINC’; { Имя поля }

iFldType: fldINT32; { Тип поля }

iSubType: fldstAUTOINC; { Подтип поля }

iUnits1: 0; { Размер поля }

iUnits2: 0; { Десятичный порядок следования ( 0 ) }

iOffset: 0; { Смещение в записи ( 0 ) }

iLen: 0; { Длина в байтах ( 0 ) }

iNullOffset: 0; { Для Null-битов ( 0 ) }

efldvVchk: fldvNOCHECKS; { Проверка корректности ( 0 ) }

efldrRights: fldrREADWRITE { Права }

),

({ Поле 2 — ALPHA }

iFldNum: 2; szName: ‘ALPHA’;

iFldType: fldZSTRING; iSubType: fldUNKNOWN;

iUnits1: 10; iUnits2: 0;

iOffset: 0; iLen: 0;

iNullOffset: 0; efldvVchk: fldvNOCHECKS;

efldrRights: fldrREADWRITE

));

type

TForm1 = class(TForm)

Button1: TButton;

Database1: TDatabase;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

var

TblDesc: CRTblDesc;

uNumFields: Integer;

Rslt: DbiResult;

ErrorString: array[0..dbiMaxMsgLen] of Char;

begin

FillChar(TblDesc, sizeof(CRTblDesc), #0);

lStrCpy(TblDesc.szTblName, szTblName);

lStrCpy(TblDesc.szTblType, szTblType);

uNumFields := trunc(sizeof(fldDes) / sizeof(fldDes[0]));

TblDesc.iFldCount := uNumFields;

TblDesc.pfldDesc := @fldDes;

Rslt := DbiCreateTable(Database1.Handle, TRUE, TblDesc);

if Rslt dbiErr_None then

begin

DbiGetErrorString(Rslt, ErrorString);

MessageDlg(StrPas(ErrorString), mtWarning, [mbOk], 0);

end;

end;

end.

{/codecitation}

Создание таблицы программным путем

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Цымбал Виталий

WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Создание таблицы программным путем

Function CreateTable(liTableType:Integer;lsTableName:AnsiString;lsFields:AnsiString):BOOLEAN;

liTableType

Value Meaning

0 ttDefault (Default) Determine table type based on file extension for the table.

1 ttParadox Table is a Paradox table.

2 ttDBase Table is a dBASE table.

3 ttFoxPro Table is a FoxPro table.

4 ttASCII Table is a text file with comma-delimited, quoted strings for each field

If liTableType is set to 0(ttDefault), the lsTableName extension determines the table type:

Extension Meaning

DB or none Paradox table

DBF dBASE table

TXT ASCII table

ATTENTION!!

lsFields

‘Name1;DataType1;Size1;Precision1;Requered1;Name2;DataType2;Size2;

Precision2;Requered2;…;…;…;…;…; NameN;DataTypeN;SizeN;PrecisionN;RequeredN’

1.Name : string;

2.DataType : TFieldType:

Value Description

ftUnknown Unknown or undetermined

ftString Character or string field

ftSmallint 16-bit integer field

ftInteger 32-bit integer field

ftWord 16-bit unsigned integer field

ftBoolean Boolean field

ftFloat Floating-point numeric field

ftCurrency Money field

ftBCD Binary-Coded Decimal field

ftDate Date field

ftTime Time field

ftDateTime Date and time field

ftBytes Fixed number of bytes (binary storage)

ftVarBytes Variable number of bytes (binary storage)

ftAutoInc Auto-incrementing 32-bit integer counter field

ftBlob Binary Large OBject field

ftMemo Text memo field

ftGraphic Bitmap field

ftFmtMemo Formatted text memo field

ftParadoxOle Paradox OLE field

ftDBaseOle dBASE OLE field

ftTypedBinary Typed binary field

ftCursor Output cursor from an Oracle stored procedure (TParam only)

ftFixedChar Fixed character field

ftWideString Wide string field

ftLargeInt Large integer field

ftADT Abstract Data Type field

ftArray Array field

ftReference REF field

ftDataSet DataSet field

ftOraBlob BLOB fields in Oracle 8 tables

ftOraClob CLOB fields in Oracle 8 tables

ftVariant Data of unknown or undetermined type

ftInterface References to interfaces (IUnknown)

ftIDispatch References to IDispatch interfaces

ftGuid globally unique identifier (GUID) values

3. Size : integer

4. Precision : integer;

— for DataType ftBCD only

5. Requered : Boolean

Value – [true;false]

Example

CreateTable(1,’c:\base1′,’CODE;ftString;60;0;;NAME;ftString;100;0;true;COUNT;

ftInteger;;;;SUM;ftBCD;10;2;false;DATE;ftDate;;;’)

Зависимости: Windows, Messages, SysUtils, Classes, Db, DBTables

Автор: Цымбал Виталий Викторович, victor@ab-system.com, Львов

Copyright: Cобственная разработка

Дата: 16 августа 2002 г.

***************************************************** }

function TForm1.CreateTable(liTableType: Integer; lsTableName: AnsiString;

lsFields: AnsiString): BOOLEAN;

var

TType, S, lSTR: AnsiString;

i: integer;

lSize: boolean;

FTable: TTable;

begin

try

Result := True;

i := 0;

lSTR := lsFields;

while Pos(‘;’, lSTR) > 0 do

begin

lSTR[Pos(‘;’, lSTR)] := ‘0’;

i := i 1;

end;

i := i 1;

// проверка на количество разделителей ‘;’ в описании полей — должно быть

// кратно 5

if (int(i / 5)) (i / 5) then

begin

ShowMessage(‘Ошибка!’ #13

‘Неверное количество параметров в строке с данными про поля таблицы’);

Result := False;

end;

// создание объекта — таблица

FTable := TTable.Create(nil);

with FTable do

begin

Active := False;

// задание типа таблицы в числовом выражении

case liTableType of

0: TableType := ttDefault;

1: TableType := ttParadox;

2: TableType := ttDBase;

3: TableType := ttFoxPro;

4: TableType := ttASCII;

else

begin

ShowMessage(‘Ошибка!’ #13

‘Неверно задан тип тиблицы (возможны значения 0-4)’);

Result := False;

end;

end;

// ввод имени таблицы с полным путем

TableName := lsTableName;

FieldDefs.Clear;

while Pos(‘;’, lsFields) > 0 do

begin

with FieldDefs do

begin

S := copy(lsFields, 1, Pos(‘;’, lsFields) — 1);

with AddFieldDef do

begin

// анализ и разбивка строки с данными про поля таблицы

system.delete(lsFields, 1, Pos(‘;’, lsFields));

Name := S;

S := copy(lsFields, 1, Pos(‘;’, lsFields) — 1);

lSize := True;

if (S = ‘ftUnknown’) then

begin

DataType := ftUnknown;

lSize := False;

end;

if (S = ‘ftString’) then

DataType := ftString;

if (S = ‘ftBCD’) then

DataType := ftBCD;

if (S = ‘ftBytes’) then

DataType := ftBytes;

if (S = ‘ftVarBytes’) then

DataType := ftVarBytes;

if (S = ‘ftBlob’) then

DataType := ftBlob;

if (S = ‘ftMemo’) then

DataType := ftMemo;

if (S = ‘ftFmtMemo’) then

DataType := ftFmtMemo;

if (S = ‘ftSmallint’) then

begin

DataType := ftSmallint;

lSize := False;

end;

if (S = ‘ftInteger’) then

begin

DataType := ftInteger;

lSize := False;

end;

if (S = ‘ftBoolean’) then

DataType := ftBoolean;

if (S = ‘ftFloat’) then

begin

DataType := ftFloat;

lSize := False;

end;

if (S = ‘ftCurrency’) then

begin

DataType := ftCurrency;

lSize := False;

end;

if (S = ‘ftTime’) then

begin

DataType := ftTime;

lSize := False;

end;

if (S = ‘ftDate’) then

begin

DataType := ftDate;

lSize := False;

end;

if (S = ‘ftDateTime’) then

begin

DataType := ftDateTime;

lSize := False;

end;

if (S = ‘ftAutoInc’) then

begin

DataType := ftAutoInc;

lSize := False;

end;

if (S = ‘ftGraphic’) then

DataType := ftGraphic;

if (S = ‘ftParadoxOle’) then

DataType := ftParadoxOle;

if (S = ‘ftDBaseOle’) then

DataType := ftDBaseOle;

if (S = ‘ftTypedBinary’) then

DataType := ftTypedBinary;

if (S = ‘ftCursor’) then

begin

DataType := ftCursor;

lSize := False;

end;

if (S = ‘ftFixedChar’) then

DataType := ftFixedChar;

if (S = ‘ftWideString’) then

DataType := ftWideString;

if (S = ‘ftLargeint’) then

DataType := ftLargeint;

if (S = ‘ftADT’) then

DataType := ftADT;

if (S = ‘ftArray’) then

DataType := ftArray;

if (S = ‘ftReference’) then

begin

DataType := ftReference;

lSize := False;

end;

if (S = ‘ftDataSet’) then

begin

DataType := ftDataSet;

lSize := False;

end;

if (S = ‘ftOraBlob’) then

DataType := ftOraBlob;

if (S = ‘ftVariant’) then

DataType := ftVariant;

if (S = ‘ftInterface’) then

DataType := ftInterface;

if (S = ‘ftIDispatch’) then

DataType := ftIDispatch;

if (S = ‘ftGuid’) then

DataType := ftGuid;

if (S = ‘ftBoolean’) then

begin

DataType := ftBoolean;

lSize := False;

end;

if (S = ‘ftWord’) then

begin

DataType := ftWord;

lSize := False;

end;

TType := S;

system.delete(lsFields, 1, Pos(‘;’, lsFields));

S := copy(lsFields, 1, Pos(‘;’, lsFields) — 1);

// Precision(Точность) поддерживает только тип BCD

if lSize then

if S » then

begin

if TType = ‘ftBCD’ then

Precision := StrToInt(S)

else

Size := StrToInt(S);

end;

system.delete(lsFields, 1, Pos(‘;’, lsFields));

S := copy(lsFields, 1, Pos(‘;’, lsFields) — 1);

if (S ») and (TType = ‘ftBCD’) then

Size := StrToInt(S); //!!!

system.delete(lsFields, 1, Pos(‘;’, lsFields));

if Pos(‘;’, lsFields) > 0 then

begin

S := copy(lsFields, 1, Pos(‘;’, lsFields) — 1);

system.delete(lsFields, 1, Pos(‘;’, lsFields));

end

else

S := lsFields;

if (S ») then

if (UPPERCASE(s) = ‘TRUE’) then

Required := True;

end;

end;

end;

//создание таблицы с заданными параметрами

CreateTable;

// уничтожение объекта — таблица

FTable.Free

end;

if Result = True then

ShowMessage(‘Таблица создана успешно’)

except

ShowMessage(‘Ошибка при создании таблицы’);

end;

end;

end;

Пример использования:

CreateTable(1, ‘c:\base1’,

‘CODE;ftString;60;0;;NAME;ftString;100;0;true;COUNT;ftInteger;;;;SUM;ftBCD;10;2;false;DATE;ftDate;;;’)

{/codecitation}

Создание таблицы по образу и подобию

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Создайте во время выполнения программы пустую таблицу, скопируйте структуру существующей, включая первичный индекс. На практике это выглядит примерно так:

var

Table2 : TTable;

begin

Table1.FieldDefs.Update;

Table1.IndexDefs.Update;

Table2 := TTable.Create(nil);

Table2.DatabaseName := Table1.DatabaseName;

Table2.TableName := ‘MyTable’;

Table2.TableType := Table1.TableType;

Table2.FieldDefs.Assign(Table1.FieldDefs);

Table2.IndexDefs.Assign(Table1.IndexDefs);

Table2.CreateTable ;

end;

…один способ сделать это.

{/codecitation}

Создание новой таблицы на основе структуры другой таблицы

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

На ум сразу приходит операция присваивания значения свойству (стоящему с левой стороны от ‘:=’), при которой Delphi в своих недрах вызывает метод ‘write’ и передает ему в виде единственного параметра все то, что находится в правой части выражения. Если свойство не имеет метода write, оно предназначено только для чтения. Вот определение свойства FieldDefs объекта TDataSet в файле DB.PAS:

property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;

Как вы можете видеть, у него есть метод write. Следовательно, код:

Destination.FieldDefs := Source.FieldDefs;

в действительности делает такую операцию:

Destination.SetFieldDefs(Source.FieldDefs);

(за исключением того, что вы не можете использовать эту строку, поскольку SetFieldDefs определен в секции Private.)

Вот определение свойства IndexDefs объекта TTable в файле DBTABLES.PAS file:

property IndexDefs: TIndexDefs read FIndexDefs;

В этом случае метод write отсутствует, поэтому свойство имеет атрибут только для чтения. Тем не менее, для самого объекта TIndexDefs существует метод Assign. Следовательно, следующий код должен работать:

Source.IndexDefs.Update;

Destination.IndexDefs.Assign(Source.IndexDefs);

Перед вызовом Assign для Source.IndexDefs вызывайте метод Update, чтобы быть уверенным в том, что вы получите то, что хотите.

Метод SetFieldDefs является процедурой с одной строкой кода, в которой вызывается метод FieldDefs Assign.

Также можно проверить, определен ли реально индекс, и, если нет, то при вызове IndexDefs.Assign вы можете получить исключение типа «List Index Out Of Bounds» (или что-то типа этого). Например, так:

if Source.IndexDefs.Count > 0 then…

Вам нужно будет это сделать, поскольку метод TIndexDefs.Assign не проверяет это перед копированием индекс-информации. Также вам нет необходимости вызывать Clear до работы с IndexDefs, поскольку метод Assign сделает это и без вашего участия.

{/codecitation}

Создание кросс-таблицы

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Michael Lant

Вы можете создать их в DBD как QBE-шки. Пользуясь компонентом TQBE для загрузки одной из библиотек, вы можете непосредственно использовать QBE-шки в вашем Delphi-приложении.

В следующем примере предполагается, что каждый служащий каждый день сообщает оператору о своем месторасположении. Код определяет начало трудовой недели с понедельника плюс еще четыре рабочих дня с показом соответствующей даты. Строки с 1 по 5 в QBE1.QBE (нулевая описательная) в нижеприведенной процедуре заменяются кодом. Результат всего этого в том, что строка (если имеется) для каждого человека отображается в колонке установленного результата и значение ‘X’ включается если только запись существует. Для создания агрегатной таблицы можно было бы подсчитывать результаты.

Текст в QBE1.QBE :

CALLIN.DB | StaffNo | Date |

| _join1 | 3/10/95 |

| _join2 | 3/11/95 |

| _join3 | 3/12/95 |

| _join4 | 3/13/95 |

| _join5 | 3/14/95 |

XTAB.DB | StaffNo |Mon |Tue |Wed |Thu |Fri |

| _join1 |changeto X| | | | |

| _join2 | |changeto X| | | |

| _join3 | | |changeto X| | |

| _join4 | | | |changeto X| |

| _join5 | | | | |changeto X|

procedure TCallInReport.ButtonSelectClick(Sender: TObject);

begin

TableXTab.active := false;

if EditWeekOf.Text = » then

begin

messageBeep(0);

messageDlg(‘Для выбора записи необходима дата.’, mtInformation, [mbOK], 0);

exit;

end;

Screen.Cursor := crHourGlass;

dtWeekOf := StrToDate(EditWeekOf.Text);

dtStartDate := dtWeekOf — DayOfWeek(dtWeekOf) 2;

TableXTab.active := false;

TableXTab.EmptyTable;

TableXTab.active := true;

{

Замените строки 1 — 5 в QBE1.QBE реальными датами

}

QBE1.QBE.Strings[1] := ‘ | _join1 | ‘ DateToStr(dtStartDate) ‘ | ‘;

QBE1.QBE.Strings[2] := ‘ | _join2 | ‘ DateToStr(dtStartDate 1) ‘ | ‘;

QBE1.QBE.Strings[3] := ‘ | _join3 | ‘ DateToStr(dtStartDate 2) ‘ | ‘;

QBE1.QBE.Strings[4] := ‘ | _join4 | ‘ DateToStr(dtStartDate 3) ‘ | ‘;

QBE1.QBE.Strings[5] := ‘ | _join5 | ‘ DateToStr(dtStartDate 4) ‘ | ‘;

try

QBE1.active := true;

except

on E: EDataBaseError do

begin

if E.Message = ‘Ошибка создания дескриптора курсора’ then

{ Ничего не делайте. Делая TQBE активной, мы пытаемся создать курсор.

Это вызывает исключительную ситуацию, которую мы должны перехватить.

Пока я не нашел способа как отделаться от исключения. }

else

begin

Screen.Cursor := crDefault;

raise;

end;

end;

else

Screen.Cursor := crDefault;

raise;

end;

TableXTab.refresh;

Screen.Cursor := crDefault;

TableXTab.active := true;

end;

{/codecitation}

Путь к локальной таблице

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

implementation

{$R *.DFM}

uses DbiTypes, DbiProcs;

function fDbiFormFullName(Tbl: TTable): String;

var

Props: CurProps;

Buffer1 : array[0..DBIMAXPATHLEN] of char;

Buffer2 : array[0..DBIMAXPATHLEN] of char;

begin

Check(DbiGetCursorProps(Tbl.Handle,Props));

StrPCopy(Buffer1, Tbl.TableName);

Check(DbiFormFullName(Tbl.DBHandle,

@Buffer1,

Props.szTableType,

@Buffer2));

Result := StrPas(Buffer2);

end;

// Notes:

// Table_You_Are_Using.Active Must be True.

// Works on Local Tables.

{/codecitation}