home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / kompon / d123456 / ANRMLB.ZIP / component / mlb2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-09-27  |  90.7 KB  |  3,254 lines
  1. (*******************************************************************
  2. MY LITTLE BASE 2.0.0 delphi source code
  3. CopyRights owned by S.A.R.L ANIROM Multimedia Marseille FRANCE
  4. http://www.anirom.com
  5. except for the public domain Excel export section found on the web
  6. MLB official website is http://www.mylittlebase.org
  7.  
  8. This source code is Freeware
  9. You can copy it and use it freely for any purpose (even commercial)
  10. but you must add in the about box of your program that it uses
  11. MyLittleBase source code (http://www.mylittlebase.org)
  12. You can freely distribute this unmodified source code containing
  13. this copyright notice
  14. You can modify it for your own purposes, but you cannot distribute
  15. the modified code as mylittlebase without the written consent from ANIROM
  16. You can write external modules using this unmodified source code
  17. and distribute them
  18.  
  19. ANIROM Multimedia assumes no liability of any kind
  20. use this code at your own risks or do not use it
  21. *******************************************************************)
  22. unit mlb2;
  23.  
  24. interface
  25.  
  26. uses
  27.     SysUtils, Classes;
  28.  
  29. const MLB_MAJOR_VERSION = 2;
  30. const MLB_MINOR_VERSION = 00;
  31. const MLB_AFTER = true;
  32. const MLB_BEFORE = false;
  33. const MLB_LOWEST = false;
  34. const MLB_GREATEST = true;
  35. const MLB_FORWARD = true;
  36. const MLB_BACKWARD = false;
  37. {errors}
  38. const MLB_ERROR_NOPE = 0;      {NO ERROR HAS BEEN FOUND}
  39. const MLB_ERROR_UNKNOWN = 1;   {ERROR NOT DOCUMENTED}
  40. const MLB_ERROR_BADFORMAT = 2; {THE FILE FORMAT IS NOT CORRECT}
  41. const MLB_ERROR_IO = 3;        {INPUT-OUTPUT ERROR WHILE READING/WRITING FILES}
  42. {-------EXCEL DEBUT INTERFACE !!!}
  43. Const
  44.  
  45.   TMlb2_Space : char = chr(32);
  46.   TMlb2_Tab   : char = chr(9);
  47.   TMlb2_CR    : char = chr(13);
  48.   TMlb2_LF    : char = chr(10);
  49.  
  50.   {BOF}
  51.   TMlb2_BOF       = $0009;
  52.   BIT_BIFF5 = $0800;
  53.   BIT_BIFF4 = $0400;
  54.   BIT_BIFF3 = $0200;
  55.   BOF_BIFF5 = TMlb2_BOF or BIT_BIFF5;
  56.   BOF_BIFF4 = TMlb2_BOF or BIT_BIFF4;
  57.   BOF_BIFF3 = TMlb2_BOF or BIT_BIFF3;
  58.   {EOF}
  59.   BIFF_EOF = $000a;
  60.   {Dimensions}
  61.   DIMENSIONS = $0000;
  62.   DIMENSIONS_BIFF4 = DIMENSIONS or BIT_BIFF3;
  63.   DIMENSIONS_BIFF3 = DIMENSIONS or BIT_BIFF3;
  64.   {Document types}
  65.   DOCTYPE_XLS = $0010;
  66.   DOCTYPE_XLC = $0020;
  67.   DOCTYPE_XLM = $0040;
  68.   DOCTYPE_XLW = $0100;
  69.   {Use with output functions}
  70.   VER_BIFF4 = $04;
  71.   VER_BIFF3 = $03;
  72.   VER_BIFF2 = $02;
  73.   {Structures}
  74.   LEN_RECORDHEADER = 4;
  75.   {Data types }
  76.   CellBlank   = 1;
  77.   CellLongInt = 2;
  78.   CellDouble  = 4;
  79.   CellLabel   = 8;
  80.   CellBoolean = 16; { or error }
  81.  
  82. type MLB_int1 = byte;
  83. type MLB_int2 = Word;
  84. type MLB_int4 = LongInt;
  85. type MLB_endian_test = array [1..2] of MLB_int1;
  86. type PMLB_endian_test = ^MLB_endian_test;
  87. Type
  88.   TFileName = String;
  89.   string10 = String[10]; String255 = string[255];
  90.   chartype = array[0..255] of char;
  91.  
  92.   PBaseSave = ^TBaseSave;
  93.   TBaseSave = object
  94.     Charfile : file of char;
  95.     DataString : String255; Separator : char;
  96.     MinSaveRecs, MaxSaveRecs, MinSaveCols, MaxSaveCols : word;
  97.     CellType, Row, Col : LongInt;
  98.     DataPointer : pointer;
  99.     EndOfLine : boolean;
  100.  
  101.     Constructor Init(SaveFileName : String );
  102.     procedure WriteBlank; virtual;
  103.     procedure WriteLongInt; virtual;
  104.     procedure WriteDouble; virtual;
  105.     procedure WriteLabel (var w : word); virtual;
  106.     procedure WriteData(AType, ARow, ACol: LongInt; AData: Pointer); virtual;
  107.     Destructor Done; virtual;
  108.   end;
  109.  
  110.   PASCII = ^TASCII;
  111.   TASCII = object(TBaseSave)
  112.     Constructor Init( SaveFileName : TFileName );
  113.     Destructor Done; virtual;
  114.   end;
  115.  
  116.   PExcelTab = ^TExcelTab;
  117.   TExcelTab = object(TBaseSave)
  118.     Constructor Init(SaveFileName : TFileName );
  119.     Destructor Done; virtual;
  120.   end;
  121.  
  122.   PBIFF2 = ^TBIFF2;
  123.   TBIFF2 = object(TBaseSave)
  124.     {BIFFtime, BIFFdata : double;} BIFFColumn : byte;
  125.     ExcelFile : File;
  126.     VerBIFF, TypeDOC : word;
  127.     typerec, lendata : word;
  128.  
  129.     constructor Init(AFileName : TFileName);
  130.     destructor Done; virtual;
  131.     procedure BIFFBOF; virtual;
  132.     procedure BIFFDIM; virtual;
  133.     procedure WriteBOF; virtual;
  134.     procedure WriteRecordHeader; virtual;
  135.     procedure WriteDimensions; virtual;
  136.     procedure WriteEOF; virtual;
  137.     procedure WriteData(AType, ARow, ACol: LongInt; AData: Pointer); virtual;
  138.     procedure WriteBlank; virtual;
  139.     procedure WriteLongInt; virtual;
  140.     procedure WriteDouble; virtual;
  141.     procedure WriteLabel (var w : word); virtual;
  142.     procedure WriteBoolean; virtual;
  143.   end;
  144.  
  145.   PBIFF3 = ^TBIFF3;
  146.   TBIFF3 = object(TBIFF2)
  147.     procedure BIFFBOF; virtual;
  148.     procedure BIFFDIM; virtual;
  149.   end;
  150.  
  151.   PBIFF4 = ^TBIFF4;
  152.   TBIFF4 = object(TBIFF3)
  153.     procedure BIFFBOF; virtual;
  154.   end;
  155.  
  156.   PBIFF5 = ^TBIFF5;
  157.   TBIFF5 = object(TBIFF4)
  158.     procedure BIFFBOF; virtual;
  159.   end;
  160.  
  161. var PSaveFile : PBaseSave;
  162. {EXCEL FIN INTERFACE}
  163.  
  164. type
  165. {TKLIST DEBUT INTERFACE}
  166.   PListItem = ^TListItem;
  167.   TListItem = record
  168.         item: Pointer;
  169.         Prev, Next: PListItem;
  170.   end;
  171.  
  172.   TKList = class(TObject)
  173.   private
  174.         first, current, last: PListItem;
  175.         index, n: LongInt;
  176.  
  177.         function best_pointer(k: LongInt): LongInt;
  178.   public
  179.         constructor Create;
  180.         destructor Destroy; override;
  181.  
  182.         procedure Add(item: pointer);
  183.         function Insert(k: LongInt; item: pointer): boolean;
  184.         function Init(ditems: boolean): boolean;
  185.         function Remove(k: LongInt): pointer;
  186.         function Delete(ditems: boolean): boolean;
  187.         procedure Purge;
  188.         function GetItem(k: LongInt): pointer;
  189.         function SetItem(k: LongInt; p: pointer): pointer;
  190.         function GetIndex: LongInt;
  191.         function Count: LongInt;
  192.  
  193.         procedure AddString(s: string);
  194.         function InsertString(k: LongInt; s: string): boolean;
  195.         function GetString(k: LongInt): string;
  196.         function SetString(k: LongInt; s: string): boolean;
  197.         function IndexOfString(s: string): LongInt;
  198.  
  199.         function Empty: boolean;
  200.         function Go(k: LongInt): boolean;
  201.         function GoFirst: boolean;
  202.         function GoLast: boolean;
  203.         function GoNext: boolean;
  204.         function GoPrevious: boolean;
  205.  
  206.         function Exchange(k1, k2: LongInt): boolean;
  207.   end;
  208.  
  209.   TKBaseList = class(TObject)
  210.   private
  211.         list: TKList;
  212.         function ReadCount: LongInt;
  213.         function ReadItems(index1: LongInt): pointer;
  214.         procedure WriteItems(index1: LongInt; v: pointer);
  215.   public
  216.         constructor Create;
  217.         destructor Destroy; override;
  218.         property Count: LongInt read ReadCount;
  219.         property Items[index1: LongInt]: pointer read ReadItems write WriteItems;
  220.         procedure Clear;
  221.         procedure Pack;
  222.         procedure Add(p: pointer);
  223.         procedure Insert(position1: LongInt; p: pointer);
  224.         procedure Delete(k: LongInt);
  225.         procedure Exchange(k1, k2: LongInt);
  226.   end;
  227.  
  228.   TKStringList = class(TObject)
  229.   private
  230.         list: TKList;
  231.         function ReadCount: LongInt;
  232.         function ReadStrings(index1: LongInt): string;
  233.         procedure WriteStrings(index1: LongInt; v: string);
  234.   public
  235.         constructor Create;
  236.         destructor Destroy; override;
  237.         procedure Assign(tk: TKStringList);
  238.         property Count: LongInt read ReadCount;
  239.         property Strings[index1: LongInt]: string read ReadStrings write WriteStrings;
  240.         procedure Clear;
  241.         function IndexOf(s: string): LongInt;
  242.         procedure Add(s: string);
  243.         function Delete(k: LongInt): boolean;
  244.   end;
  245. {TKLIST FIN INTERFACE}
  246.  
  247.  
  248. {CONCORDANCES DEBUT INTERFACE !!!}
  249. type
  250.   TConcordances = class(TObject)
  251.   private
  252.     function del_spaces(var s: string): string;
  253.   public
  254.     space_matching: boolean;
  255.     case_matching: boolean;
  256.     like_matching: boolean;
  257.  
  258.     constructor Create;
  259.     destructor Destroy; override;
  260.     function SI_VERIFICATION(sujet1, sujet2: string): boolean;
  261.     function Concordance(sujet1, sujet2: string): boolean;
  262.   end;
  263. {CONCORDANCES FIN INTERFACE !!!}
  264. const RF_BUFFER_SIZE = 1000;
  265.  
  266. type
  267.   TMlb2_ROW = TKStringList;
  268.   TMlb2_SLOTS = TKBaseList;
  269.  
  270.   TMlb2ParseCSV = class(TObject)
  271.   private
  272.         csvline: string;
  273.         index: LongInt;
  274.   public
  275.         CSVSeparator: string;
  276.         constructor Create;
  277.         destructor Destroy; override;
  278.  
  279.         procedure Init(s1: string);
  280.         function NextField(var field: string): Boolean;
  281.         function FromN(s1: string): string;
  282.         function ToN(s1: string): string;
  283.   end;
  284.   PTMlb2IntegerList = ^TMlb2IntegerList;
  285.   TMlb2IntegerList = record
  286.        k: integer;
  287.        nextfield: PTMlb2IntegerList;
  288.   end;
  289.   TMlbFusionArray = string;
  290.   PTMlb2 = ^TMlb2;
  291.   TMlb2 = class(TObject)
  292.   protected
  293.   name_: string;
  294.   current, position: LongInt;
  295.   fields: TMlb2_ROW;
  296.   ftypes: TMlb2_ROW;
  297.   data: TMlb2_SLOTS;
  298.   psv: TMlb2ParseCSV;
  299.   rowcopy: array [1..2] of TMlb2_ROW;
  300.   firstseek: boolean;
  301.   {ISAMPARSE}
  302.       RFBuffer: array [1..RF_BUFFER_SIZE] of char;
  303.       RFI: LongInt;
  304.       RFD: LongInt;
  305.       CHAR1, CHAR2: char;
  306.       VCHAR: char;
  307.       in_quotes, with_quotes: boolean;
  308.       Token: string;
  309.       LikeAgent: TConcordances;
  310.       direction : boolean;
  311.  
  312.   function local_endian: byte;
  313.   procedure init_error;
  314.   function row(row1: LongInt): TMlb2_ROW;
  315.   function lastrow: TMlb2_ROW;
  316.   function currentrow: TMlb2_ROW;
  317.   function trim2(s1: string): string;
  318.   function FieldNameRead(index1: LongInt): string;
  319.   procedure FieldNameWrite(index1: LongInt; v: string);
  320.   function DataTypeRead(index1: LongInt): string;
  321.   procedure DataTypeWrite(index1: LongInt; v: string);
  322.   function AccessDataRead(field1, index1: LongInt): string;
  323.   function find_extension(filename1: string): string;
  324.   procedure write_text_as_binary(var f: file; t: string);
  325.   function read_text_as_binary(H: integer): string;
  326.   function read_int2_from_other_endian(H: integer): MLB_int2;
  327.   function read_int4_from_other_endian(H: integer): MLB_int4;
  328.   function same_endian(endian1: byte): boolean;
  329.   function tonz(m, n: integer): string;
  330.   function getName: string;
  331.   procedure setName(name1: string);
  332.   procedure nameFromFilename(filename1: string);
  333.  
  334.   {ISAMPARSE}
  335.     function RFGetChar(H: integer): LongInt;
  336.     function GetNextToken(H: integer): boolean;
  337.     function IsSeparator(s: char): boolean;
  338.     function quote2(s: string): string;
  339.   public
  340.         Distinct: boolean;
  341.         QuoteSeparator: string;
  342.         CSVSeparator: string;
  343.         BeginningOfFile: boolean;
  344.         EndOfFile: boolean;
  345.         MLBError: integer;
  346.         MLBErrorComment: string;
  347.         constructor Create;
  348.         destructor Destroy; override;
  349.  
  350.         procedure Init;
  351.         procedure Clear;
  352.         procedure Assign(var mlb: TMlb2);
  353.         function GetVersion: String;
  354.         function GetVersionNumber: Integer;
  355.         property Name: string read getName write setName;
  356.  
  357.         function AddField(fieldname1: string): Boolean;
  358.         function RemoveField(fieldname1: string): Boolean;
  359.         property FieldName[index1: LongInt]: string read FieldNameRead write FieldNameWrite;
  360.         property DataType[index1: LongInt]: string read DataTypeRead write DataTypeWrite;
  361.         function FieldCount: LongInt;
  362.  
  363.         procedure AddRow;
  364.         function InsertRow(where1: boolean): boolean;
  365.         function RemoveRow: Boolean;
  366.         function RemoveRowByIndex(k: LongInt): Boolean;
  367.         function CopyRow: boolean;
  368.         function PasteRow: boolean;
  369.         function CopyRowBySlot(slot: integer): boolean;
  370.         function PasteRowBySlot(slot: integer): boolean;
  371.         function InitFieldWithData(fieldname1: string; data1: string): boolean;
  372.         function InitFieldWithValue(fieldname1: string; value1: Extended): boolean;
  373.         procedure ForceRows(nrows: LongInt);
  374.         function RowCount: LongInt;
  375.  
  376.         function GetCurrentRow: LongInt;
  377.         function IsEmpty: Boolean;
  378.  
  379.         function Go(row1: LongInt): Boolean;
  380.         function GoFirst: Boolean;
  381.         function GoLast: Boolean;
  382.         function GoNext: Boolean;
  383.         function GoPrevious: Boolean;
  384.         function BeginSeek(direction1: boolean): Boolean;
  385.         function EndSeek: Boolean;
  386.         function SeekData(fieldname1, comp1, value1: string): boolean;
  387.         function SeekFloat(fieldname1, comp1: string; value1: Extended): boolean;
  388.         function MatchData(fieldname1, comp1, value1: string): boolean;
  389.         function MatchFloat(fieldname1, comp1: string; value1: Extended): boolean;
  390.         function SavePosition: boolean;
  391.         function RestorePosition: boolean;
  392.         function GetPosition: LongInt;
  393.  
  394.         function GetData(fieldname1: string): string;
  395.         function SetData(fieldname1: string; data1: string): Boolean;
  396.         function GetDataByIndex(index1: LongInt): string;
  397.         function SetDataByIndex(index1: LongInt; data1: string): Boolean;
  398.         function GetFloat(fieldname1: string): Extended;
  399.         function SetFloat(fieldname1: string; float1: Extended): Boolean;
  400.         function GetFloatByIndex(index1: LongInt): Extended;
  401.         function SetFloatByIndex(index1: LongInt; float1: Extended): Boolean;
  402.         function GetFieldName(index1: LongInt): string;
  403.         function GetFieldIndex(fieldname1: string): LongInt;
  404.         property AccessData[field1, index1: LongInt]: string read AccessDataRead;
  405.  
  406.         function LoadFromFile(filename1: string): Boolean;
  407.         function LoadFromCSVFile(filename1: string): Boolean;
  408.         function LoadFromISAMFile(filename1: string): Boolean;
  409.         function LoadFromMLBFile(filename1: string): Boolean;
  410.         function SaveToFile(FileName1: string): boolean;
  411.         function SaveToCSVFile(filename1: string): Boolean;
  412.         function SaveToISAMFile(filename1: string): Boolean;
  413.         function SaveToMLBFile(filename1: string): Boolean;
  414.         function SaveToExcelFile(FileName1: string): boolean;
  415.  
  416.         function RobustStrToFloat(s1: string): Extended;
  417.         function RobustFloatToStr(v1: Extended): string;
  418.         function SortByData(fieldname1: string; lowest2greatest1: boolean): boolean;
  419.         function SortByFloat(fieldname1: string; lowest2greatest1: boolean): boolean;
  420.         procedure RandomSort;
  421.         procedure MakeDistinct;
  422.         function AreSameRows(k, l: LongInt): boolean;
  423.         function Fusion(var dest_mlb, source_mlb: TMlb2; a1: TMlbFusionArray): boolean;
  424.   end;
  425.  
  426. function Trim(s1: string): string;
  427. implementation
  428.  
  429. function Trim(s1: string): string;
  430. var i: LongInt;
  431.     r: string;
  432. begin
  433.      i := 1;
  434.      while (i<=length(s1)) and (s1[i] = ' ') do i:=i+1;
  435.      r := Copy(s1, i, length(s1)-i+1);
  436.      i := length(r);
  437.      while (i>0) and (r[i] = ' ') do i:=i-1;
  438.      Result := Copy(r, 1, i);
  439. end;
  440.  
  441. {CONCORDANCES DEBUT IMPLEMENTATION !!!}
  442. constructor TConcordances.Create;
  443. begin
  444.      inherited Create;
  445.      like_matching := false;
  446.      case_matching := true;
  447.      space_matching := true;
  448. end;
  449.  
  450. destructor TConcordances.Destroy;
  451. begin
  452.      inherited Destroy;
  453. end;
  454.  
  455. function TConcordances.del_spaces(var s: string): string;
  456. var i: integer;
  457.     token: string;
  458. begin
  459.      i := 1;
  460.      token := '';
  461.      while (i<=length(s)) do begin
  462.          if (s[i]=' ') then begin
  463.          end else begin
  464.              token := token + s[i];
  465.          end;
  466.          Inc(i, 1);
  467.      end;
  468.      Result := token;
  469. end;
  470.  
  471. function TConcordances.SI_VERIFICATION(sujet1, sujet2: string): boolean;
  472. var s1, s2: string;
  473. begin
  474.      s1 := sujet1;
  475.      s2 := sujet2;
  476.      if space_matching then begin
  477.      end else begin
  478.         del_spaces(s1);
  479.         del_spaces(s2);
  480.      end;
  481.      if case_matching then begin
  482.      end else begin
  483.         s1 := UpperCase(s1);
  484.         s2 := UpperCase(s2);
  485.      end;
  486.      if like_matching then begin
  487.         Result := Concordance(s1, s2);
  488.      end else begin
  489.         Result := s1 = s2;
  490.      end;
  491. end;
  492.  
  493. function TConcordances.Concordance(sujet1, sujet2: string): boolean;
  494. var i: integer;
  495.     j: integer;
  496.     k: integer;
  497.     concorde: boolean;
  498.     n1, n2: integer;
  499.     capting_set: boolean;
  500.     set_not: boolean;
  501.     set_separator: boolean;
  502.     myset: set of char;
  503.     mychar: char;
  504. begin
  505.      i := 1;
  506.      j := 0;
  507.      concorde := true;
  508.      capting_set := false;
  509.      set_separator := false;
  510.      set_not := false;
  511.      myset := [];
  512.      mychar := #0;
  513.      while (i<=length(sujet1)) and concorde do begin
  514.            if capting_set then begin
  515.                if sujet1[i] = ']' then begin
  516.                    capting_set := false;
  517.                    Dec(i, 1);
  518.                end else if (sujet1[i] = '-') and (mychar<>#0) then begin
  519.                    set_separator := true;
  520.                end else if (sujet1[i] = '!') and (mychar=#0) then begin
  521.                    set_not := true;
  522.                end else begin
  523.                    if set_separator then begin
  524.                       for k:=ord(mychar)+1 to ord(sujet1[i]) do begin
  525.                           myset := myset + [chr(k)];
  526.                       end;
  527.                       set_separator := false;
  528.                    end else begin
  529.                       mychar := sujet1[i];
  530.                       myset := myset + [mychar];
  531.                    end;
  532.                end;
  533.            end else begin
  534.                if sujet1[i] = '*' then begin
  535.                   concorde := false;
  536.                   n1 := 0;
  537.                   repeat
  538.                         Inc(i, 1);
  539.                         Inc(n1, 1);
  540.                   until (i>length(sujet1)) or not (sujet1[i] in ['*', '?']);
  541.                   Dec(n1, 1);
  542.                   n2 := 0;
  543.                   if (i<=length(sujet1)) and (sujet1[i]='#') then begin
  544.                      Inc(j, 1);
  545.                      while (j<=length(sujet2)) and (sujet2[j] in ['0'..'9']) do begin
  546.                            Inc(j, 1);
  547.                            Inc(n2, 1);
  548.                      end;
  549.                   end else if (i<=length(sujet1)) then begin
  550.                      Inc(j, 1);
  551.                      while (j<=length(sujet2)) and (sujet2[j]<>sujet1[i]) do begin
  552.                            Inc(j, 1);
  553.                            Inc(n2, 1);
  554.                      end;
  555.                   end else begin
  556.                      n2 := length(sujet2)-j+1;
  557.                      j := length(sujet2) + 1;
  558.                      concorde := n2>=n1;
  559.                   end;
  560.                   concorde := concorde or ((j<=length(sujet2)) and (n2>=n1));
  561.                end else if sujet1[i] = '?' then begin
  562.                    Inc(j, 1);
  563.                    concorde := (j<=length(sujet2));
  564.                end else if sujet1[i] = '#' then begin
  565.                    Inc(j, 1);
  566.                    concorde := (j<=length(sujet2)) and (sujet2[j] in ['0'..'9']);
  567.                end else if sujet1[i] = '[' then begin
  568.                    set_separator := false;
  569.                    set_not := false;
  570.                    capting_set := true;
  571.                    myset := [];
  572.                    mychar := #0;
  573.                end else if sujet1[i] = ']' then begin
  574.                    Inc(j, 1);
  575.                    if set_not then begin
  576.                        concorde := (j<=length(sujet2)) and not (sujet2[j] in myset);
  577.                    end else begin
  578.                        concorde := (j<=length(sujet2)) and (sujet2[j] in myset);
  579.                    end;
  580.                end else begin
  581.                    Inc(j, 1);
  582.                    concorde := (j<=length(sujet2)) and (sujet2[j]=sujet1[i]);
  583.                end;
  584.            end;
  585.            Inc(i, 1);
  586.      end;
  587.      Result := concorde and (j>=length(sujet2));
  588. end;
  589. {CONCORDANCES FIN IMPLEMENTATION !!!}
  590.  
  591. procedure TMlb2.nameFromFilename(filename1: string);
  592. var f: string;
  593.     i: integer;
  594. begin
  595.      f := ExtractFileName(filename1);
  596.      i := length(f);
  597.      while (i>0) and (f[i]<>'.') do begin
  598.            Dec(i, 1);
  599.      end;
  600.      Name := Copy(f, 1, i-1);
  601. end;
  602.  
  603. function TMlb2.getName: string;
  604. begin
  605.      Result := name_;
  606. end;
  607.  
  608. procedure TMlb2.setName(name1: string);
  609. begin
  610.      name_ := name1;
  611. end;
  612.  
  613. constructor TMlb2.Create;
  614. begin
  615.      inherited Create;
  616.  
  617.      Name := '';
  618.      MLBError := MLB_ERROR_NOPE;
  619.      MLBErrorComment := '';
  620.      QuoteSeparator := '"';
  621.      CSVSeparator := ';';
  622.      fields := TMlb2_ROW.Create;
  623.      {fields.Sorted := False;}
  624.      ftypes := TMlb2_ROW.Create;
  625.      {ftypes.Sorted := False;}
  626.      data := TMlb2_SLOTS.Create;
  627.      psv := TMlb2ParseCSV.Create;
  628.      LikeAgent := TConcordances.Create;
  629.      LikeAgent.case_matching := False;
  630.      LikeAgent.space_matching := True;
  631.      LikeAgent.like_matching := True;
  632.      direction := MLB_FORWARD;
  633.      rowcopy[1] := TMlb2_ROW.Create;
  634.      rowcopy[2] := TMlb2_ROW.Create;
  635.      Init;
  636. end;
  637.  
  638. destructor TMlb2.Destroy;
  639. begin
  640.      Init;
  641.      psv.Free;
  642.      rowcopy[1].Free;
  643.      rowcopy[2].Free;
  644.      data.Free;
  645.      fields.Free;
  646.      ftypes.Free;
  647.      LikeAgent.Free;
  648.      inherited Destroy;
  649. end;
  650.  
  651. procedure TMlb2.Assign(var mlb: TMlb2);
  652. var i, j: LongInt;
  653. begin
  654.      Init;
  655.      for i:=1 to mlb.FieldCount do begin
  656.          AddField(mlb.FieldName[i]);
  657.          DataType[i] := mlb.DataType[i];
  658.      end;
  659.      for i:=1 to mlb.RowCount do begin
  660.          AddRow;
  661.          for j:=1 to mlb.FieldCount do begin
  662.              SetDataByIndex(j, mlb.AccessData[j, i]);
  663.          end;
  664.      end;
  665. end;
  666.  
  667. {ISAM PARSE FUNCTIONS --------------------------------------------}
  668. function TMlb2.RFGetChar(H: integer): LongInt;
  669. var r: integer;
  670. begin
  671.      Inc(RFI, 1);
  672.      if RFI>RFD then begin
  673.         r := FileRead(H, RFBuffer, RF_BUFFER_SIZE);
  674.         RFD := r;
  675.         if r=0 then begin
  676.            Result := 1;
  677.            Exit;
  678.         end;
  679.         RFI := 1;
  680.      end else begin
  681.      end;
  682.      CHAR1 := RFBuffer[RFI];
  683.      Inc(RFI, 1);
  684.      if RFI>RFD then begin
  685.         r := FileRead(H, RFBuffer, RF_BUFFER_SIZE);
  686.         RFD := r;
  687.         if r=0 then begin
  688.            Result := 2;
  689.            Exit;
  690.         end;
  691.         RFI := 1;
  692.      end else begin
  693.      end;
  694.      CHAR2 := RFBuffer[RFI];
  695.      Dec(RFI, 1);
  696.      Result := 0;
  697. end;
  698.  
  699. function TMlb2.IsSeparator(s: char): boolean;
  700. begin
  701.      Result := (s=CSVSeparator) or (s=chr(13));
  702. end;
  703.  
  704. function TMlb2.GetNextToken(H: integer): boolean;
  705. var  gr: LongInt;
  706.      trouve: boolean;
  707. begin
  708.      trouve := false;
  709.      token := '';
  710.      gr := 0;
  711.      in_quotes := false;
  712.      with_quotes := false;
  713.      VCHAR := ' ';
  714.      while (gr=0) and not trouve do begin
  715.          gr := RFGetChar(H);
  716.          if (gr<>1) then begin
  717.              if not in_quotes then begin
  718.              {CAS OU ON EST PAS DANS LES QUOTES}
  719.                  if CHAR1=QuoteSeparator then begin
  720.                     with_quotes := true;
  721.                     in_quotes := true;
  722.                  end else if CHAR1=' ' then begin
  723.                  end else if CHAR1=chr(10) then begin
  724.                  end else if IsSeparator(CHAR1) then begin
  725.                      VCHAR := CHAR1;
  726.                      trouve := true;
  727.                  end else begin
  728.                      token := token + CHAR1;
  729.                  end;
  730.              end else begin
  731.              {CAS OU ON EST DANS LES QUOTES}
  732.                  if CHAR1=QuoteSeparator then begin
  733.                     if (gr<>2) and (CHAR2=QuoteSeparator) then begin
  734.                        token := token + QuoteSeparator;
  735.                        RFGetChar(H);
  736.                     end else begin
  737.                        in_quotes := false;
  738.                     end;
  739.                  {end else if CHAR1='"' then begin}
  740.                  end else begin
  741.                     token := token + CHAR1;
  742.                  end;
  743.              end;
  744.          end else begin
  745.          end;
  746.      end;
  747.      Result := gr=0;
  748. end;
  749.  
  750. function TMlb2.LoadFromISAMFile(filename1: string): Boolean;
  751. var H: integer;
  752.     fin, premier: boolean;
  753.     k: LongInt;
  754. begin
  755.      H := FileOpen(filename1, $0);
  756.      if H>0 then begin
  757.         nameFromFilename(filename1);
  758.         Init;
  759.         RFI := 0;
  760.         RFD := 0;
  761.  
  762.         VCHAR := ' ';
  763.         {Lecture des champs}
  764.         fin := false;
  765.         while (VCHAR<>#13) and (not fin) do begin
  766.              fin := not GetNextToken(H);
  767.              if Token<>'' then begin
  768.                 AddField(Token);
  769.              end else begin
  770.              end;
  771.         end;
  772.  
  773.         {Lecture des DonnΘes}
  774.         while not fin do begin
  775.               VCHAR := ' ';
  776.               premier := true;
  777.               k := 1;
  778.               while (VCHAR<>#13) and (not fin) do begin
  779.                    fin := not GetNextToken(H);
  780.                    if not fin then begin
  781.                      if premier then begin
  782.                         GoLast;
  783.                         AddRow;
  784.                      end;
  785.                      if Token<>'' then begin
  786.                         if premier then begin
  787.                             premier := false;
  788.                             if not with_quotes then begin
  789.                                ftypes.Strings[k-1] := 'FLOAT';
  790.                             end else begin
  791.                                ftypes.Strings[k-1] := 'STRING';
  792.                             end;
  793.                         end else begin
  794.                         end;
  795.                         SetDataByIndex(k, Token);
  796.                      end else begin
  797.                         if premier then begin
  798.                             premier := false;
  799.                             if not with_quotes then begin
  800.                                ftypes.Strings[k-1] := 'STRING';
  801.                             end else begin
  802.                             end;
  803.                         end else begin
  804.                         end;
  805.                      end;
  806.                      Inc(k, 1);
  807.                    end;
  808.               end;
  809.         end;
  810.  
  811.         FileClose(H);
  812.         Result := true;
  813.      end else begin
  814.         Result := false;
  815.      end;
  816. end;
  817. {-------------------------------------------------------------------}
  818.  
  819. procedure TMlb2.init_error;
  820. begin
  821.      MLBError := MLB_ERROR_NOPE;
  822.      MLBErrorComment := '';
  823. end;
  824.  
  825. function TMlb2.GetVersionNumber: Integer;
  826. begin
  827.      init_error;
  828.      Result := 100*MLB_MAJOR_VERSION + MLB_MINOR_VERSION;
  829. end;
  830.  
  831. function TMlb2.tonz(m, n: integer): string;
  832. var k1: string;
  833.     i: integer;
  834. begin
  835.      k1 := IntToStr(m);
  836.      for i:=1 to n-length(k1) do begin
  837.          k1 := '0' + k1;
  838.      end;
  839.      Result := k1;
  840. end;
  841.  
  842. function TMlb2.GetVersion: String;
  843. begin
  844.      init_error;
  845.      Result := 'MyLittleBase version ' + IntToStr(MLB_MAJOR_VERSION) + '.' + tonz(MLB_MINOR_VERSION, 2);
  846. end;
  847.  
  848. function TMlb2.trim2(s1: string): string;
  849. var i: LongInt;
  850. begin
  851.      i := 1;
  852.      while (i<=length(s1)) and (s1[i] = ' ') do i:=i+1;
  853.      Result := Copy(s1, i, length(s1)-i+1);
  854. end;
  855.  
  856. function TMlb2.quote2(s: string): string;
  857. var i: LongInt;
  858.     r: string;
  859. begin
  860.      i:=1;
  861.      r := '';
  862.      while i<=length(s) do begin
  863.            if s[i]='"' then begin
  864.               r := r + '""';
  865.            end else begin
  866.               r := r + s[i];
  867.            end;
  868.            i := i + 1;
  869.      end;
  870.      Result := r;
  871. end;
  872.  
  873. function TMlb2.AccessDataRead(field1, index1: LongInt): string;
  874. begin
  875.      If (field1>0) and (field1<=fields.Count) then begin
  876.         Result := row(index1-1).Strings[field1-1];
  877.      end else begin
  878.         Result := '';
  879.      end;
  880. end;
  881.  
  882. function TMlb2.DataTypeRead(index1: LongInt): string;
  883. begin
  884.      If (index1>0) and (index1<=fields.Count) then begin
  885.         Result := ftypes.Strings[index1-1];
  886.      end else begin
  887.         Result := '';
  888.      end;
  889. end;
  890.  
  891. procedure TMlb2.DataTypeWrite(index1: LongInt; v: string);
  892. begin
  893.      If (index1>0) and (index1<=fields.Count) then begin
  894.         ftypes.Strings[index1-1] := v;
  895.      end else begin
  896.      end;
  897. end;
  898.  
  899. function TMlb2.FieldNameRead(index1: LongInt): string;
  900. begin
  901.      If (index1>0) and (index1<=fields.Count) then begin
  902.         Result := fields.Strings[index1-1];
  903.      end else begin
  904.         Result := '';
  905.      end;
  906. end;
  907.  
  908. procedure TMlb2.FieldNameWrite(index1: LongInt; v: string);
  909. begin
  910.      If (index1>0) and (index1<=fields.Count) then begin
  911.         fields.Strings[index1-1] := v;
  912.      end else begin
  913.      end;
  914. end;
  915.  
  916. {INITIALISATION DES STRUCTURES DE DONNEES}
  917. procedure TMlb2.Init;
  918. var i: LongInt;
  919. begin
  920.      init_error;
  921.      fields.Clear;
  922.      ftypes.Clear;
  923.      For i:=0 to (data.Count-1) do begin
  924.          TMlb2_ROW(data.Items[i]).Free;
  925.      end;
  926.      data.Clear;
  927.      data.Pack;
  928.      current := -1;
  929.      position := -1;
  930.      firstseek := False;
  931.      Distinct := False;
  932.      BeginningOfFile := True;
  933.      EndOfFile := True;
  934. end;
  935.  
  936. procedure TMlb2.Clear;
  937. var i: LongInt;
  938. begin
  939.      init_error;
  940.      For i:=0 to (data.Count-1) do begin
  941.          TMlb2_ROW(data.Items[i]).Free;
  942.      end;
  943.      data.Clear;
  944.      data.Pack;
  945.      current := -1;
  946.      position := -1;
  947.      firstseek := False;
  948.      Distinct := False;
  949.      BeginningOfFile := True;
  950.      EndOfFile := True;
  951. end;
  952.  
  953. procedure TMlb2.MakeDistinct;
  954. var i, j: LongInt;
  955. begin
  956.     init_error;
  957.     i := 1;
  958.     while (i<=RowCount) do begin
  959.             j := i+1;
  960.             while (j<=RowCount) do begin
  961.                     if (AreSameRows(i, j)) then begin
  962.                             RemoveRowByIndex(j);
  963.                             Dec(j, 1);
  964.                     end else begin
  965.                     end;
  966.                     Inc(j, 1);
  967.             end;
  968.             Inc(i, 1);
  969.     end;
  970. end;
  971.  
  972. {AJOUT D'UN CHAMPS A LA TABLE}
  973. function TMlb2.AddField(fieldname1: string): Boolean;
  974. var i: LongInt;
  975. begin
  976.      if (Length(Trim2(fieldname1))>0) and (fields.IndexOf(fieldname1) < 0) then begin
  977.       fields.Add(fieldname1);
  978.       ftypes.Add('STRING');
  979.       {Ajouter un Î˜lΘment Î± tous les data}
  980.       For i:=0 to data.Count-1 do begin
  981.           row(i).Add('');
  982.       end;
  983.       Result := True;
  984.      end else begin
  985.       Result := False;
  986.      end;
  987. end;
  988.  
  989. function TMlb2.row(row1: LongInt): TMlb2_ROW;
  990. begin
  991.      if (row1>=0) and (row1<data.Count) then begin
  992.         Result := TMlb2_ROW(data.Items[row1]);
  993.      end else begin
  994.         Result := nil;
  995.      end;
  996. end;
  997.  
  998. function TMlb2.lastrow: TMlb2_ROW;
  999. begin
  1000.      Result := row(data.Count-1);
  1001. end;
  1002.  
  1003. function TMlb2.currentrow: TMlb2_ROW;
  1004. begin
  1005.      Result := TMlb2_ROW(data.Items[current]);
  1006. end;
  1007.  
  1008. procedure TMlb2.AddRow;
  1009. var i: LongInt;
  1010. begin
  1011.      data.Add(TMlb2_ROW.Create);
  1012.      {lastrow.Sorted := False;}
  1013.      {Ajouter autant de valeurs que de champs}
  1014.      For i:=1 to fields.Count do begin
  1015.          lastrow.Add('');
  1016.      end;
  1017.      GoLast;
  1018. end;
  1019.  
  1020. function TMlb2.InsertRow(where1: boolean): boolean;
  1021. var i: LongInt;
  1022.     myrow: TMlb2_ROW;
  1023. begin
  1024.      myrow := TMlb2_ROW.Create;
  1025.      if where1 then begin
  1026.         data.Insert(current+1, myrow);
  1027.         GoNext;
  1028.      end else begin
  1029.         data.Insert(current, myrow);
  1030.      end;
  1031.      {myrow.Sorted := False;}
  1032.      {Ajouter autant de valeurs que de champs}
  1033.      For i:=1 to fields.Count do begin
  1034.          myrow.Add('');
  1035.      end;
  1036.      Result := True;
  1037. end;
  1038.  
  1039. function TMlb2.GetCurrentRow: LongInt;
  1040. begin
  1041.      Result := current + 1;
  1042. end;
  1043.  
  1044. function TMlb2.IsEmpty: Boolean;
  1045. begin
  1046.      Result := data.Count<=0;
  1047. end;
  1048.  
  1049. function TMlb2.RemoveField(fieldname1: string): Boolean;
  1050. var i, k: LongInt;
  1051. begin
  1052.      k := fields.IndexOf(fieldname1);
  1053.      if k>=0 then begin
  1054.          fields.Delete(k);
  1055.          ftypes.Delete(k);
  1056.          for i:=0 to data.Count-1 do begin
  1057.              row(i).Delete(k);
  1058.          end;
  1059.          Result := True;
  1060.      end else begin
  1061.          Result := False;
  1062.      end;
  1063. end;
  1064.  
  1065. function TMlb2.AreSameRows(k, l: LongInt): boolean;
  1066. var i: LongInt;
  1067. begin
  1068.      for i:=1 to FieldCount do begin
  1069.         if (AccessData[i, k]<>AccessData[i, l]) then begin
  1070.                 Result := false;
  1071.                 Exit;
  1072.         end else begin
  1073.         end;
  1074.      end;
  1075.      Result := true;
  1076. end;
  1077.  
  1078. function TMlb2.RemoveRow: Boolean;
  1079. begin
  1080.      Result := RemoveRowByIndex(GetCurrentRow);
  1081.      if (GetCurrentRow>0) and (GetCurrentRow<=RowCount) then begin
  1082.      end else begin
  1083.          GoLast;
  1084.      end;
  1085. end;
  1086.  
  1087. function TMlb2.RemoveRowByIndex(k: LongInt): Boolean;
  1088. begin
  1089.      {detruit la ligne courante}
  1090.      If (k>0) and (k<=data.Count) then begin
  1091.          row(k-1).Free;
  1092.          data.Delete(k-1);
  1093.          data.Pack;
  1094.          Result := True;
  1095.      end else begin
  1096.          Result := False;
  1097.      end;
  1098. end;
  1099.  
  1100. function TMlb2.Go(row1: LongInt): Boolean;
  1101. begin
  1102.      If (row1>0) and (row1<=data.Count) then begin
  1103.         current := row1-1;
  1104.         BeginningOfFile := False;
  1105.         EndOfFile := False;
  1106.         Result := True;
  1107.      end else begin
  1108.         BeginningOfFile := True;
  1109.         EndOfFile := True;
  1110.         Result := False;
  1111.      end;
  1112. end;
  1113.  
  1114. function TMlb2.GoFirst: Boolean;
  1115. begin
  1116.      if not IsEmpty then begin
  1117.         current := 0;
  1118.         BeginningOfFile := False;
  1119.         EndOfFile := False;
  1120.         Result := True;
  1121.      end else begin
  1122.         current := -1;
  1123.         BeginningOfFile := True;
  1124.         EndOfFile := True;
  1125.         Result := False;
  1126.      end;
  1127. end;
  1128.  
  1129. function TMlb2.GoLast: Boolean;
  1130. begin
  1131.      if not IsEmpty then begin
  1132.         current := data.Count-1;
  1133.         BeginningOfFile := False;
  1134.         EndOfFile := False;
  1135.         Result := True;
  1136.      end else begin
  1137.         current := -1;
  1138.         BeginningOfFile := True;
  1139.         EndOfFile := True;
  1140.         Result := False;
  1141.      end;
  1142. end;
  1143.  
  1144. function TMlb2.GoNext: Boolean;
  1145. begin
  1146.      if not IsEmpty and (current<(data.Count-1)) then begin
  1147.         Inc(current, 1);
  1148.         BeginningOfFile := False;
  1149.         EndOfFile := False;
  1150.         Result := True;
  1151.      end else begin
  1152.         BeginningOfFile := IsEmpty;
  1153.         EndOfFile := true;
  1154.         Result := False;
  1155.      end;
  1156. end;
  1157.  
  1158. function TMlb2.GoPrevious: Boolean;
  1159. begin
  1160.      if not IsEmpty and (current>0) then begin
  1161.         Dec(current, 1);
  1162.         BeginningOfFile := False;
  1163.         EndOfFile := False;
  1164.         Result := True;
  1165.      end else begin
  1166.         BeginningOfFile := true;
  1167.         EndOfFile := IsEmpty;
  1168.         Result := False;
  1169.      end;
  1170. end;
  1171.  
  1172. function TMlb2.GetFieldName(index1: LongInt): string;
  1173. begin
  1174.      If (index1>0) and (index1<=fields.Count) then begin
  1175.         Result := fields.Strings[index1-1];
  1176.      end else begin
  1177.         Result := '';
  1178.      end;
  1179. end;
  1180.  
  1181. function TMlb2.GetFieldIndex(fieldname1: string): LongInt;
  1182. var k: LongInt;
  1183. begin
  1184.      k := fields.IndexOf(fieldname1);
  1185.      If k>=0 then begin
  1186.         Result := k+1;
  1187.      end else begin
  1188.         Result := 0;
  1189.      end;
  1190. end;
  1191.  
  1192. function TMlb2.GetData(fieldname1: string): string;
  1193. var k: LongInt;
  1194. begin
  1195.      k := fields.IndexOf(fieldname1);
  1196.      If k>=0 then begin
  1197.          If current>=0 then begin
  1198.             Result := row(current).Strings[k];
  1199.          end else begin
  1200.             Result := '';
  1201.          end;
  1202.      end else begin
  1203.          Result := '';
  1204.      end;
  1205. end;
  1206.  
  1207. function TMlb2.SetData(fieldname1: string; data1: string): Boolean;
  1208. var k: LongInt;
  1209. begin
  1210.      k := fields.IndexOf(fieldname1);
  1211.      If k>=0 then begin
  1212.          If current>=0 then begin
  1213.             row(current).Strings[k] := data1;
  1214.             Result := True;
  1215.          end else begin
  1216.             Result := False;
  1217.          end;
  1218.      end else begin
  1219.          Result := False;
  1220.      end;
  1221. end;
  1222.  
  1223.  
  1224. function TMlb2.GetDataByIndex(index1: LongInt): string;
  1225. begin
  1226.      If (index1>0) and (index1<=fields.Count) then begin
  1227.          If current>=0 then begin
  1228.             Result := row(current).Strings[index1-1];
  1229.          end else begin
  1230.             Result := '';
  1231.          end;
  1232.      end else begin
  1233.          Result := '';
  1234.      end;
  1235. end;
  1236.  
  1237. function TMlb2.SetDataByIndex(index1: LongInt; data1: string): Boolean;
  1238. begin
  1239.      If (index1>0) and (index1<=fields.Count) then begin
  1240.          If current>=0 then begin
  1241.             row(current).Strings[index1-1] := data1;
  1242.             Result := True;
  1243.          end else begin
  1244.             Result := False;
  1245.          end;
  1246.      end else begin
  1247.          Result := False;
  1248.      end;
  1249. end;
  1250.  
  1251.  
  1252. function TMlb2.GetFloat(fieldname1: string): Extended;
  1253. var k: LongInt;
  1254. begin
  1255.      k := fields.IndexOf(fieldname1);
  1256.      If k>=0 then begin
  1257.          If current>=0 then begin
  1258.             Result := RobustStrToFloat(row(current).Strings[k]);
  1259.          end else begin
  1260.             Result := 0.0;
  1261.          end;
  1262.      end else begin
  1263.          Result := 0.0;
  1264.      end;
  1265. end;
  1266.  
  1267. function TMlb2.SetFloat(fieldname1: string; float1: Extended): Boolean;
  1268. var k: LongInt;
  1269. begin
  1270.      k := fields.IndexOf(fieldname1);
  1271.      If k>=0 then begin
  1272.          If current>=0 then begin
  1273.             row(current).Strings[k] := RobustFloatToStr(float1);
  1274.             Result := True;
  1275.          end else begin
  1276.             Result := False;
  1277.          end;
  1278.      end else begin
  1279.          Result := False;
  1280.      end;
  1281. end;
  1282.  
  1283. function TMlb2.GetFloatByIndex(index1: LongInt): Extended;
  1284. begin
  1285.      If (index1>0) and (index1<=fields.Count) then begin
  1286.          If current>=0 then begin
  1287.             Result := RobustStrToFloat(row(current).Strings[index1-1]);
  1288.          end else begin
  1289.             Result := 0.0;
  1290.          end;
  1291.      end else begin
  1292.          Result := 0.0;
  1293.      end;
  1294. end;
  1295.  
  1296. function TMlb2.SetFloatByIndex(index1: LongInt; float1: Extended): Boolean;
  1297. begin
  1298.      If (index1>0) and (index1<=fields.Count) then begin
  1299.          If current>=0 then begin
  1300.             row(current).Strings[index1-1] := RobustFloatToStr(float1);
  1301.             Result := True;
  1302.          end else begin
  1303.             Result := False;
  1304.          end;
  1305.      end else begin
  1306.          Result := False;
  1307.      end;
  1308. end;
  1309.  
  1310. function TMlb2.find_extension(filename1: string): string;
  1311. begin
  1312.      if length(filename1)>=3 then begin
  1313.          Result := UpperCase(Copy(filename1, length(filename1)-2, 3));
  1314.      end else begin
  1315.          Result := '';
  1316.      end;
  1317. end;
  1318.  
  1319. function TMlb2.LoadFromFile(filename1: string): Boolean;
  1320. var extension: string;
  1321. begin
  1322.      init_error;
  1323.      extension := find_extension(filename1);
  1324.      if extension = 'TXT' then begin
  1325.          Result := LoadFromISAMFile(filename1);
  1326.      end else if extension = 'CSV' then begin
  1327.          Result := LoadFromCSVFile(filename1);
  1328.      end else if extension = 'MLB' then begin
  1329.          Result := LoadFromMLBFile(filename1);
  1330.      end else begin
  1331.          Result := LoadFromCSVFile(filename1);
  1332.      end;
  1333. end;
  1334.  
  1335. function TMlb2.LoadFromMLBFile(filename1: string): Boolean;
  1336. var H: Integer;
  1337.     bdummy: MLB_int1;
  1338.     ddummy: MLB_int2;
  1339.     ldummy: MLB_int4;
  1340.     i, j, nf, nv: LongInt;
  1341.     bcount: LongInt;
  1342.     signature: array [1..3] of char;
  1343. begin
  1344.      init_error;
  1345.      H := FileOpen(FileName1, $0);
  1346.      If H>0 then begin
  1347.         {Reads the SIGNATURE}
  1348.         FileRead(H, signature, 3);
  1349.         if (signature[1]<>'M') or (signature[2]<>'L') or (signature[3]<>'B') then begin
  1350.            {This is not a MyLittleBase file}
  1351.            MLBError := MLB_ERROR_BADFORMAT;
  1352.            MLBErrorComment := '1-File''s Signature must be MLB';
  1353.            FileClose(H);
  1354.            Result := False; Exit;
  1355.         end;
  1356.         {Reads versions numbers, ignored}
  1357.         {MAJOR VERSION NUMBER}
  1358.         FileRead(H, bdummy, sizeof(MLB_int1));
  1359.         {MINOR VERSION NUMBER}
  1360.         FileRead(H, bdummy, sizeof(MLB_int1));
  1361.         {LITTLE ENDIAN ?}
  1362.         FileRead(H, bdummy, sizeof(MLB_int1));
  1363.         if same_endian(bdummy) then begin
  1364. {SAME Endian}
  1365.             {TABLES COUNT}
  1366.             FileRead(H, ddummy, sizeof(MLB_int2));
  1367.             If (ddummy<1) then begin
  1368.                {number of tables must be at least 1}
  1369.                MLBError := MLB_ERROR_BADFORMAT;
  1370.                MLBErrorComment := '2-number of tables must be at least 1';
  1371.                FileClose(H);
  1372.                Result := False; Exit;
  1373.             end;
  1374.             {ADDITIONAL COUNT} {ignored in MLB 2.00}
  1375.             FileRead(H, ddummy, sizeof(MLB_int2));
  1376.  
  1377.             {BLOCKID FOR TABLE 1}
  1378.             FileRead(H, ddummy, sizeof(MLB_int2));
  1379.             if (ddummy<>0) then begin
  1380.                {The first block must be a TABLE in this version}
  1381.                MLBError := MLB_ERROR_BADFORMAT;
  1382.                MLBErrorComment := '3-First Block must be a TABLE';
  1383.                FileClose(H);
  1384.                Result := False; Exit;
  1385.             end;
  1386.             Init; {Reinits MyLittleBase}
  1387.             {length of table data}
  1388.             FileRead(H, bcount, sizeof(MLB_int4));
  1389.             {TABLEID FOR TABLE 1 Not used in this version}
  1390.             FileRead(H, ddummy, sizeof(MLB_int2));
  1391.             {TABLENAME FOR TABLE 1}
  1392.             Name := read_text_as_binary(H);
  1393.  
  1394.             {FIELDS COUNT}
  1395.             FileRead(H, nf, sizeof(MLB_int4));
  1396.             {ROWS COUNT}
  1397.             FileRead(H, nv, sizeof(MLB_int4));
  1398.  
  1399.             for i:=1 to nf do begin
  1400.                 {Reads THE DATA TYPE}
  1401.                 FileRead(H, bdummy, sizeof(MLB_int1));
  1402.                 {Reads FIELDNAME and Adds the new field}
  1403.                 AddField(read_text_as_binary(H));
  1404.                 case bdummy of
  1405.                      0: begin
  1406.                         DataType[i] := 'STRING';
  1407.                      end;
  1408.                      1: begin
  1409.                         DataType[i] := 'FLOAT';
  1410.                      end;
  1411.                      else begin
  1412.                         DataType[i] := 'STRING';
  1413.                      end;
  1414.                 end;
  1415.             end;
  1416.             for j:=1 to nv do begin
  1417.                 {Reads the row length, ignored, reserved for read from disk operations}
  1418.                 FileRead(H, ldummy, sizeof(MLB_int4));
  1419.                 AddRow;
  1420.                 for i:=1 to nf do begin
  1421.                     SetDataByIndex(i, read_text_as_binary(H));
  1422.                 end;
  1423.             end;
  1424.         end else begin
  1425. {Other endian}
  1426.             {TABLES COUNT}
  1427.             ddummy := read_int2_from_other_endian(H);
  1428.             If (ddummy<1) then begin
  1429.                {number of tables must be at least 1}
  1430.                MLBError := MLB_ERROR_BADFORMAT;
  1431.                MLBErrorComment := '2-number of tables must be at least 1';
  1432.                FileClose(H);
  1433.                Result := False; Exit;
  1434.             end;
  1435.             {ADDITIONAL COUNT} {ignored in MLB 2.00}
  1436.             ddummy := read_int2_from_other_endian(H);
  1437.  
  1438.             {BLOCKID FOR TABLE 1}
  1439.             ddummy := read_int2_from_other_endian(H);
  1440.             if (ddummy<>0) then begin
  1441.                {The first block must be a TABLE in this version}
  1442.                MLBError := MLB_ERROR_BADFORMAT;
  1443.                MLBErrorComment := '3-First Block must be a TABLE';
  1444.                FileClose(H);
  1445.                Result := False; Exit;
  1446.             end;
  1447.             Init; {Reinits MyLittleBase}
  1448.             {length of table data}
  1449.             bcount := read_int4_from_other_endian(H);
  1450.             {TABLEID FOR TABLE 1 Not used in this version}
  1451.             ddummy := read_int2_from_other_endian(H);
  1452.             {TABLENAME FOR TABLE 1}
  1453.             Name := read_text_as_binary(H);
  1454.  
  1455.             {FIELDS COUNT}
  1456.             nf := read_int4_from_other_endian(H);
  1457.             {ROWS COUNT}
  1458.             nv := read_int4_from_other_endian(H);
  1459.  
  1460.             for i:=1 to nf do begin
  1461.                 {Reads THE DATA TYPE}
  1462.                 FileRead(H, bdummy, sizeof(MLB_int1));
  1463.                 {Reads FIELDNAME and Adds the new field}
  1464.                 AddField(read_text_as_binary(H));
  1465.                 case bdummy of
  1466.                      0: begin
  1467.                         DataType[i] := 'STRING';
  1468.                      end;
  1469.                      1: begin
  1470.                         DataType[i] := 'FLOAT';
  1471.                      end;
  1472.                      else begin
  1473.                         DataType[i] := 'STRING';
  1474.                      end;
  1475.                 end;
  1476.             end;
  1477.             for j:=1 to nv do begin
  1478.                 {Reads the row length, ignored, reserved for read from disk operations}
  1479.                 ldummy := read_int4_from_other_endian(H);
  1480.                 AddRow;
  1481.                 for i:=1 to nf do begin
  1482.                     SetDataByIndex(i, read_text_as_binary(H));
  1483.                 end;
  1484.             end;
  1485.         end;
  1486.         FileClose(H);
  1487.         Result := True;
  1488.      end else begin
  1489.         MLBError := MLB_ERROR_IO;
  1490.         MLBErrorComment := '4-Unable to open file for reading';
  1491.         Result := False;
  1492.      end;
  1493. end;
  1494.  
  1495. function TMlb2.LoadFromCSVFile(filename1: string): Boolean;
  1496. var F: TextFile;
  1497.     fline, token: string;
  1498.     is_first_line: boolean;
  1499.     i, k: LongInt;
  1500. begin
  1501.      init_error;
  1502.      AssignFile(F, filename1);
  1503.      {$i-}
  1504.         Reset(F);
  1505.      {$i+}
  1506.      If (Trim(filename1)='') or (IoResult<>0) then begin
  1507.         {CloseFile(F);}
  1508.         MLBError := MLB_ERROR_IO;
  1509.         MLBErrorComment := '1-Unable to open the file for reading';
  1510.         Result := False;
  1511.         Exit;
  1512.      end else begin
  1513.          nameFromFilename(filename1);
  1514.          Result := True;
  1515.          Init;
  1516.          is_first_line := True;
  1517.          While Not Eof(F) Do begin
  1518.                ReadLn(F, fline);
  1519.                if (not is_first_line) and (Trim(fline)<>'') then begin
  1520.                   AddRow;
  1521.                end else begin
  1522.                end;
  1523.                i := 1;
  1524.                k := 0;
  1525.                token := '';
  1526.                while (i<=length(fline)) do begin
  1527.                      if (fline[i] = '\') then begin
  1528.                         if (i<length(fline)) then begin
  1529.                             if (UpperCase(fline[i+1])='N') then begin
  1530.                                token := token + #13 + #10;
  1531.                             end else begin
  1532.                                token := token + fline[i+1];
  1533.                             end;
  1534.                             Inc(i, 1);
  1535.                         end else begin
  1536.                             token := token + fline[i];
  1537.                         end;
  1538.                      end else if (fline[i]=CSVSeparator) then begin
  1539.                           if is_first_line then begin
  1540.                              AddField(token);
  1541.                           end else begin
  1542.                              lastrow.Strings[k] := token;
  1543.                           end;
  1544.                           Inc(k, 1);
  1545.                           token := '';
  1546.                      end else begin
  1547.                           token := token + fline[i];
  1548.                      end;
  1549.                      Inc(i, 1);
  1550.                end;
  1551.                if is_first_line then begin
  1552.                  AddField(token);
  1553.                end else begin
  1554.                  lastrow.Strings[k] := token;
  1555.                end;
  1556.                is_first_line := False;
  1557.          end;
  1558.          CloseFile(F);
  1559.      end;
  1560. end;
  1561.  
  1562. function TMlb2.SaveToFile(FileName1: string): boolean;
  1563. var extension: string;
  1564. begin
  1565.      extension := find_extension(filename1);
  1566.      if extension = 'TXT' then begin
  1567.          Result := SaveToISAMFile(filename1);
  1568.      end else if extension = 'CSV' then begin
  1569.          Result := SaveToCSVFile(filename1);
  1570.      end else if extension = 'MLB' then begin
  1571.          Result := SaveToMLBFile(filename1);
  1572.      end else begin
  1573.          Result := SaveToCSVFile(filename1);
  1574.      end;
  1575. end;
  1576.  
  1577. procedure TMlb2.write_text_as_binary(var f: file; t: string);
  1578. var l: LongInt;
  1579.     r: integer;
  1580.     p: PChar;
  1581. begin
  1582.      l := length(t);
  1583.      BlockWrite(f, l, 4, r);
  1584.      p := @t[1];
  1585.      BlockWrite(f, p^, l, r);
  1586. end;
  1587.  
  1588. function TMlb2.read_text_as_binary(H: integer): string;
  1589. var l: LongInt;
  1590.     p: PChar;
  1591.     res: string;
  1592. begin
  1593.      FileRead(H, l, sizeof(LongInt));
  1594.      p := AllocMem(l+1);
  1595.      FileRead(H, p^, l);
  1596.      p[l] := #0;
  1597.      res := StrPas(p);
  1598.      FreeMem(p, l);
  1599.      Result := res;
  1600. end;
  1601.  
  1602. function TMlb2.local_endian: byte;
  1603. var ktest: MLB_int2;
  1604.     ptest: PMLB_endian_test;
  1605. begin
  1606.      ktest := $FF00;
  1607.      ptest := PMLB_endian_test(@ktest);
  1608.      if (ptest^[2]=$FF) then begin
  1609.         Result := 1;
  1610.      end else begin
  1611.         Result := 0;
  1612.      end;
  1613. end;
  1614.  
  1615. function TMlb2.read_int2_from_other_endian(H: integer): MLB_int2;
  1616. var p: array [1..3] of byte;
  1617. begin
  1618.     FileRead(H, p, 2*sizeof(byte));
  1619.     p[3] := p[2]; p[2] := p[1]; p[1] := p[3];
  1620.     Result := MLB_int2((@p)^);
  1621. end;
  1622.  
  1623. function TMlb2.read_int4_from_other_endian(H: integer): MLB_int4;
  1624. var p: array [1..5] of byte;
  1625. begin
  1626.     FileRead(H, p, 4*sizeof(byte));
  1627.     p[5] := p[4]; p[4] := p[1]; p[1] := p[5];
  1628.     p[5] := p[3]; p[3] := p[2]; p[2] := p[5];
  1629.     Result := MLB_int4((@p)^);
  1630. end;
  1631.  
  1632. function TMlb2.SaveToMLBFile(FileName1: string): boolean;
  1633. var F: file;
  1634.     r: integer;
  1635.     cdummy: char;
  1636.     bdummy: MLB_int1;
  1637.     ddummy: MLB_int2;
  1638.     ldummy: MLB_int4;
  1639.     table_offset: LongInt;
  1640.     row_offset: LongInt;
  1641.     my_offset: LongInt;
  1642.     i, j: LongInt;
  1643.     bcount, rcount: LongInt;
  1644.     data: string;
  1645. begin
  1646.      init_error;
  1647.      AssignFile(F, FileName1);
  1648.      {$i-}
  1649.      Rewrite(F, 1);
  1650.      {$i+}
  1651.      If IoResult=0 then begin
  1652.         {Write the SIGNATURE}
  1653.         cdummy := 'M'; BlockWrite(F, cdummy, sizeof(char), r);
  1654.         cdummy := 'L'; BlockWrite(F, cdummy, sizeof(char), r);
  1655.         cdummy := 'B'; BlockWrite(F, cdummy, sizeof(char), r);
  1656.         {MAJOR VERSION NUMBER}
  1657.         bdummy := MLB_MAJOR_VERSION;
  1658.         BlockWrite(F, bdummy, sizeof(MLB_int1), r);
  1659.         {MINOR VERSION NUMBER}
  1660.         bdummy := MLB_MINOR_VERSION;
  1661.         BlockWrite(F, bdummy, sizeof(MLB_int1), r);
  1662.         {LITTLE ENDIAN ?}
  1663.         bdummy := local_endian;
  1664.         BlockWrite(F, bdummy, sizeof(MLB_int1), r);
  1665.         {TABLES COUNT}
  1666.         ddummy := 1;
  1667.         BlockWrite(F, ddummy, sizeof(MLB_int2), r);
  1668.         {ADDITIONAL COUNT}
  1669.         ddummy := 0;
  1670.         BlockWrite(F, ddummy, sizeof(MLB_int2), r);
  1671.  
  1672.         {BLOCKID FOR TABLE 1}
  1673.         ddummy := 0;
  1674.         BlockWrite(F, ddummy, sizeof(MLB_int2), r);
  1675.         {Saves The Position to Save the block length}
  1676.         bcount := 0;
  1677.         table_offset := FilePos(F);
  1678.         ldummy := 0;
  1679.         BlockWrite(F, ldummy, sizeof(MLB_int4), r);
  1680.         {TABLEID FOR TABLE 1 Not used in this version}
  1681.         ddummy := 0;
  1682.         BlockWrite(F, ddummy, sizeof(MLB_int2), r);
  1683.         bcount := bcount + 2;
  1684.         {TABLENAME FOR TABLE 1}
  1685.         write_text_as_binary(F, Name);
  1686.         bcount := bcount + 4 + length(Name);
  1687.  
  1688.         {FIELDS COUNT}
  1689.         ldummy := FieldCount;
  1690.         BlockWrite(F, ldummy, sizeof(MLB_int4), r);
  1691.         bcount := bcount + 4;
  1692.         {ROWS COUNT}
  1693.         ldummy := RowCount;
  1694.         BlockWrite(F, ldummy, sizeof(MLB_int4), r);
  1695.         bcount := bcount + 4;
  1696.  
  1697.         for i:=1 to FieldCount do begin
  1698.             {SAVES THE DATA TYPE}
  1699.             if DataType[i]='STRING' then begin
  1700.                bdummy := 0;
  1701.                BlockWrite(F, bdummy, sizeof(MLB_int1), r);
  1702.             end else if DataType[i]='FLOAT' then begin
  1703.                bdummy := 1;
  1704.                BlockWrite(F, bdummy, sizeof(MLB_int1), r);
  1705.             end else begin
  1706.                bdummy := 0;
  1707.                BlockWrite(F, bdummy, sizeof(MLB_int1), r);
  1708.             end;
  1709.             {SAVES FIELDNAMES}
  1710.             write_text_as_binary(F, FieldName[i]);
  1711.             bcount := bcount + 1 + 4 + length(FieldName[i]);
  1712.         end;
  1713.         for j:=1 to RowCount do begin
  1714.             {Saves the position of the row length}
  1715.             rcount := 0;
  1716.             row_offset := FilePos(F);
  1717.             ldummy := 0;
  1718.             BlockWrite(F, ldummy, sizeof(MLB_int4), r);
  1719.             for i:=1 to FieldCount do begin
  1720.                 data := AccessData[i, j];
  1721.                 write_text_as_binary(F, data);
  1722.                 rcount := rcount + 4 + length(data);
  1723.             end;
  1724.             my_offset := FilePos(F);
  1725.             Seek(F, row_offset);
  1726.             BlockWrite(F, rcount, sizeof(MLB_int4), r);
  1727.             Seek(F, my_offset);
  1728.             bcount := bcount + 4 + rcount;
  1729.         end;
  1730.         my_offset := FilePos(F);
  1731.         Seek(F, table_offset);
  1732.         BlockWrite(F, bcount, sizeof(MLB_int4), r);
  1733.         Seek(F, my_offset);
  1734.         CloseFile(F);
  1735.         Result := True;
  1736.      end else begin
  1737.         MLBError := MLB_ERROR_IO;
  1738.         MLBErrorComment := '1-Unable to open the file for writing';
  1739.         Result := False;
  1740.      end;
  1741. end;
  1742.  
  1743. function TMlb2.same_endian(endian1: byte): boolean;
  1744. begin
  1745.      Result := local_endian = endian1;
  1746. end;
  1747.  
  1748. function TMlb2.SaveToCSVFile(filename1: string): Boolean;
  1749. var F: TextFile;
  1750.     i, j: LongInt;
  1751. begin
  1752.      init_error;
  1753.      AssignFile(F, filename1);
  1754.      try
  1755.         Rewrite(F);
  1756.         Result := True;
  1757.      except
  1758.         CloseFile(F);
  1759.         MLBError := MLB_ERROR_IO;
  1760.         MLBErrorComment := '1-Unable to open the file for writing';
  1761.         Result := False;
  1762.         Exit;
  1763.      end;
  1764.      for i:=0 to fields.Count-2 do begin
  1765.          Write(F, fields.Strings[i], CSVSeparator);
  1766.      end;
  1767.      if fields.Count>0 then begin
  1768.         WriteLn(F, fields.Strings[fields.Count-1]);
  1769.      end;
  1770.      for i:=0 to data.Count-1 do begin
  1771.          for j:=0 to fields.Count-2 do begin
  1772.              Write(F, psv.ToN(row(i).Strings[j]), CSVSeparator);
  1773.          end;
  1774.          if not IsEmpty then begin
  1775.             WriteLn(F, psv.ToN(row(i).Strings[fields.Count-1]));
  1776.          end;
  1777.      end;
  1778.      CloseFile(F);
  1779. end;
  1780.  
  1781. function TMlb2.SaveToISAMFile(filename1: string): Boolean;
  1782. var F: TextFile;
  1783.     i, j: LongInt;
  1784. begin
  1785.      init_error;
  1786.      AssignFile(F, filename1);
  1787.      try
  1788.         Rewrite(F);
  1789.         Result := True;
  1790.      except
  1791.         CloseFile(F);
  1792.         MLBError := MLB_ERROR_IO;
  1793.         MLBErrorComment := '1-Unable to open the file for writing';
  1794.         Result := False;
  1795.         Exit;
  1796.      end;
  1797.      for i:=0 to fields.Count-2 do begin
  1798.          Write(F, QuoteSeparator, fields.Strings[i], QuoteSeparator, CSVSeparator);
  1799.      end;
  1800.      if fields.Count>0 then begin
  1801.         WriteLn(F, QuoteSeparator, fields.Strings[fields.Count-1], QuoteSeparator);
  1802.      end;
  1803.      for i:=0 to data.Count-1 do begin
  1804.          for j:=0 to fields.Count-2 do begin
  1805.              if ftypes.Strings[j] = 'STRING' then begin
  1806.                 Write(F, QuoteSeparator, quote2(row(i).Strings[j]), QuoteSeparator, CSVSeparator);
  1807.              end else begin
  1808.                 Write(F, row(i).Strings[j], CSVSeparator);
  1809.              end;
  1810.          end;
  1811.          if not IsEmpty then begin
  1812.              if ftypes.Strings[fields.Count-1] = 'STRING' then begin
  1813.                 WriteLn(F, QuoteSeparator, quote2(row(i).Strings[fields.Count-1]), QuoteSeparator);
  1814.              end else begin
  1815.                 WriteLn(F, row(i).Strings[fields.Count-1]);
  1816.              end;
  1817.          end;
  1818.      end;
  1819.      CloseFile(F);
  1820. end;
  1821.  
  1822. procedure TMlb2.ForceRows(nrows: LongInt);
  1823. var i, rw: LongInt;
  1824. begin
  1825.      rw := GetCurrentRow;
  1826.      if nrows<RowCount then begin
  1827.         for i:=1 to RowCount-nrows do begin
  1828.             GoLast;
  1829.             RemoveRow;
  1830.         end;
  1831.      end else if nrows>RowCount then begin
  1832.         for i:=1 to nrows-RowCount do begin
  1833.             GoLast;
  1834.             AddRow;
  1835.         end;
  1836.      end else begin
  1837.      end;
  1838.      Go(rw);
  1839. end;
  1840.  
  1841. function TMlb2.RowCount: LongInt;
  1842. begin
  1843.      Result := data.Count;
  1844. end;
  1845.  
  1846. function TMlb2.FieldCount: LongInt;
  1847. begin
  1848.      Result := fields.Count;
  1849. end;
  1850.  
  1851. function TMlb2.SavePosition: boolean;
  1852. begin
  1853.      if (current>=0) and (current<data.Count) then begin
  1854.         position := current;
  1855.         Result := True;
  1856.      end else begin
  1857.         Result := False;
  1858.      end;
  1859. end;
  1860.  
  1861. function TMlb2.RestorePosition: boolean;
  1862. begin
  1863.      if (position>=0) and (position<data.Count) then begin
  1864.         current := position;
  1865.         Result := True;
  1866.      end else begin
  1867.         Result := False;
  1868.      end;
  1869. end;
  1870.  
  1871. function TMlb2.RobustStrToFloat(s1: string): Extended;
  1872. var i: LongInt;
  1873.     anomalie, sortie, cas1, cas2: boolean;
  1874.     r: string;
  1875. begin
  1876.     r := '';
  1877.     for i:=1 to length(s1) do begin
  1878.          if s1[i] in ['.', ','] then s1[i] := DecimalSeparator;
  1879.          case s1[i] of
  1880.               '0'..'9', '.', ',', 'E', 'e', '+', '-': begin
  1881.                 r := r + s1[i];
  1882.               end;
  1883.          end;
  1884.     end;
  1885.     {Avant E, [+, -]Chiffres[DC]Chiffres[E, e][+, -]Chiffres}
  1886.     {Le premier caractere doit etre [+, -, chiffre]}
  1887.     if length(r)>0 then begin
  1888.         if (r[1] in ['0'..'9', '+', '-']) then begin
  1889.            i := 2;
  1890.            anomalie := false;
  1891.            sortie := false;
  1892.            cas1 := false;
  1893.            cas2 := false;
  1894.            while not sortie and (i<=length(r)) do begin
  1895.                  if not (r[i] in ['0'..'9']) then begin
  1896.                     cas1 := r[i]=DecimalSeparator;
  1897.                     cas2 := UpperCase(r[i])='E';
  1898.                     anomalie := not (cas1 or cas2);
  1899.                     sortie := true;
  1900.                  end else begin
  1901.                  end;
  1902.                  Inc(i, 1);
  1903.            end;
  1904.            if cas1 then begin
  1905.               anomalie := false;
  1906.               sortie := false;
  1907.               while not sortie and (i<=length(r)) do begin
  1908.                     if not (r[i] in ['0'..'9']) then begin
  1909.                        anomalie := UpperCase(r[i])<>'E';
  1910.                        cas2 := True;
  1911.                        sortie := true;
  1912.                     end else begin
  1913.                     end;
  1914.                     Inc(i, 1);
  1915.               end;
  1916.            end;
  1917.            if cas2 then begin
  1918.                anomalie := anomalie or not (r[i] in ['+', '-', '0'..'9']);
  1919.                Inc(i, 1);
  1920.                sortie := false;
  1921.                while not sortie and (i<=length(r)) do begin
  1922.                     if not (r[i] in ['0'..'9']) then begin
  1923.                        anomalie := True;
  1924.                        sortie := true;
  1925.                     end else begin
  1926.                     end;
  1927.                     Inc(i, 1);
  1928.                end;
  1929.            end;
  1930.            if anomalie then begin
  1931.               Result := 0.0;
  1932.            end else begin
  1933.               Result := StrToFloat(r);
  1934.            end;
  1935.         end else begin
  1936.             Result := 0.0;
  1937.         end;
  1938.     end else begin
  1939.         Result := 0.0;
  1940.     end;
  1941. end;
  1942.  
  1943. function TMlb2.RobustFloatToStr(v1: Extended): string;
  1944. begin
  1945.      Result := FloatToStr(v1);
  1946. end;
  1947.  
  1948. function TMlb2.BeginSeek(direction1: boolean): Boolean;
  1949. begin
  1950.      direction := direction1;
  1951.      If Not IsEmpty then begin
  1952.         firstseek := True;
  1953.         Result := True;
  1954.      end else begin
  1955.         Result := False;
  1956.      end;
  1957. end;
  1958.  
  1959. function TMlb2.EndSeek: Boolean;
  1960. begin
  1961.      If Not IsEmpty then begin
  1962.          If (current<0) or (current>=data.Count) then begin
  1963.             GoLast;
  1964.          end else begin
  1965.          end;
  1966.          firstseek := False;
  1967.          Result := True;
  1968.      end else begin
  1969.          Result := False;
  1970.      end;
  1971. end;
  1972.  
  1973. function TMlb2.MatchData(fieldname1, comp1, value1: string): boolean;
  1974. var trouve: boolean;
  1975. begin
  1976.       trouve := False;
  1977.       if (comp1 = '<') then begin
  1978.          trouve := GetData(fieldname1)<value1;
  1979.       end else if (comp1 = '>') then begin
  1980.          trouve := GetData(fieldname1)>value1;
  1981.       end else if (comp1 = '=') then begin
  1982.          trouve := GetData(fieldname1)=value1;
  1983.       end else if (comp1 = '<=') then begin
  1984.          trouve := GetData(fieldname1)<=value1;
  1985.       end else if (comp1 = '>=') then begin
  1986.          trouve := GetData(fieldname1)>=value1;
  1987.       end else if (UpperCase(comp1) = 'LIKE') then begin
  1988.          trouve := LikeAgent.SI_VERIFICATION(value1, GetData(fieldname1));
  1989.       end else begin
  1990.       end;
  1991.       Result := trouve;
  1992. end;
  1993.  
  1994. function TMlb2.MatchFloat(fieldname1, comp1: string; value1: Extended): boolean;
  1995. var trouve: boolean;
  1996. begin
  1997.       trouve := False;
  1998.       if (comp1 = '<') then begin
  1999.          trouve := GetFloat(fieldname1)<value1;
  2000.       end else if (comp1 = '>') then begin
  2001.          trouve := GetFloat(fieldname1)>value1;
  2002.       end else if (comp1 = '=') then begin
  2003.          trouve := GetFloat(fieldname1)=value1;
  2004.       end else if (comp1 = '<=') then begin
  2005.          trouve := GetFloat(fieldname1)<=value1;
  2006.       end else if (comp1 = '>=') then begin
  2007.          trouve := GetFloat(fieldname1)>=value1;
  2008.       end else begin
  2009.       end;
  2010.       Result := trouve;
  2011. end;
  2012.  
  2013. function TMlb2.SeekData(fieldname1, comp1, value1: string): boolean;
  2014. var trouve: boolean;
  2015.     sens: integer;
  2016.     rw: LongInt;
  2017. begin
  2018.      if direction = MLB_FORWARD then begin
  2019.         sens := 1;
  2020.      end else if direction = MLB_BACKWARD then begin
  2021.         sens := -1;
  2022.      end else begin
  2023.         sens := 1;
  2024.      end;
  2025.      trouve := False;
  2026.      if IsEmpty then begin
  2027.         Result := False;
  2028.      end else begin
  2029.         rw := GetCurrentRow;
  2030.         if (current<0) then begin
  2031.            current := 0;
  2032.         end else if (current>=0) then begin
  2033.            if firstseek then begin
  2034.            end else begin
  2035.               current := current + sens*1;
  2036.            end;
  2037.         end;
  2038.         while (not trouve) and (((direction=MLB_FORWARD) and (current<data.Count))
  2039.               or ((direction=MLB_BACKWARD) and (current>0))) do begin
  2040.               if (comp1 = '<') then begin
  2041.                  trouve := GetData(fieldname1)<value1;
  2042.               end else if (comp1 = '>') then begin
  2043.                  trouve := GetData(fieldname1)>value1;
  2044.               end else if (comp1 = '=') then begin
  2045.                  trouve := GetData(fieldname1)=value1;
  2046.               end else if (comp1 = '<=') then begin
  2047.                  trouve := GetData(fieldname1)<=value1;
  2048.               end else if (comp1 = '>=') then begin
  2049.                  trouve := GetData(fieldname1)>=value1;
  2050.               end else if (UpperCase(comp1) = 'LIKE') then begin
  2051.                  trouve := LikeAgent.SI_VERIFICATION(value1, GetData(fieldname1));
  2052.               end else begin
  2053.               end;
  2054.               if not trouve then current := current + sens*1;
  2055.         end;
  2056.         firstseek := False;
  2057.         if not trouve then begin
  2058.            Go(rw);
  2059.            Result := False;
  2060.         end else begin
  2061.            Result := True;
  2062.         end;
  2063.      end;
  2064. end;
  2065.  
  2066. function TMlb2.SeekFloat(fieldname1, comp1: string; value1: Extended): boolean;
  2067. var trouve: boolean;
  2068.     sens: integer;
  2069.     rw: LongInt;
  2070. begin
  2071.      if direction = MLB_FORWARD then begin
  2072.         sens := 1;
  2073.      end else if direction = MLB_BACKWARD then begin
  2074.         sens := -1;
  2075.      end else begin
  2076.         sens := 1;
  2077.      end;
  2078.      trouve := False;
  2079.      if IsEmpty then begin
  2080.         Result := False;
  2081.      end else begin
  2082.         rw := GetCurrentRow;
  2083.         if (current<0) then begin
  2084.            current := 0;
  2085.         end else if (current>=0) then begin
  2086.            if firstseek then begin
  2087.            end else begin
  2088.               current := current + sens*1;
  2089.            end;
  2090.         end;
  2091.         while (not trouve) and (((direction=MLB_FORWARD) and (current<data.Count))
  2092.               or ((direction=MLB_BACKWARD) and (current>0))) do begin
  2093.               if (comp1 = '<') then begin
  2094.                  trouve := GetFloat(fieldname1)<value1;
  2095.               end else if (comp1 = '>') then begin
  2096.                  trouve := GetFloat(fieldname1)>value1;
  2097.               end else if (comp1 = '=') then begin
  2098.                  trouve := GetFloat(fieldname1)=value1;
  2099.               end else if (comp1 = '<=') then begin
  2100.                  trouve := GetFloat(fieldname1)<=value1;
  2101.               end else if (comp1 = '>=') then begin
  2102.                  trouve := GetFloat(fieldname1)>=value1;
  2103.               end else begin
  2104.               end;
  2105.               if not trouve then current := current + sens*1;
  2106.         end;
  2107.         firstseek := False;
  2108.         if not trouve then begin
  2109.            Go(rw);
  2110.            Result := False;
  2111.         end else begin
  2112.            Result := True;
  2113.         end;
  2114.      end;
  2115. end;
  2116.  
  2117. function TMlb2.GetPosition: LongInt;
  2118. begin
  2119.      Result := current + 1;
  2120. end;
  2121.  
  2122. function TMlb2.SortByData(fieldname1: string; lowest2greatest1: boolean): boolean;
  2123. var i, j: LongInt;
  2124.     Item1, Item2: TMlb2_ROW;
  2125. begin
  2126.      if lowest2greatest1 then begin
  2127.         for i:=1 to data.Count do begin
  2128.             for j:=i+1 to data.Count do begin
  2129.                 Item1 := TMlb2_ROW(data.Items[i-1]);
  2130.                 Item2 := TMlb2_ROW(data.Items[j-1]);
  2131.                 if Item1.Strings[fields.IndexOf(fieldname1)]>
  2132.                    Item2.Strings[fields.IndexOf(fieldname1)] then begin
  2133.                    data.Exchange(i-1, j-1);
  2134.                 end;
  2135.             end;
  2136.         end;
  2137.      end else begin
  2138.         for i:=1 to data.Count do begin
  2139.             for j:=i+1 to data.Count do begin
  2140.                 Item1 := TMlb2_ROW(data.Items[i-1]);
  2141.                 Item2 := TMlb2_ROW(data.Items[j-1]);
  2142.                 if Item1.Strings[fields.IndexOf(fieldname1)]<
  2143.                    Item2.Strings[fields.IndexOf(fieldname1)] then begin
  2144.                    data.Exchange(i-1, j-1);
  2145.                 end;
  2146.             end;
  2147.         end;
  2148.      end;
  2149.      Result := True;
  2150. end;
  2151.  
  2152. function TMlb2.SortByFloat(fieldname1: string; lowest2greatest1: boolean): boolean;
  2153. var i, j: LongInt;
  2154.     Item1, Item2: TMlb2_ROW;
  2155. begin
  2156.      if lowest2greatest1 then begin
  2157.         for i:=1 to data.Count do begin
  2158.             for j:=i+1 to data.Count do begin
  2159.                 Item1 := TMlb2_ROW(data.Items[i-1]);
  2160.                 Item2 := TMlb2_ROW(data.Items[j-1]);
  2161.                 if RobustStrToFloat(Item1.Strings[fields.IndexOf(fieldname1)]) >
  2162.                    RobustStrToFloat(Item2.Strings[fields.IndexOf(fieldname1)]) then begin
  2163.                    data.Exchange(i-1, j-1);
  2164.                 end;
  2165.             end;
  2166.         end;
  2167.      end else begin
  2168.         for i:=1 to data.Count do begin
  2169.             for j:=i+1 to data.Count do begin
  2170.                 Item1 := TMlb2_ROW(data.Items[i-1]);
  2171.                 Item2 := TMlb2_ROW(data.Items[j-1]);
  2172.                 if RobustStrToFloat(Item1.Strings[fields.IndexOf(fieldname1)]) <
  2173.                    RobustStrToFloat(Item2.Strings[fields.IndexOf(fieldname1)]) then begin
  2174.                    data.Exchange(i-1, j-1);
  2175.                 end;
  2176.             end;
  2177.         end;
  2178.      end;
  2179.      Result := True;
  2180. end;
  2181.  
  2182. procedure TMlb2.RandomSort;
  2183. var i: integer;
  2184.     v, r, reste: integer;
  2185.     first, l, tmp: PTMlb2IntegerList;
  2186.     first1, l1: PTMlb2IntegerList;
  2187. begin
  2188.      new(first1); l1 := first1;
  2189.      l1^.nextfield := nil;
  2190.      new(first); l := first;
  2191.      for i:=1 to RowCount do begin
  2192.          new(l^.nextfield);
  2193.          l := l^.nextfield;
  2194.          l^.k := i;
  2195.      end;
  2196.      l^.nextfield := nil;
  2197.      reste := RowCount;
  2198.      Randomize;
  2199.      while reste>0 do begin
  2200.            r := Random(reste)+1;
  2201.            l := first;
  2202.            for i:=1 to r-1 do begin
  2203.                l := l^.nextfield;
  2204.            end;
  2205.            l1^.nextfield := l^.nextfield;
  2206.            l1 := l1^.nextfield;
  2207.            l^.nextfield := l1^.nextfield;
  2208.            Dec(reste, 1);
  2209.      end;
  2210.      l1^.nextfield := nil;
  2211.      dispose(first);
  2212.      l := first1;
  2213.      v := 0;
  2214.      while l^.nextfield <> nil do begin
  2215.            l := l^.nextfield;
  2216.            Go(l^.k + v);
  2217.            CopyRow;
  2218.            Go(1);
  2219.            InsertRow(MLB_BEFORE);
  2220.            Go(1);
  2221.            PasteRow;
  2222.            Inc(v, 1);
  2223.      end;
  2224.      for i:=1 to v do begin
  2225.          Go(v+1);
  2226.          RemoveRow;
  2227.      end;
  2228.      l := first1;
  2229.      for i:=1 to RowCount+1 do begin
  2230.          tmp := l^.nextfield;
  2231.          dispose(l);
  2232.          l := tmp;
  2233.      end;
  2234. end;
  2235.  
  2236. function TMlb2.CopyRowBySlot(slot: integer): boolean;
  2237. begin
  2238.      If (Not IsEmpty) and (slot>=1) and (slot<=2) then begin
  2239.         if current>=0 then begin
  2240.            rowcopy[slot].Assign(currentrow);
  2241.            Result := True;
  2242.         end else begin
  2243.            Result := False;
  2244.         end;
  2245.      end else begin
  2246.         Result := False;
  2247.      end;
  2248. end;
  2249.  
  2250. function TMlb2.CopyRow: boolean;
  2251. begin
  2252.      Result := CopyRowBySlot(1);
  2253. end;
  2254.  
  2255. function TMlb2.PasteRowBySlot(slot: integer): boolean;
  2256. begin
  2257.      If (Not IsEmpty) and (slot>=1) and (slot<=2) then begin
  2258.         if current>=0 then begin
  2259.            currentrow.Assign(rowcopy[slot]);
  2260.            Result := True;
  2261.         end else begin
  2262.            Result := False;
  2263.         end;
  2264.      end else begin
  2265.         Result := False;
  2266.      end;
  2267. end;
  2268.  
  2269. function TMlb2.PasteRow: boolean;
  2270. begin
  2271.      Result := PasteRowBySlot(1);
  2272. end;
  2273.  
  2274. function TMlb2.Fusion(var dest_mlb, source_mlb: TMlb2; a1: TMlbFusionArray): boolean;
  2275. var f: string;
  2276.     i, j, k: integer;
  2277.     bexclu: boolean;
  2278.     found, exit_while: boolean;
  2279. begin
  2280.      dest_mlb := TMlb2.Create;
  2281.      psv.Init(a1);
  2282.      psv.CSVSeparator := CSVSeparator;
  2283.      psv.NextField(f);
  2284.      if (f<>'') then begin
  2285.         if f='COMMON' then begin
  2286.            bexclu := true;
  2287.         end else if f='ALL' then begin
  2288.            bexclu := false;
  2289.         end else begin
  2290.            psv.Init(a1);
  2291.            bexclu := true;
  2292.         end;
  2293.         {FIELDS CREATION}
  2294.         k := 0;
  2295.         exit_while := false;
  2296.         while (not exit_while) and ((psv.NextField(f)) or (f<>'')) do begin
  2297.               if f='*' then begin
  2298.                  if bexclu then begin
  2299.                     {ALL COMMON FIELDS MUST BE COPIED}
  2300.                     for i:=1 to FieldCount do begin
  2301.                         j := 1;
  2302.                         found := false;
  2303.                         while (not found) and (j<=source_mlb.FieldCount) do begin
  2304.                               found := FieldName[i]=source_mlb.FieldName[j];
  2305.                               Inc(j, 1);
  2306.                         end;
  2307.                         if found then begin
  2308.                            dest_mlb.AddField(FieldName[i]);
  2309.                            Inc(k, 1);
  2310.                            dest_mlb.DataType[k] := DataType[i];
  2311.                         end else begin
  2312.                         end;
  2313.                     end;
  2314.                  end else begin
  2315.                     {ALL FIELDS OF THE 2 TABLES MUST BE COPIED}
  2316.                     for i:=1 to source_mlb.FieldCount do begin
  2317.                            dest_mlb.AddField(source_mlb.FieldName[i]);
  2318.                            Inc(k, 1);
  2319.                            dest_mlb.DataType[k] := source_mlb.DataType[i];
  2320.                     end;
  2321.                     for i:=1 to FieldCount do begin
  2322.                         if dest_mlb.GetFieldIndex(FieldName[i])<=0 then begin
  2323.                            dest_mlb.AddField(FieldName[i]);
  2324.                            Inc(k, 1);
  2325.                            dest_mlb.DataType[k] := DataType[i];
  2326.                         end else begin
  2327.                         end;
  2328.                     end;
  2329.                  end;
  2330.                  exit_while := true;
  2331.               end else begin
  2332.                  {PARSED FIELDS MUST BE COPIED}
  2333.                  if dest_mlb.GetFieldIndex(f)<=0 then begin
  2334.                     Inc(k, 1);
  2335.                     AddField(f);
  2336.                     i := GetFieldIndex(f);
  2337.                     if i>0 then begin
  2338.                           dest_mlb.DataType[k] := DataType[i];
  2339.                     end else begin
  2340.                           i := source_mlb.GetFieldIndex(f);
  2341.                           if i>0 then begin
  2342.                              dest_mlb.DataType[k] := source_mlb.DataType[i];
  2343.                           end else begin
  2344.                           end;
  2345.                     end;
  2346.                  end else begin
  2347.                  end;
  2348.               end;
  2349.         end;
  2350.         {ROWS CREATION}
  2351.         for i:=1 to RowCount+source_mlb.RowCount do begin
  2352.             dest_mlb.AddRow;
  2353.         end;
  2354.         dest_mlb.GoFirst;
  2355.         for i:=1 to RowCount do begin
  2356.             Go(i);
  2357.             for j:=1 to dest_mlb.FieldCount do begin
  2358.                 dest_mlb.SetData(dest_mlb.FieldName[j], GetData(dest_mlb.FieldName[j]));
  2359.             end;
  2360.             dest_mlb.GoNext;
  2361.         end;
  2362.         for i:=1 to source_mlb.RowCount do begin
  2363.             source_mlb.Go(i);
  2364.             for j:=1 to dest_mlb.FieldCount do begin
  2365.                 dest_mlb.SetData(dest_mlb.FieldName[j], source_mlb.GetData(dest_mlb.FieldName[j]));
  2366.             end;
  2367.             dest_mlb.GoNext;
  2368.         end;
  2369.         Result := true;
  2370.      end else begin
  2371.         Result := false;
  2372.      end;
  2373. end;
  2374.  
  2375. constructor TMlb2ParseCSV.Create;
  2376. begin
  2377.      inherited Create;
  2378.      CSVSeparator := ';';
  2379. end;
  2380.  
  2381. destructor TMlb2ParseCSV.Destroy;
  2382. begin
  2383.      inherited Destroy;
  2384. end;
  2385.  
  2386. procedure TMlb2ParseCSV.Init(s1: string);
  2387. begin
  2388.      index := 1;
  2389.      csvline := s1;
  2390. end;
  2391.  
  2392. function TMlb2ParseCSV.NextField(var field: string): Boolean;
  2393. var read_something: boolean;
  2394.     separation: boolean;
  2395. begin
  2396.      read_something := False;
  2397.      separation := false;
  2398.      field := '';
  2399.      while (index<=length(csvline)) and not separation do begin
  2400.            if (csvline[index]=CSVSeparator) then begin
  2401.               case index of
  2402.                    1: begin
  2403.                       separation := true;
  2404.                    end;
  2405.                    2: begin
  2406.                       separation := csvline[index-1]<>'\';
  2407.                    end;
  2408.                    else begin
  2409.                       separation := (csvline[index-1]<>'\') or ((csvline[index-1]='\') and (csvline[index-2]<>'\'));
  2410.                    end;
  2411.               end;
  2412.            end else begin
  2413.            end;
  2414.            if not separation then begin
  2415.               field := field + csvline[index];
  2416.               read_something := True;
  2417.            end else begin
  2418.            end;
  2419.            Inc(index, 1);
  2420.      end;
  2421. {(csvline[index]<>CSVSeparator)}
  2422. {Inc(index, 1);}
  2423.      Result := read_something or (index<=length(csvline));
  2424. end;
  2425.  
  2426. function TMlb2ParseCSV.FromN(s1: string): string;
  2427. var i: LongInt;
  2428.     token: string;
  2429. begin
  2430.      token := '';
  2431.      i := 1;
  2432.      while i<=length(s1) do begin
  2433.          if s1[i] = '\' then begin
  2434.             if (i<length(s1)) then begin
  2435.                if (s1[i+1] = 'n') then begin
  2436.                   Inc(i, 1);
  2437.                   token := token + #13 + #10;
  2438.                end else if (s1[i+1] = CSVSeparator) then begin
  2439.                   Inc(i, 1);
  2440.                   token := token + CSVSeparator;
  2441.                end else if (s1[i+1] = '\') then begin
  2442.                   Inc(i, 1);
  2443.                   token := token + '\';
  2444.                end else begin
  2445.                   token := token + s1[i];
  2446.                end;
  2447.             end else begin
  2448.                token := token + s1[i];
  2449.             end;
  2450.          end else begin
  2451.              token := token + s1[i];
  2452.          end;
  2453.          Inc(i, 1);
  2454.      end;
  2455.      Result := token;
  2456. end;
  2457.  
  2458. function TMlb2ParseCSV.ToN(s1: string): string;
  2459. var i: LongInt;
  2460.     token: string;
  2461. begin
  2462.      token := '';
  2463.      for i:=1 to length(s1) do begin
  2464.          if ord(s1[i])=13 then begin
  2465.             token := token + '\n';
  2466.          end else if ord(s1[i])=10 then begin
  2467.          end else if s1[i] = '\' then begin
  2468.             token := token + '\\';
  2469.          end else if s1[i] = CSVSeparator then begin
  2470.              token := token + '\' + CSVSeparator;
  2471.          end else begin
  2472.              token := token + s1[i];
  2473.          end;
  2474.      end;
  2475.      Result := token;
  2476. end;
  2477.  
  2478. function TMlb2.InitFieldWithData(fieldname1: string; data1: string): boolean;
  2479. var wr: LongInt;
  2480. begin
  2481.      wr := GetCurrentRow;
  2482.      if GoFirst and (GetFieldIndex(fieldname1)>0) then begin
  2483.         repeat
  2484.               SetData(fieldname1, data1);
  2485.         until not GoNext;
  2486.         Result := True;
  2487.      end else begin
  2488.         Result := False;
  2489.      end;
  2490.      Go(wr);
  2491. end;
  2492.  
  2493. function TMlb2.InitFieldWithValue(fieldname1: string; value1: Extended): boolean;
  2494. var wr: LongInt;
  2495. begin
  2496.      wr := GetCurrentRow;
  2497.      if GoFirst and (GetFieldIndex(fieldname1)>0) then begin
  2498.         repeat
  2499.               SetFloat(fieldname1, value1);
  2500.         until not GoNext;
  2501.         Result := True;
  2502.      end else begin
  2503.         Result := False;
  2504.      end;
  2505.      Go(wr);
  2506. end;
  2507.  
  2508. {---------TKLIST DEBUT IMPLEMENTATION--------}
  2509. constructor TKBaseList.Create;
  2510. begin
  2511.      list := TKList.Create;
  2512.      list.Init(False);
  2513. end;
  2514.  
  2515. destructor TKBaseList.Destroy;
  2516. begin
  2517.      list.Free;
  2518. end;
  2519.  
  2520. function TKBaseList.ReadCount: LongInt;
  2521. begin
  2522.      Result := list.Count;
  2523. end;
  2524.  
  2525. function TKBaseList.ReadItems(index1: LongInt): pointer;
  2526. begin
  2527.      Result := list.GetItem(index1+1);
  2528. end;
  2529.  
  2530. procedure TKBaseList.WriteItems(index1: LongInt; v: pointer);
  2531. begin
  2532.      list.SetItem(index1+1, v);
  2533. end;
  2534.  
  2535. procedure TKBaseList.Clear;
  2536. begin
  2537.      list.Init(False);
  2538. end;
  2539.  
  2540. procedure TKBaseList.Pack;
  2541. begin
  2542. end;
  2543.  
  2544. procedure TKBaseList.Add(p: pointer);
  2545. begin
  2546.      list.Add(p);
  2547. end;
  2548.  
  2549. procedure TKBaseList.Insert(position1: LongInt; p: pointer);
  2550. begin
  2551.      list.Insert(position1+1, p);
  2552. end;
  2553.  
  2554. procedure TKBaseList.Delete(k: LongInt);
  2555. begin
  2556.      list.Remove(k+1);
  2557. end;
  2558.  
  2559. procedure TKBaseList.Exchange(k1, k2: LongInt);
  2560. begin
  2561.      list.Exchange(k1+1, k2+1);
  2562. end;
  2563.  
  2564.  
  2565. constructor TKStringList.Create;
  2566. begin
  2567.      list := TKList.Create;
  2568.      list.Init(False);
  2569. end;
  2570.  
  2571. destructor TKStringList.Destroy;
  2572. begin
  2573.      list.Free;
  2574. end;
  2575.  
  2576. function TKStringList.ReadCount: LongInt;
  2577. begin
  2578.      Result := list.Count;
  2579. end;
  2580.  
  2581. function TKStringList.ReadStrings(index1: LongInt): string;
  2582. begin
  2583.      Result := list.GetString(index1+1);
  2584. end;
  2585.  
  2586. procedure TKStringList.WriteStrings(index1: LongInt; v: string);
  2587. begin
  2588.      list.SetString(index1+1, v);
  2589. end;
  2590.  
  2591. procedure TKStringList.Clear;
  2592. begin
  2593.      list.Init(False);
  2594. end;
  2595.  
  2596. function TKStringList.IndexOf(s: string): LongInt;
  2597. var k: integer;
  2598. begin
  2599.      Result := list.IndexOfString(s)-1;
  2600. end;
  2601.  
  2602. procedure TKStringList.Add(s: string);
  2603. begin
  2604.      list.AddString(s);
  2605. end;
  2606.  
  2607. function TKStringList.Delete(k: LongInt): boolean;
  2608. begin
  2609.      Result := list.Remove(k+1)<>nil;
  2610. end;
  2611.  
  2612. procedure TKStringList.Assign(tk: TKStringList);
  2613. var i: integer;
  2614. begin
  2615.      for i:=0 to Count-1 do begin
  2616.          Strings[i] := tk.Strings[i];
  2617.      end;
  2618. end;
  2619.  
  2620.  
  2621. function TKList.best_pointer(k: LongInt): LongInt;
  2622. begin
  2623.      if (k>0) and (k<=n) then begin
  2624.         if abs(k-1)<abs(k-index) then begin
  2625.            if abs(k-n)<abs(k-1) then begin
  2626.               {LAST est le meilleur}
  2627.               Result := 3;
  2628.            end else begin
  2629.               {FIRST est le meilleur}
  2630.               Result := 1;
  2631.            end;
  2632.         end else begin
  2633.            if abs(k-n)<abs(k-index) then begin
  2634.               {LAST est le meilleur}
  2635.               Result := 3;
  2636.            end else begin
  2637.               {CURRENT est le meilleur}
  2638.               Result := 2;
  2639.            end;
  2640.         end;
  2641.      end else begin
  2642.         Result := 0;
  2643.      end;
  2644. end;
  2645.  
  2646. constructor TKList.Create;
  2647. begin
  2648.      inherited Create;
  2649.      new(first);
  2650.      first^.Next := nil;
  2651.      first^.item := nil;
  2652.      first^.Prev := nil;
  2653.      current := first;
  2654.      last := first;
  2655.  
  2656.      index := 0;
  2657.      n := 0;
  2658. end;
  2659.  
  2660. destructor TKList.Destroy;
  2661. begin
  2662.      Delete(false);
  2663.      inherited Destroy;
  2664. end;
  2665.  
  2666. procedure TKList.Purge;
  2667. begin
  2668.      Delete(true);
  2669. end;
  2670.  
  2671. function TKList.GetIndex: LongInt;
  2672. begin
  2673.      Result := index;
  2674. end;
  2675.  
  2676. function TKList.Count: LongInt;
  2677. begin
  2678.      Result := n;
  2679. end;
  2680.  
  2681. procedure TKList.AddString(s: string);
  2682. var mystring: PString;
  2683. begin
  2684.      new(mystring);
  2685.      mystring^ := s;
  2686.      Add(mystring);
  2687. end;
  2688.  
  2689. function TKList.InsertString(k: LongInt; s: string): boolean;
  2690. var mystring: PString;
  2691. begin
  2692.      new(mystring);
  2693.      mystring^ := s;
  2694.      Insert(k, mystring);
  2695. end;
  2696.  
  2697. function TKList.GetString(k: LongInt): string;
  2698. var p: pointer;
  2699. begin
  2700.      p := GetItem(k);
  2701.      if p=nil then begin
  2702.         Result := '';
  2703.      end else begin
  2704.         Result := String(p^);
  2705.      end;
  2706. end;
  2707.  
  2708. function TKList.SetString(k: LongInt; s: string): boolean;
  2709. var p: pointer;
  2710.     mystring: PString;
  2711. begin
  2712.      p := GetItem(k);
  2713.      if p=nil then begin
  2714.      end else begin
  2715.         dispose(p);
  2716.      end;
  2717.      if (k>0) and (k<=n) then begin
  2718.         new(mystring);
  2719.         mystring^ := s;
  2720.         SetItem(k, mystring);
  2721.         Result := True;
  2722.      end else begin
  2723.         Result := False;
  2724.      end;
  2725. end;
  2726.  
  2727. function TKList.IndexOfString(s: string): LongInt;
  2728. var i: LongInt;
  2729.     trouve: boolean;
  2730. begin
  2731.      trouve := False;
  2732.      i:=1;
  2733.      while (not trouve) and (i<=Count) do begin
  2734.            trouve := s=GetString(i);
  2735.            Inc(i, 1);
  2736.      end;
  2737.      if trouve then begin
  2738.         Result := i-1;
  2739.      end else begin
  2740.         Result := 0;
  2741.      end;
  2742. end;
  2743.  
  2744. procedure TKList.Add(item: pointer);
  2745. begin
  2746.      new(last^.Next);
  2747.      Inc(n, 1);
  2748.      last^.Next^.Prev := last;
  2749.      last := last^.Next;
  2750.      last^.item := item;
  2751.      last^.Next := nil;
  2752.      if index<=0 then GoLast;
  2753. end;
  2754.  
  2755. function TKList.Insert(k: LongInt; item: pointer): boolean;
  2756. var i, necessary: LongInt;
  2757.     tmp: PListItem;
  2758. begin
  2759.      if Go(k) then begin
  2760.         new(tmp);
  2761.         tmp^.Next := current;
  2762.         tmp^.Prev := current^.Prev;
  2763.         tmp^.item := item;
  2764.         current^.Prev^.Next := tmp;
  2765.         current^.Prev := tmp;
  2766.         current := tmp;
  2767.         Inc(n, 1);
  2768.         Result := True;
  2769.      end else begin
  2770.         necessary := k-n;
  2771.         if necessary>0 then begin
  2772.            for i:=1 to necessary-1 do begin
  2773.                Add(nil);
  2774.            end;
  2775.            Add(item);
  2776.            Result := True;
  2777.         end else begin
  2778.            Result := False;
  2779.         end;
  2780.      end;
  2781. end;
  2782.  
  2783. function TKList.Remove(k: LongInt): pointer;
  2784. var tmp: PListItem;
  2785. begin
  2786.      if Go(k) then begin
  2787.         Dec(index, 1); Dec(n, 1);
  2788.         tmp := current;
  2789.         current^.Prev^.Next := current^.Next;
  2790.         if current^.Next=nil then begin
  2791.             last := current^.Prev;
  2792.         end else begin
  2793.             current^.Next^.Prev := current^.Prev;
  2794.         end;
  2795.         current := current^.Prev;
  2796.         Result := tmp^.item;
  2797.         dispose(tmp);
  2798.      end else begin
  2799.         Result := nil;
  2800.      end;
  2801. end;
  2802.  
  2803. function TKList.Delete(ditems: boolean): boolean;
  2804. begin
  2805.      Init(ditems);
  2806.      dispose(first);
  2807. end;
  2808.  
  2809. function TKList.Init(ditems: boolean): boolean;
  2810. var tmp: PListItem;
  2811.     i: LongInt;
  2812. begin
  2813.      Result := Empty;
  2814.      current := first^.Next;
  2815.      for i:=1 to n do begin
  2816.          tmp := current;
  2817.          current := current^.Next;
  2818.          if ditems then dispose(tmp^.item);
  2819.          dispose(tmp);
  2820.      end;
  2821.      current := first; last := first; index := 0; n := 0;
  2822. end;
  2823.  
  2824. function TKList.GetItem(k: LongInt): pointer;
  2825. begin
  2826.      if Go(k) then begin
  2827.          Result := current^.item;
  2828.      end else begin
  2829.          Result := nil;
  2830.      end;
  2831. end;
  2832.  
  2833. function TKList.SetItem(k: LongInt; p: pointer): pointer;
  2834. begin
  2835.      if Go(k) then begin
  2836.          Result := current^.item;
  2837.          current^.item := p;
  2838.      end else begin
  2839.          Result := nil;
  2840.      end;
  2841. end;
  2842.  
  2843. function TKList.Exchange(k1, k2: LongInt): boolean;
  2844. var p: pointer;
  2845. begin
  2846.      if (k1>0) and (k1<=Count) and (k2>0) and (k2<=Count) then begin
  2847.         {prendre l'item de k2 dans un pointeur}
  2848.         p := GetItem(k2);
  2849.         {copier l'item de k1 dans k2}
  2850.         SetItem(k2, GetItem(k1));
  2851.         {copier le pointeur dans k1}
  2852.         SetItem(k1, p);
  2853.         Result := True;
  2854.      end else begin
  2855.         Result := False;
  2856.      end;
  2857. end;
  2858.  
  2859. function TKList.Empty: boolean;
  2860. begin
  2861.      Result := first=last;
  2862. end;
  2863.  
  2864. function TKList.Go(k: LongInt): boolean;
  2865. var i: LongInt;
  2866. begin
  2867.      Result := true;
  2868.      case best_pointer(k) of
  2869.           0: begin
  2870.              Result := false;
  2871.           end;
  2872.           1: begin
  2873.              current := first; index := 0;
  2874.              for i:=1 to k do begin
  2875.                  current := current^.Next;
  2876.              end; index := k;
  2877.           end;
  2878.           2: begin
  2879.              if k-index>0 then begin
  2880.                 for i:=index to k-1 do begin
  2881.                     current := current^.Next;
  2882.                 end; index := k;
  2883.              end else begin
  2884.                 for i:=1 to index-k do begin
  2885.                     current := current^.Prev;
  2886.                 end; index := k;
  2887.              end;
  2888.           end;
  2889.           3: begin
  2890.              current := last; index := n;
  2891.              for i:=1 to n-k do begin
  2892.                  current := current^.Prev;
  2893.              end; index := k;
  2894.           end;
  2895.      end;
  2896. end;
  2897.  
  2898. function TKList.GoFirst: boolean;
  2899. begin
  2900.      if Empty then begin
  2901.          index := 0;
  2902.          n := 0;
  2903.          current := first;
  2904.      end else begin
  2905.          index := 1;
  2906.          current := first^.Next;
  2907.      end;
  2908.      Result := index>0;
  2909. end;
  2910.  
  2911. function TKList.GoLast: boolean;
  2912. begin
  2913.      if Empty then begin
  2914.          index := 0;
  2915.          n := 0;
  2916.          current := first;
  2917.      end else begin
  2918.          index := n;
  2919.          current := last;
  2920.      end;
  2921.      Result := index>0;
  2922. end;
  2923.  
  2924. function TKList.GoNext: boolean;
  2925. begin
  2926.      if index<n then begin
  2927.         Inc(index, 1);
  2928.         current := current^.Next;
  2929.         Result := true;
  2930.      end else begin
  2931.         Result := false;
  2932.      end;
  2933. end;
  2934.  
  2935. function TKList.GoPrevious: boolean;
  2936. begin
  2937.      if index>1 then begin
  2938.         Dec(index, 1);
  2939.         current := current^.Prev;
  2940.         Result := true;
  2941.      end else begin
  2942.         Result := false;
  2943.      end;
  2944. end;
  2945. {---------TKLIST FIN IMPLEMENTATION--------}
  2946.  
  2947. {---------EXCEL DEBUT IMPLEMENTATION--------}
  2948. Constructor TBaseSave.Init;
  2949. begin
  2950.   MinSaveRecs := 0; MaxSaveRecs := 100;
  2951.   MinSaveCols := 0; MaxSaveCols := 100;
  2952.   EndOfLine := false;
  2953. end;
  2954.  
  2955. Procedure TBaseSave.WriteBlank;
  2956. begin
  2957.   write( CharFile, separator );
  2958. end;
  2959.  
  2960. Procedure TBaseSave.WriteLongInt;
  2961. var ALongIntP : ^LongInt; ALongInt : LongInt;
  2962. begin
  2963.   ALongIntP := DataPointer; ALongInt := ALongIntP^;
  2964.   str(ALongInt, DataString );
  2965. end;
  2966.  
  2967. Procedure TBaseSave.WriteDouble;
  2968. var ADoubleP : ^double; ADouble : double;
  2969. begin
  2970.   ADoubleP := DataPointer; ADouble := ADoubleP^;
  2971.   str(ADouble, DataString );
  2972. end;
  2973.  
  2974. Procedure TBaseSave.WriteLabel;
  2975. var ALabelP : ^CharType; ALabel : CharType;
  2976. begin
  2977.   ALabelP := DataPointer; ALabel := ALabelP^;
  2978.   DataString  := String( ALabel );
  2979.   w := length(DataString); {unused by calling method}
  2980. end;
  2981.  
  2982. Procedure TBaseSave.WriteData;
  2983. var i : LongInt; AWordLength : word;
  2984. begin
  2985.   CellType := AType;
  2986.   if Row <> -1 then if Row <> ARow then EndOfLine := true else EndOfLine := false;
  2987.   Row := ARow;
  2988.   Col := ACol;
  2989.   DataPointer := AData;
  2990.  
  2991.   case CellType of
  2992.     CellBlank   : WriteBlank;
  2993.     CellLongInt : WriteLongInt;
  2994.     CellDouble  : WriteDouble;
  2995.     CellLabel   : WriteLabel(AWordLength);
  2996.     CellBoolean : exit; {No boolean types in text files}
  2997.     else exit;
  2998.   end;
  2999.   
  3000.   if EndOfLine then begin write ( CharFile, TMlb2_CR ); write ( CharFile, TMlb2_LF ) end;
  3001.   for i := 1 to length(DataString) do write( CharFile, DataString[i] );
  3002.   write( CharFile, separator );
  3003.   
  3004. end;
  3005.  
  3006. Destructor TBaseSave.Done;
  3007. begin
  3008. end;
  3009.  
  3010. {ASCII files object}
  3011.  
  3012. Constructor TASCII.Init;
  3013. begin
  3014.   TBaseSave.Init( SaveFileName );
  3015.   Separator := TMlb2_Space;
  3016.   assign( CharFile, SaveFileName );
  3017.   Row := -1; col := -1;
  3018.   rewrite ( CharFile );
  3019. end;
  3020.  
  3021. Destructor TASCII.Done;
  3022. begin
  3023.   TBaseSave.Done; close( CharFile );
  3024. end;
  3025.  
  3026. {Excel tab-delimited files object}
  3027.  
  3028. Constructor TExcelTab.Init;
  3029. begin
  3030.   TBaseSave.Init( SaveFileName );
  3031.   Separator := TMlb2_tab;
  3032.   assign( CharFile, SaveFileName );
  3033.   Row := -1; col := -1;
  3034.   rewrite ( CharFile ); 
  3035. end;
  3036.  
  3037. Destructor TExcelTab.Done;
  3038. begin
  3039.   TBaseSave.Done; close( CharFile );
  3040. end;
  3041.  
  3042. {Excel BIFF2 object}
  3043.  
  3044. Constructor TBIFF2.Init;
  3045. begin
  3046.   TBaseSave.Init( AFileName );
  3047.   Assign( ExcelFile, AFileName); Rewrite( ExcelFile, 1 );
  3048.   WriteBOF;
  3049.   WriteDimensions;
  3050. end;
  3051.  
  3052. Destructor TBIFF2.Done;
  3053. begin
  3054.   TBaseSave.Done;
  3055.   WriteEOF;
  3056.   Close (ExcelFile);
  3057. end; 
  3058.  
  3059. procedure TBIFF2.BIFFBOF;
  3060. begin
  3061.   typerec := TMlb2_BOF;
  3062.   lendata := 4;
  3063. end;
  3064.  
  3065. procedure TBIFF2.BIFFDIM;
  3066. begin
  3067.   typerec := DIMENSIONS;
  3068.   lendata := 8;
  3069. end;
  3070.  
  3071. procedure TBIFF2.WriteBOF;
  3072. var awBuf : array[0..2] of word;
  3073. begin
  3074.   awBuf[0] := 0;
  3075.   awBuf[1] := DOCTYPE_XLS;
  3076.   awBuf[2] := 0;
  3077.   BIFFBOF;
  3078.   WriteRecordHeader; 
  3079.   Blockwrite(Excelfile, awbuf, lendata);
  3080. end;
  3081.  
  3082. procedure TBIFF2.WriteRecordHeader;
  3083. var awBuf : array[0..1] of word;
  3084. begin
  3085.   awBuf[0] := typerec;
  3086.   awBuf[1] := lendata;
  3087.   Blockwrite(Excelfile, awbuf, LEN_RECORDHEADER);
  3088. end;
  3089.  
  3090. procedure TBIFF2.WriteDimensions;
  3091. var awBuf : array[0..4] of word;
  3092. begin
  3093.   awBuf[0] := MinSaveRecs;
  3094.   awBuf[1] := MaxSaveRecs;
  3095.   awBuf[2] := MinSaveCols;
  3096.   awBuf[3] := MaxSaveCols;
  3097.   awBuf[4] := 0;
  3098.   BIFFDIM;
  3099.   WriteRecordHeader;
  3100.   Blockwrite(Excelfile, awbuf, lendata);
  3101. end;
  3102.  
  3103. procedure TBIFF2.WriteEOF;
  3104. begin
  3105.   typerec := BIFF_EOF;
  3106.   lendata := 0;
  3107.   WriteRecordHeader;
  3108. end;
  3109.  
  3110. Procedure TBIFF2.WriteBlank;
  3111. begin
  3112.   typerec := 1;
  3113.   lendata := 7;
  3114.   WriteRecordHeader;
  3115.   lendata := 0;
  3116. end;
  3117.  
  3118. Procedure TBIFF2.WriteLongInt;
  3119. begin
  3120.   typerec := 2;
  3121.   lendata := 9;
  3122.   WriteRecordHeader;
  3123.   lendata := 2;
  3124. end;
  3125.  
  3126. Procedure TBIFF2.WriteDouble;
  3127. begin
  3128.   typerec := 3;
  3129.   lendata := 15;
  3130.   WriteRecordHeader;
  3131.   lendata := 8;
  3132. end;
  3133.  
  3134. Procedure TBIFF2.WriteLabel(var w : word);
  3135. var p: PChar;
  3136. begin
  3137.   p := PChar(DataPointer);
  3138.   w := length(StrPas(p));
  3139.   typerec := 4;
  3140.   lendata := 8+w;
  3141.   WriteRecordHeader;
  3142.   lendata := w;
  3143. end;
  3144.  
  3145. Procedure TBIFF2.WriteBoolean;
  3146. begin
  3147.   typerec := 5;
  3148.   lendata := 9;
  3149.   WriteRecordHeader;
  3150.   lendata := 0;
  3151. end;
  3152.  
  3153. Procedure TBIFF2.WriteData;
  3154. const
  3155.   Attribute: Array[0..2] Of Byte = (0, 0, 0); { 24 bit bitfield }
  3156. var
  3157.   awBuf : array[0..1] of word;
  3158.   AWordLength : word; ABoolByte : byte;
  3159. begin
  3160.   CellType := AType;
  3161.   Row := ARow;
  3162.   Col := ACol;
  3163.   DataPointer := AData;
  3164.  
  3165.   case CellType of
  3166.     CellBlank   : WriteBlank;
  3167.     CellLongInt : WriteLongInt;
  3168.     CellDouble  : WriteDouble;
  3169.     CellLabel   : WriteLabel(AWordLength);
  3170.     CellBoolean : WriteBoolean; { or error }
  3171.     else exit;
  3172.   end;
  3173.   awBuf[0] := Row;
  3174.   awBuf[1] := Col;
  3175.   Blockwrite(Excelfile, awbuf, sizeof(awBuf));
  3176.   BlockWrite(Excelfile, Attribute, SizeOf(Attribute));
  3177.   
  3178.   if CellType = CellLabel then begin
  3179.     ABoolByte := AWordLength;
  3180.     BlockWrite(Excelfile, ABoolByte, SizeOf(ABoolByte))
  3181.   end else if CellType = CellBoolean then begin
  3182.     if byte(DataPointer^) <> 0 then ABoolByte := 1 else ABoolByte := 0;
  3183.     BlockWrite(Excelfile, ABoolByte, SizeOf(ABoolByte));
  3184.     ABoolByte := 0;
  3185.     BlockWrite(Excelfile, ABoolByte, SizeOf(ABoolByte));
  3186.   end;
  3187.   if lendata <> 0 then BlockWrite(Excelfile, DataPointer^, lendata);
  3188. end;
  3189.  
  3190. {Excel BIFF3 object}
  3191.  
  3192. procedure TBIFF3.BIFFBOF;
  3193. begin
  3194.   typerec := BOF_BIFF3;
  3195.   lendata := 6;
  3196. end;
  3197.  
  3198. procedure TBIFF3.BIFFDIM;
  3199. begin
  3200.   typerec := DIMENSIONS_BIFF3;
  3201.   lendata := 10;
  3202. end;
  3203.  
  3204. {Excel BIFF4 object}
  3205.  
  3206. procedure TBIFF4.BIFFBOF;
  3207. begin
  3208.   typerec := BOF_BIFF4;
  3209.   lendata := 6;
  3210. end;
  3211.  
  3212. {Excel BIFF5 object}
  3213.  
  3214. procedure TBIFF5.BIFFBOF;
  3215. begin
  3216.   typerec := BOF_BIFF5;
  3217.   lendata := 6;
  3218. end;
  3219.  
  3220. function TMlb2.SaveToExcelFile(FileName1: string): boolean;
  3221. var i, j: LongInt;
  3222.     ALabel: PChar;
  3223.     Q: PChar;
  3224.     k: string;
  3225. begin
  3226.   PSavefile := New(PBIFF5,Init(FileName1));
  3227.   with PSaveFile^ do begin
  3228.     for i := 1 to fields.Count do begin
  3229.           ALabel := AllocMem(length(fields.Strings[i-1]) + 1);
  3230.           k := fields.Strings[i-1] + #0;
  3231.           Q := @(k[1]);
  3232.           StrCopy(PChar(ALabel), PChar(Q));
  3233.           PSaveFile^.WriteData(CellLabel, 0, i-1, ALabel);
  3234.           FreeMem(ALabel, length(fields.Strings[i-1]) + 1);
  3235.     end;
  3236.     for i := 1 to fields.Count do begin
  3237.       for j := 1 to data.Count do begin
  3238.           ALabel := AllocMem(length(TMlb2_ROW(data.Items[j-1]).Strings[i-1]) + 1);
  3239.           k := TMlb2_ROW(data.Items[j-1]).Strings[i-1] + #0;
  3240.           Q := @(k[1]);
  3241.           StrCopy(PChar(ALabel), PChar(Q));
  3242.           PSaveFile^.WriteData(CellLabel, j, i-1, ALabel);
  3243.           FreeMem(ALabel, length(TMlb2_ROW(data.Items[j-1]).Strings[i-1]) + 1);
  3244.       end;
  3245.     end;
  3246.   end;
  3247.   dispose(PSaveFile,done);
  3248.   Result := True;
  3249. end;
  3250. {------EXCEL FIN IMPLEMENTATION------}
  3251.  
  3252. end.
  3253.  
  3254.