home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d123456 / JBDBF.ZIP / jbdbf.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-08-27  |  70.2 KB  |  1,922 lines
  1. {$IfDef VER80}
  2. {$X+}
  3. {$Else}
  4. {$X+,H-}
  5. {$EndIf}
  6. unit jbDbf;
  7. {founded 1999 (c) Jaro Benes}
  8. {works with DBF table by direct file}
  9. {for version Delphi 1..6}
  10. {history:}
  11. {  20.8. 2002 changes and Italian messages by Andrea Russo /AR/ [mailto:andrusso@yahoo.com]}
  12. {  18.04.2001 bugfix changes by Jarda Jirava [<mailto:listuj@centrum.cz>]}
  13. {  30.10.2001 bugfix and extended by Vyacheslav Nebroev /VN/ [<mailto:vasu@amts.smolensk.ru>]}
  14. {  15.01.2002 all comments convert from Czech to English}
  15. interface
  16.  
  17. uses SysUtils, Classes, Dialogs;
  18.  
  19. {$IfNDef Ver130}
  20. Const
  21. {$Else}
  22. ResourceString { Changed by me /VN/ }
  23. {$EndIf}
  24.  
  25. {$DEFINE MessagesItalianLang}
  26. {$IfDEF MessagesItalianLang}
  27.   msgCreateDBFError = 'Impossibile creare un nuovo file DBF';
  28.   msgErrorOnOpen = 'Impossibile aprire il file DBF';
  29.   msgEOFmarkMiss = 'Fine del file non trovata';
  30.   msgNoPasswordMatch = 'Password non valida';
  31.   msgNotEnoughtCreateIdx = 'Impossibile creare l''indice IDX';
  32.   msgIdxTableNotFound = 'Impossible aprire l''indice IDX "%s"';
  33.   msgErrorOnIdxTable = 'Errore durante la lettura dell''indice IDX "%s"';
  34.   msgIdxFieldNotFound = 'Campo indice "%s" non trovato';
  35.   msgFieldNotFound = 'Il campo numero %d non Φ presente';
  36.   msgFileIsTooLarge = 'File troppo grande';
  37.   msgErrorOnWrite = 'Errore durante la scrittura della tabella';
  38.   msgFileTooRemote = 'La data del file non Φ valida';
  39.   msgCannotOpenTable = 'Impossibile aprire la tabella';
  40.   msgCannotDeleteItem = 'Impossibile cancellare il campo';
  41.   msgCannotAddItem = 'Impossibile aggiungere un nuovo campo';
  42.   msgBadDefinitionOfField = 'La definizione del campo Φ errata';
  43.   msgDuplicateInUnique = 'Valore duplicato in un indice univoco';
  44.   msgErrorOnMemoOpen = 'Errore durante l''apertura del memo';
  45.   prgMakeIndexSort = 'Ordinamento dell''indice';
  46.   prgWriteIndexSort = 'Scrittura dell''indice';
  47.   prgSearchByKey = 'Ricerca per chiave';
  48.  
  49. {$Else}
  50.  
  51. {$IfDef MessagesCzechLang}
  52.   {hlasky lze doplnit diakritikou}
  53.   {messages (and all comments) in Czech haven't got diacritics}
  54.   {but is possible insert it into messages}
  55.   msgCreateDBFError = 'Nemohu vytvorit novou DBF tabulku';
  56.   msgErrorOnOpen = 'Nemohu otevrit DBF tabulku';
  57.   msgEOFmarkMiss = 'Chybi oznaceni konce souboru';
  58.   msgNoPasswordMatch = 'Nesouhlasi overovaci heslo administratora';
  59.   msgNotEnoughtCreateIdx = 'Nemohu vytvorit IDX soubor';
  60.   msgIdxTableNotFound = 'Nemohu otevrit IDX soubor "%s"';
  61.   msgErrorOnIdxTable = 'Nesouhlasi mohutnost IDX souboru "%s"';
  62.   msgIdxFieldNotFound = 'Nebyla nalezena polozka "%s"';
  63.   msgFileIsTooLarge = 'Soubor ma priliz mnoho polozek nez muze tato verze zpracovat';
  64.   msgErrorOnWrite = 'Chyba pri pokusu o zapis do tabulky';
  65.   msgFileTooRemote = 'Soubor je priliz vzdaleny az nedostupny';
  66.   msgCannotOpenTable = 'Tabulka se nenechala otevrit';
  67.   msgCannotDeleteItem = 'Zaznam z tabulky nejde odstranit';
  68.   msgCannotAddItem = 'Novy zaznam nejde do tabulky pridat';
  69.   msgBadDefinitionOfField = 'Chybna definice zaznamu pole tabulky';
  70.   msgDuplicateInUnique = 'Pokus pridat do unikatniho klice duplicitu';
  71.   msgErrorOnMemoOpen = 'Chyba pri otevirani memo souboru';
  72.   prgMakeIndexSort = 'Vytvarim indexovou strukturu';
  73.   prgWriteIndexSort = 'Zapisuji index na disk';
  74.   prgSearchByKey = 'Prohledavam tabulku dle indexu';
  75. {$Else}
  76.   msgCreateDBFError = 'Cannot create new DBF file';
  77.   msgErrorOnOpen = 'Cannot open DBF file';
  78.   msgEOFmarkMiss = 'Missing EOF mark';
  79.   msgNoPasswordMatch = 'No password match';
  80.   msgNotEnoughtCreateIdx = 'Cannot create IDX';
  81.   msgIdxTableNotFound = 'Cannot open IDX "%s"';
  82.   msgErrorOnIdxTable = 'Error of reading IDX "%s"';
  83.   msgIdxFieldNotFound = 'Index field "%s" not found';
  84.   msgFieldNotFound = 'Field with number %d not present';
  85.   msgFileIsTooLarge = 'File is too large';
  86.   msgErrorOnWrite = 'Error writing table';
  87.   msgFileTooRemote = 'File too remote';
  88.   msgCannotOpenTable = 'Cannot open table';
  89.   msgCannotDeleteItem = 'Cannot delete item';
  90.   msgCannotAddItem = 'Cannot add new item';
  91.   msgBadDefinitionOfField = 'Bad field definition';
  92.   msgDuplicateInUnique = 'Duplicate in Unique';
  93.   msgErrorOnMemoOpen = 'Error of memo opening';
  94.   prgMakeIndexSort = 'Make index sort';
  95.   prgWriteIndexSort = 'Write indes sort';
  96.   prgSearchByKey = 'Search by key';
  97. {$EndIf}
  98. {$EndIf}
  99. {----------------------------------------------------------------------------}
  100. Const
  101.   MaxSize = $7FFF;  { maximum for buffer }
  102.   MaxItems = 16384; { this is for 16bit Delphi, is possible to change}
  103.   MaxFields = 128;  { maximum count for columns }
  104.   DeleteFlag = '*';
  105.   EOFFlag = #$1A;
  106.   SpacerD = ' ';
  107. Type
  108.   charay11=Array [0..10] Of Char; {filename defs.}
  109.  
  110.   {zapis se podaril, db je nedostupna-v transakci, storno operace, chyba pri zapisu}
  111.   {write unsuccessful, db is inaccessible in transaction, cancel operation, error on write}
  112.   TStatusWrite = (dbfOK, dbfBusy, dbfCancel, dbfError);
  113.   {zaznam je ukladan jako novy, nebo je obcerstvovan}
  114.   {record is stored as new or is refreshed}
  115.   TPostAct = (dbfNew, dbfUpdate);
  116.   {pole ma unikatni klic, duplicitni klic,autoinkcementalni klic}
  117.   {field has unique key, duplicate key or autoincrement key}
  118.   TFieldReq = (dbfUnique, dbfDuplicates);
  119.   {pole razeno vzestupne, sestupne, podle alternativniho klice}
  120.   {field sorted in ascending order, descending order or by alternative key}
  121.   TSortByIndex = (dbfAscending, dbfDescending, dbfAlternative);
  122.   {declaration events procedures}
  123.   TDBFError = procedure (Sender: TObject; Const ErrorMsg: String) of object;
  124.   TDBFMakeItems = procedure (Sender: TObject; Posit: Integer;
  125.    Var INname: ChAray11; Var IWhat: Char; Var ILen, IPlaces: Byte;
  126.    Var IDXName:charay11;Var Req: TFieldReq; Var Sort: TSortByIndex) of object;
  127.   TDBFProgress = procedure (Sender: TObject; Const Operace: OpenString; Progress: Integer) of object;
  128.   TDBFPassword = procedure (Sender: TObject; Var Pass: OpenString) of object;
  129.   TDBFAssigned = procedure (Sender: TObject; Var FName: OpenString) of object;
  130.   TDBFBeforeConfirm = procedure (Sender: TObject; Const FName:String; Var Confirm: Boolean) of object;
  131.   TDBFConfirm = procedure (Sender: TObject; Var Confirm: Boolean) of object;
  132.   TDBFNavigate = procedure (Sender: TObject; Position: LongInt) of object;
  133.   TDBFOpened = procedure (Sender: TObject; IsOpened: Boolean) of object;
  134.   TDBFChange = procedure (Sender: TObject; Var Cancel: Boolean) of object;
  135.   TDBFActualize = procedure (Sender: TObject; Status: TPostAct) of object;
  136.   TDBFQuery = procedure (Sender: TObject; Const IdxName, IdxField, Key: OpenString;
  137.     Var Accept, Cancel: Boolean) of object;
  138.   TDBFAltSort = procedure (Sender: TObject; TblIdx: TStringList) of object;
  139.  
  140.   TRecArray = Array [0..MaxSize] of Char;
  141.   PRecArray = ^TRecArray;
  142.   PBigArray = PRecArray;
  143.  
  144.   TDBFHeader = record         { legends are from manual, changed for me specific}
  145.     version        : byte;    { Should be 3 or $83                           1 }
  146.                               { $3  - FoxBase+/dBase III Plus bez souboru MEMO }
  147.                               {     - FoxPro/dBase IV bez souboru memo
  148.                               { $83 - FoxBase+/dBase III Plus se souborem MEMO }
  149.                               { $F5 - FoxPRo se souborem memo                  }
  150.                               { $8B - dBase IV se souborem memo                }
  151.     year,month,day : byte;    { Date of last update                          3 }
  152.     numRecs        : longint; { Number of records in the file                4 }
  153.     headLen        : word;    { Length of the header                         2 }
  154.     recLen         : word;    { Length of individual records                 2 }
  155.     nets           : word;    { not used                                       }
  156.     transaction    : byte;    { begin-end transaction                          }
  157.                               { 00 - no transaction protected                  }
  158.                               { 01 - transaction protected                     }
  159.     encrypted      : byte;    { coded fields                                   }
  160.                               { 00 - uncrypted                                 }
  161.                               { 01 - encrypted                                 }
  162.     network        : array [1..12] of byte;
  163.     mdxfile        : byte;    { exist .mdx file indicator                      }
  164.                               { 00 - non exist                                 }
  165.                               { 01 - exist and join                            }
  166.     LangDrv        : byte;    { language driver /fox/                          }
  167.                               { 001 - code page 437                            }
  168.                               { 002 - code page 850                            }
  169.                               { 100 - code page 852                            }
  170.                               { 102 - code page 865                            }
  171.                               { 101 - code page 866                            }
  172.                               { 104 - code page 895                            }
  173.                               { 200 - code page 1250                           }
  174.                               { 201 - code page 1251                           }
  175.                               { 003 - code page 1252                           }
  176.     labeled        : word;
  177.   end;
  178.  
  179. Const
  180.   TdbTypes:Set of Char = ['C'{characters, all ascii},
  181.                           'D'{date ddmmyyyy, fix size 8},
  182.                           'T'{time hhmmss, fix size 6},
  183.                           'F'{float point, -,.,0..9},
  184.                           'L'{logical, ?,Y,y,N,n},
  185.                           'M'{memo, as numeric, fix size 10},
  186.                           'N'{numeric, -,.,0..9}];
  187.   {struktura zazn. zapisniku, pripojene soubory predava pres disk}
  188.   {structure of memo appended file on disk}
  189. Type
  190.   TDBTTypes=Record
  191.     NumberOf:LongInt;                 { record no. }
  192.     AsFileType:Array [1..3] of Char;  { extension of saved type }
  193.     Used:Boolean;                     { used/unused }
  194.     SizeOfMemo:LongInt;               { size of appended file }
  195.     FileDateTime:Double;              { original date and time of file }
  196.     {MemoField:Array[1..SizeOfMemo] of Byte; // ulozeny soubor}
  197.   End;
  198.   {
  199.   struktura zaznamu klice, je bez hlavicky
  200.   structure record key, without head
  201.   TIDXTypes=Record
  202.     ItemNo:LongInt;                   // refer to record in table
  203.     Key:TDBField.Len;                 // key component
  204.   End;
  205.   }
  206.  
  207. Type
  208.   TdbField = Record
  209.     name   : charay11;           { Name of the field                     11 }
  210.     what   : Char;               { Type of data in this field             1 }
  211.     data   : array[0..1] of word;{ Not used                               2 }
  212.     len    : byte;               { Length of the field                    1 }
  213.     places : byte;               { Number of decimal places               1 }
  214.     idxtyp : TFieldReq;          { typ klice unikatni/duplicitni...       1 }
  215.     idxsrt : TSortByIndex;       { setridit vzestupne, sestupne, custom...1 }
  216.     dfIdent: Byte;               { datafield identifier ??                1 }
  217.     idx    : charay11;           { here file name in index  XXXXXXXXIDX  11 }
  218.   End;
  219.  
  220. Type
  221.   TKey=String;
  222. {----------------------------------------------------------------------------}
  223.   TjbDBF = class(TComponent)
  224.   private
  225.     FDBFName        : String;           { Full name table }
  226.     FDBFIsOpened    : Boolean;          { TRUE when is file opened }
  227.     FDBFStoreByIndex: Boolean;          { Store by list index }
  228.     FDBFHandle      : File;             { Handle of actual file }
  229.     FDBFExist       : Boolean;          { Indicate file exists when is name assigned }
  230.     FDBFReadOnly    : Boolean;          { Read only }
  231.     FDBFSaveOnClose : Boolean;          { Save on close }
  232.     FDBFHeader      : TDBFHeader;       { Header,  filled after open }
  233.     FDBFIndex       : String;           { Actual index for FIND }
  234.     FDBFPassword    : String;           { Administrator password }
  235.     FDBFFilter      : String;           { not used}
  236.     FDBFIndexList   : TStringList;      { List all indexes of table }
  237.     FDBFBuff        : PBigArray;        { Temp FDBFBuff for record }
  238.     FDBFCurrRec     : LongInt;          { Cursor position point to record }
  239.     FDBFCountItems  : Integer;          { Count of recors collumns }
  240.     FOnError        : TDBFError;        { Event for error administration }
  241.     FOnWarn         : TDBFError;        { Event for warnings administration }
  242.     FOnMakeFields   : TDBFMakeItems;    { For create fields in record }
  243.     FOnErase        : TDBFBeforeConfirm;{ For confirm with prune of .DBF }
  244.     FOnOverwrite    : TDBFBeforeConfirm;{ For confirm with overwrite of .DBF .IDX }
  245.     FOnAdded        : TNotifyEvent;     { If record added }
  246.     FDBFOnAltSort   : TDBFAltSort;      { Alternative sort on stringlist }
  247.     FOnChange       : TDBFChange;       { If record in change }
  248.     FOnChanged      : TNotifyEvent;     { If record is changed }
  249.     FOnDelete       : TDBFConfirm;
  250.     FOnActualize    : TDBFActualize;
  251.     FOnDeleted      : TNotifyEvent;     { If record is deleted }
  252.     FOnPassword     : TDBFPassword;     { If administrator request password check }
  253.     FOnOpened       : TDBFOpened;       { If table is opened }
  254.     FOnAsSigned     : TDBFAsSigned;     { If table attach }
  255.     FOnFound        : TNotifyEvent;     { If found record by index }
  256.     FOnErased       : TNotifyEvent;     { If table is pruned }
  257.     FOnNavigate     : TDBFNavigate;     { If navigation is called }
  258.     FOnProgress     : TDBFProgress;     { If table id updated, show percent on gauge}
  259.     FOnUpdate       : TNotifyEvent;     { If record is actualized }
  260.     FOnClosed       : TNotifyEvent;     { If table is closed}
  261.     FOnLoaded       : TNotifyEvent;     { If record attach to buffer memory }
  262.     FOnQuery        : TDBFQuery;        { For query with find statement }
  263.  
  264.     procedure SetFileName(name : string);
  265.     Function GetPassword: String;
  266.     procedure SetPassword(Const thepassword:String);
  267.     function GetRecordsCount: LongInt; { return the records count /VN/ }
  268.     function GetField(Index: Integer): TDBField; { /VN/ }
  269.     function GetFieldByName(Const Key:TKey): TDBField; { /AR/ }
  270.     function IsCurrentRecDeleted: Boolean; { /VN/ }
  271.   protected
  272.     FDBFFields    : array[1..maxFields] of TdbField;  { The field data }
  273.     procedure Fatal(Const Msg:String);
  274.     Procedure Warn(Const Msg:String);
  275.     Procedure Actualization;
  276.   public
  277.     constructor Create(AOWner : TComponent); override;
  278.     destructor Destroy; override;
  279.  
  280.     procedure Close; virtual;
  281.     Function  Open:Boolean; virtual;
  282.     Function  Write(r : longint):TStatusWrite; virtual;
  283.     procedure Seek(r : longint); virtual;
  284.     procedure NewRecord; virtual;
  285.     procedure GotoStart;
  286.     procedure GotoEnd;
  287.     procedure GotoNext;
  288.     Procedure GotoPrev;
  289.     Function  Delete(R : longint):TStatusWrite; Virtual;
  290.     Function  UpdateIndexes(R:LongInt):Boolean; Virtual;
  291.     Procedure RemoveIndexes(R:LongInt); Virtual;
  292.     procedure MakeIndex(Const IdxName:String; Const Key:TKey);{make index} Virtual;
  293.     Procedure Find(Const IdxName, Value:String);{search value by key} Virtual;
  294.     Procedure Store(Const Key:TKey; Const Rec:String);{field of record} Virtual;
  295.     Procedure ELoad(Const Key:TKey; Var Rec:String);{with conversion} Virtual;
  296.     Function  Load(Const Key:TKey):String;
  297.     Procedure Update(R:LongInt); Virtual;
  298.     procedure CreateDB(Const fname:String;rL{reclen},numFields: word); Virtual;
  299.     Function  MakeField(posit:Byte;Const iname:String;iwhat:Char;ilen:byte;
  300.                         iplaces:byte;Const idxnme:String;
  301.                         Req:TFieldReq;Sort:TSortByIndex):Boolean; Virtual;
  302.     Function  Cover:Boolean; Virtual;
  303.     Procedure UnCover; Virtual;
  304.     Procedure RemoveIndex(Const Name: String); Virtual;
  305.     Function  IsMarked:Boolean;{is in transaction?} Virtual;
  306.     Function  ReIndex:Boolean; Virtual;
  307.     Procedure IncNumRec;
  308.     Function  SaveMemo(No:LongInt;Const FName:String):Boolean; Virtual;
  309.     Function  LoadMemo(No:LongInt;Var FName:String):Boolean; Virtual;
  310.     Function  EraseMemo(No:LongInt):Boolean; Virtual;
  311.     Procedure PruneDBF; Virtual;
  312.     Procedure PruneDBT; Virtual;
  313.     property  CurrRec: LongInt read FDBFCurrRec;
  314.     property  RecordsCount: LongInt read GetRecordsCount; { /VN/ }
  315.     property  FieldsCount: Integer read FDBFCountItems; { /VN/ }
  316.     property  Fields[Index: Integer]: TDBField read GetField; { /VN/ }
  317.     property  FieldByName[Const Key:TKey]: TDBField read GetFieldByName; { /AR/ }
  318.   published
  319.     property CurrentRecDeleted : Boolean read IsCurrentRecDeleted; { changed /VN/ }
  320.     property FileIsOpen : Boolean read FDBFIsOpened;
  321.     property StoreByIndex : Boolean read FDBFStoreByIndex write FDBFStoreByIndex;
  322.     property FileIsExist : Boolean read FDBFExist;
  323.     property ReadOnly : Boolean read FDBFReadOnly write FDBFReadOnly;
  324.     property SaveOnClose : Boolean read FDBFSaveOnClose write FDBFSaveOnClose;
  325.     property ByIndex : String read FDBFIndex write FDBFIndex;
  326.     property Password : String read GetPassword write SetPassword;
  327.  
  328.     property FileName     : string read FDBFName write SetFileName;
  329.     property OnError      : TdbfError read FOnError write FOnError;
  330.     property OnWarn       : TdbfError read FOnWarn write FOnWarn;
  331.     property OnMakeFields : TDBFMakeItems read FOnMakeFields write FOnMakeFields;
  332.     property OnErase      : TDBFBeforeConfirm read FOnErase write FOnErase;
  333.     property OnOverwrite  : TDBFBeforeConfirm read FOnOverwrite write FOnOverwrite;
  334.     property OnAdded      : TNotifyEvent read FOnAdded write FOnAdded;
  335.     property OnAltSort    : TDBFAltSort read FDBFOnAltSort write FDBFOnAltSort;
  336.     property OnChange     : TDBFChange read FOnChange write FOnChange;
  337.     property OnChanged    : TNotifyEvent read FOnChanged write FOnChanged;
  338.     property OnDelete     : TDBFConfirm read FOnDelete  write FOnDelete;
  339.     property OnDeleted    : TNotifyEvent read FOnDeleted write FOnDeleted;
  340.     property OnPassword   : TDBFPassword read FOnPassword write FOnPassword;
  341.     property OnOpened     : TDBFOpened read FOnOpened write FOnOpened;
  342.     property OnAsSigned   : TDBFAsSigned read FOnAsSigned write FOnAsSigned;
  343.     property OnFound      : TNotifyEvent read FOnFound write FOnFound;
  344.     property OnErased     : TNotifyEvent read FOnErased write FOnErased;
  345.     property OnNavigate   : TDBFNavigate read FOnNavigate write FOnNavigate;
  346.     property OnProgress   : TDBFProgress read FOnProgress write FOnProgress;
  347.     property OnUpdate     : TNotifyEvent read FOnUpdate write FOnUpdate;
  348.     property OnClosed     : TNotifyEvent read FOnClosed write FOnClosed;
  349.     property OnLoaded     : TNotifyEvent read FOnLoaded write FOnLoaded;
  350.     property OnActualize  : TDBFActualize read FOnActualize write FOnActualize;
  351.     property OnQuery      : TDBFQuery read FOnQuery write FOnQuery;
  352.   end;
  353.  
  354. procedure Register;
  355.  
  356. implementation
  357.  
  358. {----------------------------------------------------------------------------}
  359. procedure Register;
  360. {----------------------------------------------------------------------------}
  361. begin
  362.   RegisterComponents('Lib', [TjbDBF]);
  363. end;
  364.  
  365. {$IFDEF VER80}
  366. {----------------------------------------------------------------------------}
  367. Function Trim(Const S:String):String;
  368. {----------------------------------------------------------------------------}
  369. Begin
  370.   Result:=S;
  371.   While (Length(Result)>0) And (Result[1] <= ' ') Do
  372.     System.Delete(Result,1,1);
  373.   While (Length(Result)>0) And (Result[Length(Result)] <= ' ') Do
  374.     System.Delete(Result,Length(Result),1);
  375. End;
  376. {$ENDIF}
  377.  
  378. {----------------------------------------------------------------------------}
  379. Constructor TjbDBF.Create(AOwner : TComponent);
  380. {----------------------------------------------------------------------------}
  381. Begin
  382.   Inherited Create(AOwner);
  383.   FDBFIsOpened := False;
  384.   FileName := '';
  385.   FDBFBuff := Nil;
  386.   FDBFIndexList := TStringList.Create;
  387.   FDBFStoreByIndex := False;
  388.   FDBFExist := False;
  389.   FDBFReadOnly := False;
  390.   FDBFSaveOnClose := False;
  391. End;
  392.  
  393. {----------------------------------------------------------------------------}
  394. Destructor TjbDBF.Destroy;
  395. {----------------------------------------------------------------------------}
  396. Begin
  397.   {kdyby byla nahodou tabulka otevrena, tak ji explicitne uzavri}
  398.   {when table was opened then explicit close it}
  399.   If FDBFIsOpened Then
  400.     close;
  401.   {uvolni instanci seznamu}
  402.   {free list}
  403.   FDBFIndexList.Free;
  404.   Inherited destroy;
  405. End;
  406.  
  407. {----------------------------------------------------------------------------}
  408. procedure TjbDBF.SetFileName(name : string);
  409. {----------------------------------------------------------------------------}
  410. Begin
  411.   {kdyby byla nahodou tabulka otevrena, tak ji explicitne uzavri}
  412.   {when table was opened then explicit close it}
  413.   If FDBFIsOpened Then
  414.     Close;
  415.   {a pak zmen jmeno}
  416.   {and change name after them}
  417.   FDBFName:=name;
  418.   {prirazeni jmena oznam, a nabidni k pripadne zmene zvenku}
  419.   {give a message if name assigned for possible outside change}
  420.   If AsSigned(FOnAsSigned) Then FOnAsSigned(Self, FDBFName);
  421.   FDBFName:=LowerCase(FDBFName);
  422.   {test, zda tabulka existuje, neexistuje-li, bude potreba ji zalozit}
  423.   {test for table exists - when not exists, create it latter}
  424.   FDBFExist:=FileExists(FDBFName);
  425. End;
  426.  
  427. {----------------------------------------------------------------------------}
  428. Function TjbDBF.GetPassword: String;
  429. {----------------------------------------------------------------------------}
  430. Begin
  431.   Result := LowerCase(FDBFPassword)
  432. End;
  433.  
  434. {----------------------------------------------------------------------------}
  435. procedure TjbDBF.SetPassword(Const thepassword:String);
  436. {----------------------------------------------------------------------------}
  437. Begin
  438.   FDBFPassword := thepassword
  439. End;
  440.  
  441. {----------------------------------------------------------------------------}
  442. Function TjbDBF.Open:Boolean;
  443. {----------------------------------------------------------------------------}
  444. var
  445.   Temp : TdbField;
  446.   Done : Boolean;
  447.   Readed:{$IfDef VER80}Word{$Else}Integer{$EndIf};
  448.   Pass : String;
  449. begin
  450.   Result := False;
  451.   {kdyby nahodou byla tabulka otevrena, tak ji zavri}
  452.   {sloce table}
  453.   If FDBFIsOpened Then Close;
  454.   {neexistuje-li tabulka, nedelej nic}
  455.   {when table not exists, do nothing}
  456.   If Not FDBFExist Then Exit;
  457.  
  458.   done:=FALSE;
  459.  
  460.   If AsSigned(FOnPassword) Then FOnPassword(Self,Pass);
  461.   {prikryti heslem je mozne overit tady}
  462.   {cover by password validate here}
  463.   If FDBFPassword<>'' Then
  464.     If Pass<>FDBFPassword Then Begin
  465.       Fatal(msgNoPasswordMatch);
  466.       Exit;
  467.     End;
  468.   {otevreni pres handle}
  469.   {open through handle}
  470.   AsSignFile(FDBFHandle,FDBFName);
  471.   Try
  472.     Reset(FDBFHandle,1);
  473.     {kdyz se povedlo, zustane otevrena az do close}
  474.     {if success, stay open to close}
  475.     FDBFIsOpened:=True;
  476.     {vyzvedni si header}
  477.     {get header}
  478.     BlockRead(FDBFHandle,FDBFHeader,sizeof(TDBFHeader)); { Get the header }
  479.     {tohle bude pracovni buffer, kam budes davat data}
  480.     {working data buffer is here}
  481.     GetMem(FDBFBuff,FDBFHeader.RecLen);
  482.     {tady ctes polozky/sloupce a v tehle promenn vzdy budou}
  483.     {reading field here}
  484.     FDBFCountItems:=0;
  485.     Repeat
  486.       {cti obezretne, co kdybys narazil na neocekacany konec}
  487.       {read circumspection what about giv unexpected end of file }
  488.       {$I-}
  489.       BlockRead(FDBFHandle,temp,SizeOf(TdbField),Readed);
  490.       {$I+}
  491.       If Temp.name[0]<>#$0D then
  492.         Begin
  493.           {ukazuj na prvni volny}
  494.           {show first free}
  495.           inc(FDBFCountItems);
  496.           FDBFFields[FDBFCountItems]:=temp;
  497.           fillchar(temp,SizeOf(temp),0);
  498.         End
  499.       Else
  500.         Begin
  501.           done:=TRUE;
  502.           {jsou-li nacteny prave dva znaky, tabulka je prazdna, uprav pozici}
  503.           {when two chars readed, table is empty, correct position}
  504.           If readed=2 Then
  505.             System.Seek(FDBFHandle,System.FilePos(FDBFHandle)-1)
  506.           {jinak se postav na prvni zaznam a nacti ho do bufferu}
  507.           {other stay on first record and read it into buffer}
  508.           Else seek(0);
  509.         End;
  510.     Until DONE;
  511.     {seek(0);}
  512.     If AsSigned(FOnOpened) Then FOnOpened(Self,FDBFIsOpened);
  513.     Result := True;
  514.   Except
  515.     Fatal(msgErrorOnOpen)
  516.   End;
  517. End;
  518.  
  519. {----------------------------------------------------------------------------}
  520. procedure TjbDBF.Close;
  521. {----------------------------------------------------------------------------}
  522. Var B:Byte;
  523. Begin
  524.   {nasleduje test EOF mark a oznaceni kdyz chybi}
  525.   {tohle ale lze udelat v pripade, kdyz soubor neni read only}
  526.   {je-li read only, zahlasi se chyba a nejde soubor opravit}
  527.   {follow EOF mark test; if missing}
  528.   {do it when isn't file read-only only}
  529.   {if read only get error message and do not repair it}
  530.  
  531.   System.Seek(FDBFHandle,FileSize(FDBFHandle)-1);
  532.   Blockread(FDBFHandle,b,1);
  533.   If B<>$1A Then Begin
  534.     If Not FDBFReadOnly And Not IsMarked Then
  535.       Begin
  536.         {je-li povoleno stouchni tam posledni zaznam}
  537.         {when consented, poke last record there}
  538.         If FDBFSaveOnClose Then Write(CurrRec);
  539.         B:=$1A;
  540.         BlockWrite(FDBFHandle,B,1);
  541.       End
  542.     Else
  543.       Fatal(msgEOFmarkMiss)
  544.   End;
  545.   CloseFile(FDBFHandle);
  546.   {date of actualization}
  547.   Actualization;
  548.   FDBFIsOpened:=False; {message - file closed}
  549.   If AsSigned(FOnClosed) Then FOnClosed(Self);
  550.   FreeMem(FDBFBuff,FDBFHeader.RecLen);{ free allocated buffer}
  551. end;
  552.  
  553. {----------------------------------------------------------------------------}
  554. Function TjbDBF.Write(R : LongInt):TStatusWrite;
  555. {hlavni funkce zapisu, data jsou vzdy ukladana na pozadani}
  556. {main function for write, data store for request}
  557. {----------------------------------------------------------------------------}
  558. Var Cancel:Boolean;
  559. Begin
  560.   Result := dbfError;
  561.   {zapis muze byt proveden pouze v pripade ze neni jen pro cteni, existuje a je otevren}
  562.   {write can be do only when isn't read-only or exists or is opened}
  563.   If FDBFReadOnly Or Not FDBFExist Or Not FDBFIsOpened Then Exit;
  564.   {nastav pro pripad, kdyby to pouzival jiny proces}
  565.   {set for occur, if it use other process}
  566.   Result := dbfBusy;
  567.   {je nastaveno navesti transakce, tj. pouziva to nekdo jiny}
  568.   {is set signal label of transaction -> use it another process}
  569.   If Not IsMarked Then Begin
  570.     {ale ted ho chces pouzit ty}
  571.     {but now it want use you}
  572.     Cover;
  573.     Try
  574.       {priznak storna}
  575.       {cancel prompt}
  576.       Result := dbfCancel;
  577.       Cancel := False;
  578.       If FDBFCurrRec <> R Then FDBFCurrRec := R;
  579.       {kdykoliv zapisujes, pak menis zaznam; zde ho lze odvolat}
  580.       {write any time, you change record -> you can cancel here}
  581.       If AsSigned(FOnChange) Then FOnChange(Self, Cancel);
  582.       {je-li zaznam odvolan, zapis nebude proveden}
  583.       {when record canceled, no write}
  584.       If Cancel Then Exit;
  585.       {priznak chyby}
  586.       {error prompt}
  587.       Result := dbfError;
  588.       {pokousis se updatovat indexy}
  589.       {you can update of indexes}
  590.       Try
  591.         {jsou-li updatovany}
  592.         {if updated now}
  593.         If UpdateIndexes(R) Then Begin
  594.           Try
  595.             {vyhledej fyzicky zaznam k prepisu}
  596.             {search physical record for overwrite}
  597.             System.Seek(FDBFHandle,R * FDBFHeader.recLen + FDBFHeader.headLen);
  598.             {nastav signal pro platny zapis - zaznam je platny}
  599.             {set prompt for true write -> record is OK}
  600.             FDBFBuff^[0]:=' '; { Record not deleted! }         {uncomment /AR/ }
  601.             {zapis ho na vyhledane misto}
  602.             {write it to found place}
  603.             BlockWrite(FDBFHandle,FDBFBuff^,FDBFHeader.RecLen);
  604.  
  605.             Actualization;
  606.             {teprve tady je vsechno OK}
  607.             {only here is OK}
  608.             Result := dbfOK;
  609.           Except
  610.             On EInOutError Do Begin
  611.               Fatal(msgErrorOnWrite);
  612.               Result := dbfError;
  613.             End;
  614.           End;
  615.           {zahlas, zes zaznam zmenil}
  616.           {get message - record is changed}
  617.           If AsSigned(FOnChanged) Then FOnChanged(Self);
  618.         End;
  619.       Except
  620.         {v pripade vyskytu nejake chyby je ale musis odstranit}
  621.         {but when error ocurred, have to remove all}
  622.         RemoveIndexes(R)
  623.       End
  624.     Finally
  625.       {a tady ho zase mohou pouzivat jini}
  626.       {and there can use it others}
  627.       UnCover;
  628.     End;
  629.   End;
  630. End;
  631.  
  632. {----------------------------------------------------------------------------}
  633. Function TjbDBF.Delete(R : longint):TStatusWrite;
  634. {----------------------------------------------------------------------------}
  635. Var Confirm : Boolean;
  636. Begin
  637.   Result:=dbfError;
  638.   {zapis muze byt proveden pouze v pripade ze neni jen pro cteni, existuje a je otevren}
  639.   {write can be do only when isn't read-only or exists or is opened}
  640.   If FDBFReadOnly Or Not FDBFExist Or Not FDBFIsOpened Then Exit;
  641.   Result:=dbfBusy;
  642.   If Not IsMarked Then Begin
  643.     Cover;
  644.     Try
  645.       {zadej o svoleni s vymazanim vety}
  646.       {require consent record delete}
  647.       If AsSigned(FOnDelete) Then FOnDelete(Self, Confirm) Else Confirm := True;
  648.       If Confirm Then
  649.       Begin
  650.         Try
  651.           {nezmenil-li se zaznam od aktualniho}
  652.           {when actual record is the same as required}
  653.           If FDBFCurrRec <> R Then FDBFCurrRec := R;
  654.           {vyhledej ho v zaznamech}
  655.           {seek new position}
  656.           System.Seek(FDBFHandle,R * FDBFHeader.recLen + FDBFHeader.headLen);
  657.           {nastav priznak vymazani}
  658.           {set erase label }
  659.           FDBFBuff^[0]:=DeleteFlag; { Record is deleted! }
  660.           {zapis do souboru}
  661.           {write it into file}
  662.           BlockWrite(FDBFHandle,FDBFBuff^,FDBFHeader.recLen);
  663.           {aktualizuj indexy, tj. odstran z nich vymazany zaznam}
  664.           {and do index actualizing }
  665.           RemoveIndexes(R);
  666.  
  667.           Actualization;
  668.           Result:=dbfOk;  { /AR/ }
  669.         Except
  670.           On EInOutError Do Fatal(msgCannotDeleteItem);
  671.         End;
  672.         {oznam zes vymazal}
  673.         {and get message}
  674.         If AsSigned(FOnDeleted) Then FOnDeleted(Self);
  675.       End;
  676.     Finally
  677.       UnCover;
  678.     End
  679.   End;
  680. End;
  681.  
  682. {----------------------------------------------------------------------------}
  683. procedure TjbDBF.Seek(R : LongInt);
  684. {----------------------------------------------------------------------------}
  685. var
  686.   L      : LongInt;
  687.   Readed : {$IfDef VER80}Word{$Else}Integer{$EndIf};
  688. begin
  689.   If Not FDBFExist Or Not FDBFIsOpened Then Exit;
  690.   {nezmenil-li se zaznam od aktualniho}
  691.   {when actual record is the same as required}
  692.   If FDBFCurrRec <> R Then FDBFCurrRec := R;
  693.   {fyzicka delka zacatku vet}
  694.   {physical size of record begins}
  695.   L := R * FDBFHeader.recLen + FDBFHeader.headLen;
  696.   {kdyz je nahodou za}
  697.   {when beyond}
  698.   If L > (FileSize(FDBFHandle)-1) Then Exit;
  699.   {postav se tam}
  700.   {stay here}
  701.   System.Seek(FDBFHandle, L);
  702.   {precti vetu do bufferu}
  703.   {read record into buffer}
  704.   BlockRead(FDBFHandle, FDBFBuff^, FDBFHeader.RecLen, Readed);
  705.   {veta je uspesne nactena, jen kdyz je v bufferu cela}
  706.   {when all readed}
  707.   If FDBFHeader.RecLen = Readed Then
  708.     {a zahlas zes ji precetl}
  709.     {get message}
  710.     If AsSigned(FOnLoaded) Then FOnLoaded(Self);
  711. end;
  712.  
  713. {----------------------------------------------------------------------------}
  714. procedure TjbDBF.GotoStart;
  715. {----------------------------------------------------------------------------}
  716. begin
  717.   If Not FDBFExist Or Not FDBFIsOpened Then Exit;
  718.   {nastav se na prvni zaznam}
  719.   {seek to first}
  720.   Seek(0);
  721.   {zahlas pro navigaci, ze na nem stojis}
  722.   {and get message for navigation your position}
  723.   If AsSigned(FOnNavigate) Then FOnNavigate(Self, 0);
  724. end;
  725.  
  726. {----------------------------------------------------------------------------}
  727. procedure TjbDBF.GotoEnd;
  728. {----------------------------------------------------------------------------}
  729. begin
  730.   If Not FDBFExist Or Not FDBFIsOpened Then Exit;
  731.   {nastav se na posledni zaznam}
  732.   {seek to last}
  733.   Seek(FDBFHeader.numRecs-1);
  734.   {zahlas pro navigaci, ze na nem stojis}
  735.   {and get message for navigation your position}
  736.   If AsSigned(FOnNavigate) Then FOnNavigate(Self, FDBFHeader.numRecs-1);
  737. end;
  738.  
  739. {----------------------------------------------------------------------------}
  740. procedure TjbDBF.GotoNext;
  741. {----------------------------------------------------------------------------}
  742. begin
  743.   If Not FDBFExist Or Not FDBFIsOpened Then Exit;
  744.   {nastav se na nasledujici zaznam}
  745.   {seek to next}
  746.   Seek(FDBFCurrRec+1);
  747.   {zahlas pro navigaci, ze na nem stojis}
  748.   {and get message for navigation your position}
  749.   If AsSigned(FOnNavigate) Then FOnNavigate(Self, FDBFCurrRec+1);
  750. end;
  751.  
  752. {----------------------------------------------------------------------------}
  753. Procedure TjbDBF.GotoPrev;
  754. {----------------------------------------------------------------------------}
  755. begin
  756.   If Not FDBFExist Or Not FDBFIsOpened Then Exit;
  757.   {nastav se na predchazejici zaznam}
  758.   {seek to previous}
  759.   Seek(FDBFCurrRec-1);
  760.   {zahlas pro navigaci, ze na nem stojis}
  761.   {and get message for navigation your position}
  762.   If AsSigned(FOnNavigate) Then FOnNavigate(Self, FDBFCurrRec-1);
  763. end;
  764.  
  765. {----------------------------------------------------------------------------}
  766. procedure TjbDBF.NewRecord;
  767. {----------------------------------------------------------------------------}
  768. begin
  769.   {nemuzes nic pridavat, kdyz je jen ke cteni, nebo neexistuje, neni otevren}
  770.   {cannot do when is read-only or no exists or is closed}
  771.   If FDBFReadonly Or Not FDBFExist Or Not FDBFIsOpened Then Exit;
  772.   If Not IsMarked Then Begin
  773.     Cover;
  774.     Try
  775.       {vycisti buffer}
  776.       {clear buffer}
  777.       {FillChar(FDBFBuff^,FDBFHeader.RecLen,' ');}
  778.       {zde je mozne udelat implicitni naplneni zaznamu, coz vrele doporucuji}
  779.       {can do implicit fill of record (I recommend to)}
  780.       If AsSigned(FOnActualize) Then FOnActualize(Self,dbfNew);
  781.       Try
  782.         {zvyz pocet zaznamu a uloz je do hlavicky}
  783.         {increment count of records and save it}
  784.         IncNumRec;
  785.         {jdi na fyzicky zacatek}
  786.         {go to start}
  787.         System.Seek(FDBFHandle,0);
  788.         {zapis hlavicku}
  789.         {write header}
  790.         BlockWrite(FDBFHandle,FDBFHeader,SizeOf(TDBFHeader));
  791.         {zapis-vloz novy zaznam na konec}
  792.         {write-insert new record to end}
  793.         Write(FDBFHeader.numRecs-1);
  794.         {nastav se na ten zaznam a aktualizuj buffer}
  795.         {set position to new record and do buffer actual}
  796.         Seek(FDBFHeader.numRecs-1);
  797.       Except
  798.         On EInOutError Do Fatal(msgCannotAddItem);
  799.       End;
  800.       {a pripadne zahlas, ze zaznam byl pridan}
  801.       {and get message when added}
  802.       If AsSigned(FOnAdded) Then FOnAdded(Self);
  803.     Finally
  804.       UnCover;
  805.     End;
  806.   End;
  807. end;
  808.  
  809. {----------------------------------------------------------------------------}
  810. procedure TjbDBF.CreateDB(Const fname:String;rL{reclen},numFields: word);
  811. {----------------------------------------------------------------------------}
  812. Var
  813.   y,m,d : Word;
  814.   c:Char;
  815.   i,j:Byte;
  816. Begin
  817.   {kdyby byla nahodou tabulka otevrena, tak ji explicitne uzavri}
  818.   {close table}
  819.   If FDBFIsOpened Then
  820.     Close;
  821.  
  822.   {vytvatis novou tabulku, zde je hlavicka}
  823.   {for new table refill header}
  824.   FillChar(FDBFHeader,SizeOf(FDBFHeader),0);
  825.   With FDBFHeader Do Begin
  826.     version:=$3;
  827.     DecodeDate(Date,y,m,d); {create date}
  828.     year:=y Mod 100;
  829.     month:=Lo(m);
  830.     day:=Lo(d);
  831.     numRecs:=0;
  832.     headLen:=SizeOf(FDBFHeader)+SizeOf(TDBFHeader) * numFields + 1;
  833.     recLen:=rl + 1; {begins delete flag}
  834.   End;
  835.   {tohle je nove jmeno tabulky}
  836.   {new table name}
  837.   FDBFName:=fname;
  838.   {priprav ji k fyzickemu zalozeni}
  839.   {prepare it for physical store}
  840.   AsSignFile(FDBFHandle,FDBFName);
  841.   Try
  842.     ReWrite(FDBFHandle,1);
  843.     Try
  844.       {zalozeni se povedlo, tabulka je otevrena}
  845.       {create id OK, table wil be open}
  846.       FDBFIsOpened:=TRUE;
  847.       {zapis hlavicku}
  848.       {write header}
  849.       BlockWrite(FDBFHandle,FDBFHeader,sizeof(TDBFHeader));
  850.       {pro stanoveny pocet sloupcu prochazej}
  851.       {go by columns}
  852.       For i:=1 To numFields Do Begin
  853.         {jestlize je attachnuty event pro vyrobu pole on line tak ho zavolej}
  854.         {jinak je predpokladano ze pred volanim teto metody byly
  855.          vytvoreny sloupce pomoci MakeField()}
  856.         {on line create field}
  857.         {else before create vas MakeField called}
  858.         If AsSigned(FOnMakeFields) Then Begin
  859.           {zavolej ho tolikrat, kolik je potreba vyrobit poli}
  860.           {call by columns count}
  861.           FillChar(FDBFFields[i],SizeOf(FDBFFields[i]),0);
  862.           {zavolej ho a vyrob zaznam}
  863.           {make field here}
  864.           With FDBFFields[I] Do
  865.             FOnMakeFields(Self,I,Name,What,Len,Places,idx,idxtyp,idxsrt);
  866.           {uprav na velka pismena}
  867.           {upper case only please}
  868.           For j:=0 to 10 Do FDBFFields[i].Name[j]:=UpCase(FDBFFields[i].Name[j]);
  869.           FDBFFields[i].What := UpCase(FDBFFields[i].What);
  870.         End;
  871.         {zapis nove vyrobene pole}
  872.         {write new made field}
  873.         BlockWrite(FDBFHandle,FDBFFields[i],sizeof(TdbField))
  874.       End;
  875.       {za hlavickou nasleduje vzdy CR}
  876.       {over header poke CR mark}
  877.       c:=#$0D;
  878.       BlockWrite(FDBFHandle,c,1);
  879.       {konec souboru je indikovan EOF mark}
  880.       {end of file poke EOF mark}
  881.       c:=#26;
  882.       BlockWrite(FDBFHandle,c,1);
  883.     Finally
  884.       {tady soubor fyzicky zavri}
  885.       {and here file physicaly close}
  886.       CloseFile(FDBFHandle);
  887.     End;
  888.   Except
  889.     {ejhle, chyba; tak ji zahlas}
  890.     {ooh, error -> have to message}
  891.     Fatal(msgCreateDBFError)
  892.   End;
  893.   {tabulka je stale uzavrena}
  894.   {table still close}
  895.   FDBFIsOpened:=False;
  896. End;
  897.  
  898. {----------------------------------------------------------------------------}
  899. Function  TjbDBF.MakeField( posit:Byte;
  900.                           Const iname:String;
  901.                           iwhat:Char;
  902.                           ilen:byte;
  903.                           iplaces:byte;
  904.                           Const idxnme:String;{filename xxxxxxxxIDX}
  905.                           Req:TFieldReq;
  906.                           Sort:TSortByIndex
  907.                         ):Boolean;
  908. {----------------------------------------------------------------------------}
  909. Var
  910.   I:byte;
  911.   S:String;
  912.   X:String[8];
  913. Begin
  914.   Result := False;
  915.   If (Trim(IName)='') Or Not(UpCase(IWhat) in TdbTypes) Or (ILen = 0) Then Begin
  916.     Fatal(msgBadDefinitionOfField);
  917.     Exit;
  918.   End;
  919.   Result := True;
  920.   FillChar(FDBFFields[posit],SizeOf(FDBFFields[posit]),0);
  921.   With FDBFFields[posit] Do Begin
  922.     {prvnich 11 znaku, velka pismena}
  923.     {first 11 chars, uppercase please}
  924.     S:=Copy(UpperCase(Trim(IName)),1,11);
  925.     Move(S[1],Name,Length(S));
  926.     What   := UpCase(IWhat);
  927.     {tyhle polozky (cas, datum, memo) maji fixni tvar}
  928.     {format is fixed (time, date, memo...)}
  929.     Case What of
  930.       'T': Len := 6;
  931.       'D': Len := 8;
  932.       'M': Len := 10;
  933.       'F':
  934.       Begin
  935.         Len := iLen; {bugfix by Jarda Jirava [<mailto:listuj@centrum.cz>]  18.4.2001}
  936.         Places := IPlaces; {tohle je jenom pro float/float only}
  937.       End;
  938.  
  939.     Else
  940.       Len    := ILen;
  941.     End;
  942.  
  943.     If (IdxNme<>'') Then Begin
  944.       I:=Pos('.',IdxNme);
  945.       If I>0 Then Begin
  946.         S:=Trim(Copy(IdxNme,I+1,3));
  947.         If Length(S)<3 Then While Length(S)<3 Do S:=S+SpacerD;
  948.         X:= Trim(Copy(IdxNme,1,I-1));
  949.         If Length(X)<8 Then While Length(X)<8 Do X:=SpacerD+X;
  950.         S:=X+S;
  951.       End
  952.       Else Begin
  953.         X:=Trim(IdxNme);
  954.         If Length(X)<8 Then While Length(X)<8 Do X:=SpacerD+X;
  955.         S:=X+'IDX';
  956.       End;
  957.       S:=UpperCase(S);
  958.       Move(S[1],idx,11);
  959.     End;
  960.   End;
  961. End;
  962.  
  963. {----------------------------------------------------------------------------}
  964. Procedure TjbDBF.Fatal(Const Msg:String);
  965. {----------------------------------------------------------------------------}
  966. Begin
  967.   {kdyz je vnejsi zpracovani msg, tak ho zavolej, jinak ukaz vlastni}
  968.   {outside messages}
  969.   If AsSigned(FOnError) Then FOnError(Self,msg)
  970.   Else
  971.     {inside messages}
  972.     MessageDlg(msg, mtError, [mbOk], 0);
  973. End;
  974.  
  975. {----------------------------------------------------------------------------}
  976. Procedure TjbDBF.Warn(Const Msg:String);
  977. {----------------------------------------------------------------------------}
  978. Begin
  979.   {s varovanim je to stejne tak}
  980.   {inside/outside}
  981.   If AsSigned(FOnWarn) Then FOnWarn(Self,msg)
  982.   Else
  983.     MessageDlg(msg, mtWarning, [mbOk], 0);
  984. End;
  985.  
  986. {----------------------------------------------------------------------------}
  987. Function  TjbDBF.UpdateIndexes(R:LongInt):Boolean;
  988. {----------------------------------------------------------------------------}
  989. Var
  990.   I,J,L:LongInt;
  991.   TempFName:String;
  992.   F:File;
  993.   T:TStringList;
  994.   S,X:String;
  995.   UpdateField:Boolean;
  996. Begin
  997.   {indikace uspesneho  ukonceni}
  998.   {all OK}
  999.   Result := True;
  1000.   {indexy se aktualizuji zde, ale jen kdyz to chces}
  1001.   {can you actualise index ?}
  1002.   If Not FDBFStoreByIndex Then Exit;
  1003.   {doslo-li k uspesnemu updatu, funkce vrati True jinak udela removeindexes}
  1004.   {if NOT OK then remove indexes}
  1005.   For I:=1 To FDBFCountItems Do Begin
  1006.     {prochazis vsechny sloupce a hledas indexovy soubor}
  1007.     {go through columns and search index file}
  1008.     If Trim(FDBFFields[I].Idx)<>'' Then Begin
  1009.       {indexovy soubor byl nalezen}
  1010.       {jeho jmeno je ve tvaru xxxxxxxxIDX, vzdy zarovnan vpravo}
  1011.       {vyplne jsou SpacerD tj. "~~~JMENOIDX" nebo "~~ZAMESTID~"}
  1012.       {vyrob temp jmeno souboru}
  1013.       {found, format index filename}
  1014.       TempFName:=ExtractFilePath(FDBFName)
  1015.        +Trim(Copy(FDBFFields[I].Idx,1,8)+'.'+Copy(FDBFFields[I].Idx,9,3));
  1016.       If FileExists(TempFName) Then Begin
  1017.         AsSignFile(F,TempFName);
  1018.         Try
  1019.           ReSet(F,1);
  1020.           Try
  1021.             UpdateField:=False;
  1022.             {proc nepouzit k indexum stringlist?}
  1023.             {why don't use stringlist?}
  1024.             T:=TStringList.Create;
  1025.             Try
  1026.               {budes tridit radky}
  1027.               {will be assort lines}
  1028.               T.Sorted:=True;
  1029.               {nastavujes vlastnost duplicit}
  1030.               {and property duplicit by type of index}
  1031.               Case FDBFFields[I].idxtyp Of
  1032.                 dbfUnique:T.Duplicates := dupError;
  1033.                 dbfDuplicates:T.Duplicates := dupAccept;
  1034.               End;
  1035.               While Not Eof(F) Do Begin
  1036.                 {uprava indexu je zde}
  1037.                 {adapt index here}
  1038.                 BlockRead(F,S[1],FDBFFields[I].len+SizeOf(L));
  1039.                 Move(S[1],L,SizeOf(L));
  1040.                 {neni tam nahodou uz nektery k uprave?}
  1041.                 {if adapted?}
  1042.                 If R=L Then Begin
  1043.                   ELoad(FDBFFields[I].Name,X);
  1044.                   Move(X[1],S[5],Length(X));{zkus ho tam pridat}
  1045.                   UpdateField:=True;
  1046.                 End;
  1047.                 Try
  1048.                   T.Add(' '+Copy(S,5,255)+#1+IntToStr(L));
  1049.                 Except
  1050.                   On EListError Do
  1051.                     If T.Duplicates = dupError Then Begin
  1052.                       Warn(msgDuplicateInUnique);
  1053.                       Result:=False;
  1054.                       Exit;
  1055.                     End;
  1056.                 End;
  1057.               End{while};
  1058.               {vlozil jsi vsechny ze souboru, tak ted zkus primy}
  1059.               {all added, try direct}
  1060.               If Not UpdateField Then Begin
  1061.                 ELoad(FDBFFields[I].Name,X);
  1062.                 Try
  1063.                   T.Add(' '+X+#1+IntToStr(R));
  1064.                 Except
  1065.                   On EListError Do
  1066.                     If T.Duplicates = dupError Then Begin
  1067.                       Warn(msgDuplicateInUnique);
  1068.                       Result:=False;
  1069.                       Exit;
  1070.                     End;
  1071.                 End;
  1072.               End;
  1073.               {byl-li index uspesne vlozen, uloz indexovy soubor}
  1074.               {when index is OK, save as file}
  1075.               ReWrite(F,1);{vymaz puvodni}
  1076.               Case FDBFFields[I].idxsrt Of
  1077.                 dbfAscending:
  1078.                 Begin
  1079.                   For J := 0 To T.Count-1 Do Begin
  1080.                     S:=T.Strings[J];
  1081.                     L:=StrToInt(Copy(S,Pos(#1,S)+1,255));
  1082.                     S:='   '+Copy(S,1,Pos(#1,S)-1);
  1083.                     Move(L,S[1],SizeOf(L));
  1084.                     BlockWrite(F,S[1],Length(S));
  1085.                   End;
  1086.                 End;
  1087.                 dbfDescending:
  1088.                 Begin
  1089.                   For J := T.Count - 1 DownTo 0 Do Begin
  1090.                     S:=T.Strings[J];
  1091.                     L:=StrToInt(Copy(S,Pos(#1,S)+1,255));
  1092.                     S:='   '+Copy(S,1,Pos(#1,S)-1);
  1093.                     Move(L,S[1],SizeOf(L));
  1094.                     BlockWrite(F,S[1],Length(S));
  1095.                   End;
  1096.                 End;
  1097.                 dbfAlternative:
  1098.                 Begin
  1099.                   {Potrebujete-li to, tak jedine doprogramovat}
  1100.                   {if you want you have to coplete do it}
  1101.                   If AsSigned(FDBFOnAltSort) Then FDBFOnAltSort(Self,T);
  1102.                   {a uloz to ...}
  1103.                   {and save it...}
  1104.                   For J:=0 To T.Count-1 Do Begin
  1105.                     S:=T.Strings[J];
  1106.                     L:=StrToInt(Copy(S,Pos(#1,S)+1,255));
  1107.                     S:='   '+Copy(S,1,Pos(#1,S)-1);
  1108.                     Move(L,S[1],SizeOf(L));
  1109.                     BlockWrite(F,S[1],Length(S));
  1110.                   End;
  1111.                 End;
  1112.               End;
  1113.             Finally
  1114.               T.Free {zahod ho} {throw off}
  1115.             End;
  1116.             {idxsrt:TSortByIndex = (dbfAscending, dbfDescending, dbfAlternative);}
  1117.           Finally
  1118.             CloseFile(F);
  1119.           End;
  1120.         Except
  1121.           Fatal(Format(msgIdxTableNotFound,[ExtractFileName(TempFName)]));
  1122.         End;
  1123.       End
  1124.       Else Begin
  1125.         AsSignFile(F,TempFName);
  1126.         {tabulka jeste neexistuje}
  1127.         {table doesn't exist}
  1128.         ReWrite(F,1);
  1129.         ELoad(FDBFFields[I].Name,X);
  1130.         Move(R,S[1],SizeOf(R));
  1131.         Move(X[1],S[5],Length(X));{try it add there}
  1132.         BlockWrite(F,S[1],Length(X)+SizeOf(R));
  1133.         CloseFile(F);
  1134.       End;
  1135.     End;
  1136.   End;
  1137. End;
  1138.  
  1139. {----------------------------------------------------------------------------}
  1140. Procedure TjbDBF.RemoveIndexes(R:LongInt);
  1141. {----------------------------------------------------------------------------}
  1142. Var
  1143.   I:Integer;
  1144.   L:LongInt;
  1145.   TempFName,S:String;
  1146.   F,Fnew:File;
  1147. Begin
  1148.   {je-li nejaky zaznam vymazan, musi se tez odstranit ze vsech indexu}
  1149.   {when is some record deleted, have to delete from all indexes too}
  1150.   For I:=1 To FDBFCountItems Do Begin
  1151.     {prochazis vsechny sloupce a hledas indexovy soubor}
  1152.     {for through columns}
  1153.     If Trim(FDBFFields[I].Idx)<>'' Then Begin
  1154.       {indexovy soubor byl nalezen}
  1155.       {jeho jmeno je ve tvaru xxxxxxxxIDX, vzdy zarovnan vpravo}
  1156.       {vyplne jsou SpacerD tj. "~~~JMENOIDX" nebo "~~ZAMESTID~"}
  1157.       {vyrob temp jmeno souboru}
  1158.       {found, format name}
  1159.       TempFName:=ExtractFilePath(FDBFName)
  1160.        +Trim(Copy(FDBFFields[I].Idx,1,8)+'.'+Copy(FDBFFields[I].Idx,9,3));
  1161.       AsSignFile(F,TempFName);
  1162.       Try
  1163.         ReSet(F,1);
  1164.         Try
  1165.           AsSignFile(Fnew,ChangeFileExt(TempFName,'.$$$'));
  1166.           Try
  1167.             ReWrite(Fnew,1);
  1168.             Try
  1169.             While Not Eof(f) Do Begin
  1170.               BlockRead(F,S[1],FDBFFields[I].len+SizeOf(L));
  1171.               Move(S[1],L,SizeOf(L));
  1172.               If L<>R Then Begin
  1173.                 BlockWrite(Fnew,S[1],FDBFFields[I].len+SizeOf(L))
  1174.               End;
  1175.             End;
  1176.             Finally
  1177.               CloseFile(Fnew);
  1178.             End;
  1179.           Except
  1180.             Warn(msgNotEnoughtCreateIdx)
  1181.           End;
  1182.         Finally
  1183.           CloseFile(F);
  1184.           If FileExists(ChangeFileExt(TempFName,'.$$$')) Then Begin
  1185.             DeleteFile(TempFName);
  1186.             RenameFile(ChangeFileExt(TempFName,'.$$$'),TempFName)
  1187.           End;
  1188.         End;
  1189.       Except
  1190.         Fatal(Format(msgIdxTableNotFound,[ExtractFileName(TempFName)]));
  1191.       End;
  1192.     End;
  1193.   End;
  1194. End;
  1195.  
  1196. {----------------------------------------------------------------------------}
  1197. procedure TjbDBF.MakeIndex(Const IdxName:String; Const Key:TKey);
  1198. {vytvori index                                                               }
  1199. {ake index}
  1200. {----------------------------------------------------------------------------}
  1201. Var
  1202.   F:File;
  1203.   I,L:LongInt;
  1204.   A,B,FLD:Integer;
  1205.   S:String;
  1206.   T:TStringList;
  1207. Begin
  1208.   {Musi existovat a byt otevrena neprazdna tabulka, lze pouzit i pro preindexovani}
  1209.   {Unempty table have to exist (and reindexing too)}
  1210.   If Not (FDBFExist And  FDBFIsOpened And (FDBFHeader.NumRecs>0)) Then Exit;
  1211.   {Otevri ji na stejnem miste, pouzij idxname = cele jmeno souboru}
  1212.   {Opet it here}
  1213.   AsSignFile(F,IdxName);
  1214.   Try
  1215.     Rewrite(F,1);
  1216.     Try
  1217.       B := 0;A := -1;
  1218.       {do teto velikosti to lze setridit pres stringlist jinak per partes}
  1219.       {there is limit of stringlist for 16 bit Delphi}
  1220.       If FDBFHeader.NumRecs<MaxItems Then Begin
  1221.         T:=TStringList.Create;
  1222.         Try
  1223.           {budes tridit radky}
  1224.           {lines sorting}
  1225.           T.Sorted:=True;
  1226.           For FLD:=1 To FDBFCountItems Do
  1227.             If Trim(FDBFFields[FLD].Name)=Key Then Break;
  1228.           {nastavujes vlastnost duplicit}
  1229.           {property duplicates}
  1230.           Case FDBFFields[FLD].idxtyp Of
  1231.             dbfUnique:T.Duplicates := dupError;
  1232.             dbfDuplicates:T.Duplicates := dupAccept;
  1233.           End;
  1234.           {projdes celou tabulku a vytahnes z ni pozadovane pole}
  1235.           {go through table}
  1236.           For I := 0 To FDBFHeader.NumRecs-1 Do Begin
  1237.             Seek(I);
  1238.             ELoad(Key,S);
  1239.             {vlozis ho i s pozici do seznamu}
  1240.             {with position}
  1241.             Try
  1242.               T.Add(' '+S+#1+IntToStr(I));
  1243.             Except
  1244.               On EListError Do
  1245.                 If T.Duplicates = dupError Then Fatal(msgDuplicateInUnique);
  1246.             End;
  1247.             {aktualizujes citac - vhodne je tez nastavovat kurzor}
  1248.             {counter actualisation for gauge}
  1249.             B:=Round((I+1)/(FDBFHeader.NumRecs/100));
  1250.             If A<>B Then Begin {tohle je proto, aby se progress volal jen 101x}
  1251.               A := B;
  1252.               If AsSigned(FOnProgress) Then FOnProgress(Self,prgMakeIndexSort,B);
  1253.             End;
  1254.           End;
  1255.           {znovu projdes seznam, upravis ho do tvaru <cislo><klic> a zapises}
  1256.           {go through list, format items as <number><key> an write it}
  1257.           If AsSigned(FOnProgress) Then FOnProgress(Self,prgWriteIndexSort,B);
  1258.           Case FDBFFields[FLD].idxsrt Of
  1259.             dbfDescending:
  1260.               For I:=T.Count-1 DownTo 0 Do Begin
  1261.                 S:=T.Strings[I];
  1262.                 L:=StrToInt(Copy(S,Pos(#1,S)+1,255));
  1263.                 S:='   '+Copy(S,1,Pos(#1,S)-1);
  1264.                 Move(L,S[1],SizeOf(L));
  1265.                 BlockWrite(F,S[1],Length(S));
  1266.               End;
  1267.             dbfAscending:
  1268.               For I:=0 To T.Count-1 Do Begin
  1269.                 S:=T.Strings[I];
  1270.                 L:=StrToInt(Copy(S,Pos(#1,S)+1,255));
  1271.                 {dopredu tri mezery, jedna tam uz je}
  1272.                 {fill three space before it}
  1273.                 S:='   '+Copy(S,1,Pos(#1,S)-1);
  1274.                 Move(L,S[1],SizeOf(L));
  1275.                 BlockWrite(F,S[1],Length(S));
  1276.               End;
  1277.             dbfAlternative:
  1278.             Begin
  1279.               {Potrebujete-li to, tak jedine doprogramovat}
  1280.               {if you want you have to coplete do it}
  1281.               If AsSigned(FDBFOnAltSort) Then FDBFOnAltSort(Self,T);
  1282.               For I:=0 To T.Count-1 Do Begin
  1283.                 S:=T.Strings[I];
  1284.                 L:=StrToInt(Copy(S,Pos(#1,S)+1,255));
  1285.                 S:='   '+Copy(S,1,Pos(#1,S)-1);
  1286.                 Move(L,S[1],SizeOf(L));
  1287.                 BlockWrite(F,S[1],Length(S));
  1288.               End;
  1289.             End;
  1290.           End;
  1291.         Finally
  1292.           T.Free
  1293.         End;
  1294.       End
  1295.       Else
  1296.         Warn(msgFileIsTooLarge);
  1297.     Finally
  1298.       CloseFile(F)
  1299.     End;
  1300.   Except
  1301.     Fatal(msgNotEnoughtCreateIdx)
  1302.   End;
  1303. End;
  1304.  
  1305. {----------------------------------------------------------------------------}
  1306. Function TjbDBF.ReIndex;
  1307. {provede reindexovani tabulky}
  1308. {reindexing of table}
  1309. {----------------------------------------------------------------------------}
  1310. Var
  1311.   I:Integer;
  1312.   TempFName:String;
  1313. Begin
  1314.   Result := False;
  1315.   {je-li tabulka zrovna otevrena, tak nedelej nic}
  1316.   {when table is opened do nothing}
  1317.   If IsMarked Then Exit;
  1318.   {nemuzes-li si ji otevrit taky pro sebe, tak taky nic nedelej}
  1319.   {if you cannot open for this (transaction?) do nothing}
  1320.   If Not Cover Then Exit;
  1321.   Try
  1322.     For I:=1 To FDBFCountItems Do Begin
  1323.       {prochazis vsechny sloupce a hledas indexovy soubor}
  1324.       {go through comumns}
  1325.       If Trim(FDBFFields[I].Idx)<>'' Then Begin
  1326.         {indexovy soubor byl nalezen}
  1327.         {jeho jmeno je ve tvaru xxxxxxxxIDX, vzdy zarovnan jako soubor 8-3}
  1328.         {vyplne jsou SpacerD tj. "~~~JMENOIDX" nebo "~~ZAMESTID~"}
  1329.         {vyrob temp jmeno souboru}
  1330.         {found, format name}
  1331.         TempFName:=ExtractFilePath(FDBFName)
  1332.          +Trim(Copy(FDBFFields[I].Idx,1,8)+'.'+Copy(FDBFFields[I].Idx,9,3));
  1333.  
  1334.         MakeIndex(TempFName,Trim(FDBFFields[I].Name))
  1335.       End;
  1336.     End;
  1337.   Finally
  1338.     UnCover;
  1339.     Result := True;
  1340.   End;
  1341. End;
  1342.  
  1343. {----------------------------------------------------------------------------}
  1344. Procedure TjbDBF.Update(R:LongInt);
  1345. {----------------------------------------------------------------------------}
  1346. Begin
  1347.   {bude-li zaznam aktualizovan tesne pred update, dej to vedet i s flagem}
  1348.   {if actualized before update get message with flag}
  1349.   If AsSigned(FOnActualize) Then FOnActualize(Self,dbfUpdate);
  1350.   {zapis zaznam z bufferu}
  1351.   {write record}
  1352.   Write(CurrRec);
  1353.   {udelej jeste obnoveni/refresh, ale asi neni uz nutne}
  1354.   {and refresh}
  1355.   Seek(CurrRec);
  1356. End;
  1357.  
  1358. {----------------------------------------------------------------------------}
  1359. Procedure TjbDBF.Store(Const Key:TKey; Const Rec:String);
  1360. {vlozi hodnotu do bufferu aktualniho zaznamu dle klice pole                  }
  1361. {save value to actual record buffer by field key}
  1362. {----------------------------------------------------------------------------}
  1363. Var
  1364.   I,Posic:Integer;
  1365.   S:String;
  1366. Begin
  1367.   {pozice zacina od jedne, i kdyz je buffer od 0 protoze na }
  1368.   {pozici 0 je indikacni byte o vymazani vety}
  1369.   {cout from 1, position 0 is flag for deleting}
  1370.   Posic := 1;
  1371.   For I := 1 To FDBFCountItems Do Begin
  1372.     If Trim(FDBFFields[I].Name) = UpperCase(Key) Then Break
  1373.     Else Inc(Posic,FDBFFields[I].Len);
  1374.   End;
  1375.   S:=Rec;
  1376.   If Length(S)<FDBFFields[I].Len Then
  1377.     Case FDBFFields[I].What of
  1378.       'C','L':While Length(S)<FDBFFields[I].Len Do S := S + ' ';
  1379.       'F','N','M':While Length(S)<FDBFFields[I].Len Do S := ' ' + S;
  1380.       'D':;{date is 8 chars only ddmmyyy or mmddyyyy}
  1381.       'T':;{time is 6 chars only hhmmss}
  1382.     End;
  1383.   Move(S[1],FDBFBuff^[Posic],FDBFFields[I].Len);
  1384. End;
  1385.  
  1386. {----------------------------------------------------------------------------}
  1387. Procedure TjbDBF.ELoad(Const Key:TKey; Var Rec:String);
  1388. {Precte hodnotu z bufferu aktualniho zaznamu dle klice pole                  }
  1389. {read value from actualrecord buffer by field key}
  1390. {----------------------------------------------------------------------------}
  1391. Var
  1392.   I,Posic:Integer;
  1393. Begin
  1394.   {pozice zacina od jedne, i kdyz je buffer od 0 protoze na }
  1395.   {pozici 0 je indikacni byte o vymazani vety}
  1396.   {cout from 1, position 0 is flag for deleting}
  1397.   Posic := 1;
  1398.   {nejprve musi najit jmeno pole a nascitat pocatek}
  1399.   {search field name and recount start of}
  1400.   For I := 1 To FDBFCountItems Do Begin
  1401.     If Trim(FDBFFields[I].Name) = UpperCase(Key) Then Break
  1402.     Else Inc(Posic,FDBFFields[I].Len);
  1403.   End;
  1404.   {predej zaznam neotrimovany}
  1405.   {add unformating record}
  1406.   Move(FDBFBuff^[Posic],Rec[1],FDBFFields[I].Len);
  1407.   Rec[0]:=Chr(FDBFFields[I].Len);
  1408. End;
  1409.  
  1410. {----------------------------------------------------------------------------}
  1411. Function TjbDBF.Load(Const Key:TKey):String;
  1412. {tohle je uzivatelska modifikace funkce ELoad, ktera orizne mezery}
  1413. {this formating fersion od ELoad}
  1414. {----------------------------------------------------------------------------}
  1415. Begin
  1416.   {vola standarni funkci}
  1417.   {call standard function}
  1418.   ELoad(Key,Result);
  1419.   {a tady jeste orizne nadbytecne mezery}
  1420.   {and trim spaces}
  1421.   Result:=Trim(Result);
  1422. End;
  1423.  
  1424. {----------------------------------------------------------------------------}
  1425. Procedure TjbDBF.Find(Const IdxName, Value{toto je vlastne klic}:String);
  1426. {hleda hodnotu podle klice idxname je jmeno sloupce value je hodnota
  1427.  funkcionalitu = <> > < >= <= dodava onquery}
  1428. {dearch value by key}
  1429. {more give = <> > < >= <= get onquery}
  1430. {----------------------------------------------------------------------------}
  1431.   Function SizeOfKey(Const Key:String):Integer;
  1432.   {vraci sirku klice/pole}
  1433.   Var I:Integer;
  1434.   Begin
  1435.     For I := 1 To FDBFCountItems Do Begin
  1436.       If Trim(FDBFFields[I].Name) = UpperCase(Key) Then Begin
  1437.         Result := FDBFFields[I].Len;
  1438.         Exit
  1439.       End;
  1440.     End;
  1441.     Result:=0;
  1442.     Warn(Format(msgIdxFieldNotFound,[Key]));
  1443.   End;
  1444. Var
  1445.   F:File;
  1446.   A,B,Size:Integer;
  1447.   S:String;
  1448.   I,N,L:LongInt;
  1449.   OK, Cancel:Boolean;
  1450. Begin
  1451.   {Musi existovat a byt otevrena neprazdna tabulka, lze pouzit i pro preindexovani}
  1452.   {opened and unempty table}
  1453.   If Not (FDBFExist And  FDBFIsOpened And (FDBFHeader.NumRecs>0)) Then Exit;
  1454.   {tato procedura musi byt attachnuta, aby mohl dotaz fungovat}
  1455.   {OnQuery must be attach for good work !!!}
  1456.   If Not AsSigned(FOnQuery) Then Exit;
  1457.   {tahle taky, aby se dala predavat data}
  1458.   {and OnFound must be attach for good work too!!!}
  1459.   If Not AsSigned(FOnFound) Then Exit;
  1460.   {Otevri ji na stejnem miste, pouzij idxname a defaultni priponu}
  1461.   {open index}
  1462.   AsSignFile(F,ExtractFilePath(FDBFName)+IdxName);
  1463.   Try
  1464.     ReSet(F,1);
  1465.     Try
  1466.       B :=SizeOfKey(Value);
  1467.       {v tomto pripade vydano varovani a odchod, klic musi byt nenulovy}
  1468.       {key have to non zero}
  1469.       If B=0 Then Exit;
  1470.       {sestaveni zaznamu}
  1471.       {build record}
  1472.       Size:=B+SizeOf(LongInt);
  1473.       {overeni na velikost souboru}
  1474.       {size of file for align}
  1475.       I := FileSize(F);
  1476.       {v pripade ze neco zbyde (polozky nejsou align) tak chyba}
  1477.       {fatal error occurr when non align}
  1478.       If (I Mod Size) <> 0 Then Begin
  1479.         Fatal(Format(msgErrorOnIdxTable,[IdxName]));
  1480.         Exit;
  1481.       End;
  1482.       {tohle je pocet polozek}
  1483.       {count of records}
  1484.       N := I Div Size;
  1485.       {nastav prostor na S}
  1486.       {make place for it}
  1487.       S:='';For I := 1 To Size Do S:=S+' ';
  1488.       Cancel:=False;
  1489.       {prochazej periodicky klic}
  1490.       {go by key}
  1491.       B := 0; A := -1;
  1492.       For I := 0 To N-1 Do Begin
  1493.         BlockRead(F,S[1],Size);
  1494.         S[0]:=Chr(Size);
  1495.         Move(S[1],L,SizeOf(L));
  1496.         S:=Copy(S,5,255);
  1497.         {zde je dotaz na tabulku, uzivatel filtruje dle pole}
  1498.         {query to table, user do filtering}
  1499.         {no accept}
  1500.         OK:=False;{predpoklad, ze ho nechci}
  1501.         FOnQuery(Self,IdxName,Value,Trim(S),OK, Cancel);
  1502.         If OK Then Begin
  1503.           {je-li pozadovany filtr akceptovan, vyzvedni zaznam}
  1504.           {when accept, get record from table}
  1505.           Seek(L);
  1506.           {zaznam se musi zpracovat, jinak jsou data ztracena}
  1507.           {zde se data ctou napr. do listboxu nebo stringgridu}
  1508.           {record must be worked but data throw off}
  1509.           {may be read to list ??}
  1510.           FOnFound(Self);
  1511.         End;
  1512.         {aktualizujes citac - vhodne je tez nastavovat kurzor}
  1513.         {for gauge}
  1514.         B:=Round((I+1)/(N/100));
  1515.         If Cancel Then B:=100;
  1516.         If A<>B Then Begin {tohle je proto, aby se progress volal jen 101x}
  1517.           A := B;
  1518.           If AsSigned(FOnProgress) Then FOnProgress(Self,prgSearchByKey,B);
  1519.         End;
  1520.         If Cancel Then Break;
  1521.       End;
  1522.     Finally
  1523.       CloseFile(F)
  1524.     End;
  1525.   Except
  1526.     Fatal(Format(msgIdxTableNotFound,[ExtractFilePath(FDBFName)+IdxName]));
  1527.   End;
  1528. End;
  1529.  
  1530. {----------------------------------------------------------------------------}
  1531. Function TjbDBF.Cover:Boolean;
  1532. {nastavuje bit transakce}
  1533. {set flag for transaction}
  1534. {----------------------------------------------------------------------------}
  1535. Var
  1536.   F: File;
  1537.   B: Byte;
  1538. Begin
  1539.   Result := False;
  1540.   If IsMarked Then Exit;
  1541.   AssignFile(F, FDBFName);
  1542.   Try
  1543.     Reset(F, 1);
  1544.     Try
  1545.       B:=1;
  1546.       System.Seek(F, 14);
  1547.       BlockWrite(F, B, 1);
  1548.       Result := True;
  1549.     Finally
  1550.       CloseFile(F);
  1551.     End;
  1552.   Except
  1553.     On EInOutError Do Warn(msgFileTooRemote);
  1554.   End;
  1555. End;
  1556.  
  1557. {----------------------------------------------------------------------------}
  1558. Procedure TjbDBF.UnCover;
  1559. {shazuje bit transakce}
  1560. {reset flag for transaction}
  1561. {----------------------------------------------------------------------------}
  1562. Var
  1563.   F: File;
  1564.   B: Byte;
  1565. Begin
  1566.   If Not IsMarked Then Exit;
  1567.   AssignFile(F, FDBFName);
  1568.   Try
  1569.     Reset(F, 1);
  1570.     Try
  1571.       B:=0;
  1572.       System.Seek(F, 14);
  1573.       BlockWrite(F, B, 1);
  1574.     Finally
  1575.       CloseFile(F);
  1576.     End;
  1577.   Except
  1578.     On EInOutError Do Warn(msgFileTooRemote);
  1579.   End;
  1580. End;
  1581.  
  1582. {----------------------------------------------------------------------------}
  1583. procedure TjbDBF.RemoveIndex(Const Name: String);
  1584. {explicitni zruseni indexu .mdx a zruseni propojeni}
  1585. {explicit delete of index and erase link}
  1586. {----------------------------------------------------------------------------}
  1587. Var
  1588.   F: File;
  1589.   B: Byte;
  1590. Begin
  1591.   AssignFile(F, FDBFName);
  1592.   Try
  1593.     Reset(F, 1);
  1594.     Try
  1595.       System.Seek(F, 28);
  1596.       B := 0;
  1597.       BlockWrite(F, B, 1);
  1598.       DeleteFile(ChangeFileExt(Name, '.mdx'));
  1599.     Finally
  1600.       CloseFile(F);
  1601.     End;
  1602.   Except
  1603.     On EInOutError Do Warn(msgCannotOpenTable)
  1604.   End;
  1605. End;
  1606.  
  1607. {----------------------------------------------------------------------------}
  1608. Function TjbDBF.IsMarked:Boolean;
  1609. {vraci priznak, zda je nastavena transakce}
  1610. {get flag that transaction is of/off}
  1611. {----------------------------------------------------------------------------}
  1612. Var
  1613.   F: File;
  1614.   B: Byte;
  1615. Begin
  1616.   Result := True;
  1617.   AssignFile(F, FDBFName);
  1618.   Try
  1619.     Reset(F, 1);
  1620.     Try
  1621.       System.Seek(F, 14);
  1622.       BlockRead(F, B, 1);
  1623.       Result := B = 1;
  1624.     Finally
  1625.       CloseFile(F);
  1626.     End;
  1627.   Except
  1628.     On EInOutError Do Warn(msgFileTooRemote);
  1629.   End;
  1630. End;
  1631.  
  1632. {----------------------------------------------------------------------------}
  1633. Procedure TjbDBF.IncNumRec;
  1634. {procedura zvysi pocet zaznamu o jeden}
  1635. {increment count of records +1}
  1636. {----------------------------------------------------------------------------}
  1637. Var
  1638.   F: File;
  1639.   L: LongInt;
  1640. Begin
  1641.   AssignFile(F, FDBFName);
  1642.   Try
  1643.     Reset(F, 1);
  1644.     Try
  1645.       System.Seek(F, 4);
  1646.       BlockRead(F, L, SizeOf(L));
  1647.       Inc(L);
  1648.       FDBFHeader.numRecs:=L;
  1649.       System.Seek(F, 4);
  1650.       BlockWrite(F, L, SizeOf(L));
  1651.     Finally
  1652.       CloseFile(F);
  1653.     End;
  1654.   Except
  1655.     On EInOutError Do Warn(msgFileTooRemote);
  1656.   End;
  1657. End;
  1658.  
  1659. {----------------------------------------------------------------------------}
  1660. Procedure TjbDBF.Actualization;
  1661. {zapis do hlavicky aktualni datum}
  1662. {write to header of dbf actual date and time}
  1663. {----------------------------------------------------------------------------}
  1664. Var
  1665.   F: File;
  1666.   S: String[3];
  1667.   Year, Month, Day: Word;
  1668. Begin
  1669.   AssignFile(F, FDBFName);
  1670.   Try
  1671.     Reset(F, 1);
  1672.     Try
  1673.       System.Seek(F, 1);
  1674.       BlockRead(F, S[1], 3);
  1675.       DecodeDate(Date, Year, Month, Day);
  1676.       Byte(S[1]):=(Year Mod 100);
  1677.       Byte(S[2]):=Month;
  1678.       Byte(S[3]):=Day;
  1679.       Move(S[1],FDBFHeader.Year,3);
  1680.       System.Seek(F, 1);
  1681.       BlockWrite(F, S[1], 3);
  1682.     Finally
  1683.       CloseFile(F);
  1684.     End;
  1685.   Except
  1686.     On EInOutError Do Warn(msgFileTooRemote);
  1687.   End;
  1688. End;
  1689.  
  1690. {----------------------------------------------------------------------------}
  1691. Function TjbDBF.SaveMemo(No:LongInt;Const FName:String):Boolean;
  1692. {ulozi soubor do memo}
  1693. {store file to memo}
  1694. {----------------------------------------------------------------------------}
  1695. Var F,FF:File;
  1696.     T:TDBTTypes;
  1697.     S:String[79];
  1698.     SR:TSearchRec;
  1699.     A:Array[1..1024] of Char;
  1700.     NumRead, NumWritten:{$IfDef VER80}Word{$Else}Integer{$EndIf};
  1701. Begin
  1702.   Result:=False;
  1703.   If Not FileExists(FName) Then Exit;
  1704.   If FindFirst(FName,faAnyFile,SR)<>0 Then Exit;
  1705.   FindClose(SR);
  1706.   AsSignFile(F,ChangeFileExt(FDBFName,'.DBT'));
  1707.   Try
  1708.     {$I-}
  1709.     ReSet(F,1);
  1710.     {$I+}
  1711.     If IoResult<>0 Then ReWrite(F,1);
  1712.     {zapis vety}
  1713.     Try
  1714.       System.Seek(F,System.FileSize(F));
  1715.       With T Do Begin
  1716.         { cislo zaznamu}
  1717.         {record no}
  1718.         NumberOf:=No;
  1719.         S:=ExtractFileExt(FName);
  1720.         If Length(S)<=3 Then
  1721.           Move(S[1],AsFileType,Length(S)); { extension of dtored type}
  1722.         Used:=True;                     { is used}
  1723.         SizeOfMemo:=SR.Size; { size of linked file}
  1724.         FileDateTime:=FileDateToDateTime(SR.Time); { original date and time of file}
  1725.       End;
  1726.       BlockWrite(F,T,SizeOf(T));
  1727.       {prekopiruj soubor do memo}
  1728.       {re-copy file to memo}
  1729.       AsSignFile(FF,FName);
  1730.       ReSet(FF,1);
  1731.       Try
  1732.         Repeat
  1733.           BlockRead(FF, A, SizeOf(A), NumRead);
  1734.           BlockWrite(F, A, NumRead, NumWritten);
  1735.         Until (NumRead = 0) or (NumWritten <> NumRead);
  1736.       Finally
  1737.         CloseFile(FF)
  1738.       End;
  1739.       Result:=True;
  1740.     Finally
  1741.       CloseFile(F);
  1742.     End;
  1743.   Except
  1744.     On EInOutError Do Fatal(msgErrorOnMemoOpen);
  1745.   End;
  1746. End;
  1747.  
  1748. {----------------------------------------------------------------------------}
  1749. Function TjbDBF.LoadMemo(No:LongInt;Var FName:String):Boolean;
  1750. {preda soubor z memo na disk do FName - zmeni u nej pouze extenzi dle uloz. typu}
  1751. {get filename from memo}
  1752. {----------------------------------------------------------------------------}
  1753. Var F,FF:File;
  1754.     T:TDBTTypes;
  1755.     Readed:{$IfDef VER80}Word{$Else}Integer{$EndIf};
  1756.     C:Char;
  1757.     I:LongInt;
  1758.     Handle:Integer;
  1759. Begin
  1760.   Result:=False;
  1761.   AsSignFile(F,ChangeFileExt(FDBFName,'.DBT'));
  1762.   Try
  1763.     ReSet(F,1);
  1764.     Try
  1765.       T.NumberOf:=-1;
  1766.       {hleda hlavickovy zaznam}
  1767.       {search header}
  1768.       While T.NumberOf<>No Do Begin
  1769.         BlockRead(F,T,SizeOf(T),Readed);
  1770.         If Readed=0 Then Exit;
  1771.         System.Seek(F,System.FilePos(F)+T.SizeOfMemo);
  1772.       End;
  1773.       {nasels, vrat se}
  1774.       {found, go back}
  1775.       System.Seek(F,System.FilePos(F)-T.SizeOfMemo);
  1776.       {zapis ho na disk - je-li jineho typu, zmen extenzi!! }
  1777.       {write to disk}
  1778.       FName:=ChangeFileExt(FName,'.'+T.AsFileType);
  1779.       AsSignFile(FF,FName);
  1780.       Try
  1781.         ReWrite(FF,1);
  1782.         Try
  1783.           {prekopiruj to do souboru}
  1784.           {re-copu to file}
  1785.           For I:=1 To T.SizeOfMemo Do Begin
  1786.             BlockRead(F,C,SizeOf(C));
  1787.             BlockWrite(FF,C,SizeOf(C));
  1788.           End;
  1789.         Finally
  1790.           CloseFile(FF);
  1791.           {nastav puvodni datum souboru}
  1792.           {set original date and time of file}
  1793.           Handle:=FileOpen(FName,fmOpenReadWrite);
  1794.           FileSetDate(Handle,DateTimeToFileDate(T.FileDateTime));
  1795.           FileClose(Handle);
  1796.         End;
  1797.       Except
  1798.         On EInOutError Do ;
  1799.       End;
  1800.       {a zapis}
  1801.       {and write}
  1802.       BlockWrite(F,T,SizeOf(T));
  1803.     Finally
  1804.       CloseFile(F);
  1805.     End;
  1806.     Result:=True;
  1807.   Except
  1808.     On EInOutError Do Fatal(msgErrorOnMemoOpen);
  1809.   End;
  1810.  
  1811. End;
  1812.  
  1813. {----------------------------------------------------------------------------}
  1814. Function TjbDBF.EraseMemo(No:LongInt):Boolean;
  1815. {oznaci soubor v memo za nepouzivany}
  1816. {set mark in memo file as unused}
  1817. {----------------------------------------------------------------------------}
  1818. Var F:File;
  1819.     T:TDBTTypes;
  1820.     Readed:{$IfDef VER80}Word{$Else}Integer{$EndIf};
  1821. Begin
  1822.   Result:=False;
  1823.   AsSignFile(F,ChangeFileExt(FDBFName,'.DBT'));
  1824.   Try
  1825.     ReSet(F,1);
  1826.     Try
  1827.       T.NumberOf:=-1;
  1828.       While T.NumberOf<>No Do Begin
  1829.         BlockRead(F,T,SizeOf(T),Readed);
  1830.         If Readed=0 Then Exit;
  1831.         System.Seek(F,System.FilePos(F)+T.SizeOfMemo);
  1832.       End;
  1833.       {nasels, vrat se}
  1834.       {find, go back}
  1835.       System.Seek(F,System.FilePos(F)-T.SizeOfMemo-SizeOf(T));
  1836.       {Nastav priznak}
  1837.       {set flag}
  1838.       T.Used:=False;
  1839.       {a zapis}
  1840.       {and write it}
  1841.       BlockWrite(F,T,SizeOf(T));
  1842.     Finally
  1843.       CloseFile(F);
  1844.     End;
  1845.     Result:=True;
  1846.   Except
  1847.     On EInOutError Do Fatal(msgErrorOnMemoOpen);
  1848.   End;
  1849. End;
  1850.  
  1851. {----------------------------------------------------------------------------}
  1852. Procedure TjbDBF.PruneDBF;
  1853. {odstrani z tabulky vymazane zaznamy}
  1854. {remove deleted records from table}
  1855. {----------------------------------------------------------------------------}
  1856. Begin
  1857. End;
  1858. {----------------------------------------------------------------------------}
  1859. Procedure TjbDBF.PruneDBT;
  1860. {odstrani z memo nepouzite zaznamy}
  1861. {remove deleted records from memo}
  1862. {----------------------------------------------------------------------------}
  1863. Begin
  1864. End;
  1865.  
  1866. { Changed by /VN/: }
  1867. {----------------------------------------------------------------------------}
  1868. function TjbDBF.GetRecordsCount: LongInt;
  1869. {vraci pocet zaznamu}
  1870. {get count of records}
  1871. {----------------------------------------------------------------------------}
  1872. begin
  1873.   Result := FDBFHeader.numRecs;
  1874. end;
  1875.  
  1876. {----------------------------------------------------------------------------}
  1877. function TjbDBF.GetField(Index: Integer): TDBField;
  1878. {vrati polozku}
  1879. {get field}
  1880. {----------------------------------------------------------------------------}
  1881. begin
  1882.   if (Index < 0) or (Index > FDBFCountItems) then
  1883.     Fatal(Format(msgFieldNotFound, [Index]))
  1884.   else
  1885.     Result := FDBFFields[Index];
  1886. end;
  1887.  
  1888. {----------------------------------------------------------------------------}
  1889. function TjbDBF.IsCurrentRecDeleted: Boolean;
  1890. {rekne zda-li je zaznam vymazan}
  1891. {get flat that records is deleted}
  1892. {----------------------------------------------------------------------------}
  1893. begin
  1894.   Result := FDBFBuff^[0] = '*';
  1895. end;
  1896.  
  1897. {added by /AR/ }
  1898. {----------------------------------------------------------------------------}
  1899. function TjbDBF.GetFieldByName(Const Key:TKey): TDBField;
  1900. {----------------------------------------------------------------------------}
  1901. var
  1902.   bFound : boolean;
  1903.   i : integer;
  1904. begin
  1905.  
  1906. bFound := false;
  1907. i:=0;
  1908.  
  1909. while not(bFound or (i>(FDBFCountItems))) do
  1910. begin
  1911.   inc(i);
  1912.   if Trim(FDBFFields[i].Name)=UpperCase(Key) then
  1913.   begin
  1914.      bFound := true;
  1915.      Result := FDBFFields[i];
  1916.   end;
  1917. end;
  1918. if not(bFound) then
  1919.     Fatal(msgBadDefinitionOfField);
  1920. end;
  1921.  
  1922. End. {end of file; end of comment 15.1.2002 by J.B. Sorry for my English}
  1923.