Quellcodebibliothek Statistik Leitseite products/Sources/formale Sprachen/Delphi/Bille 0.71/__history/   (Columbo Version 0.7©)  Datei vom 16.0.2013 mit Größe 63 kB image not shown  

Bilddatei

Matching.pas.~570~


products/Sources/formale Sprachen/Delphi/Bille 0.71/__history/Matching.pas.~570~

unit Matching; interface //------------------------------------------------------- // //------------------------------------------------------- uses Dialogs, ExtCtrls, Grids, ValEdit, Menus, Options, ComCtrls, SysUtils, StrUtils, Classes, Math, Forms, Controls, //OleAuto, //------------------------------------------------------- // //------------------------------------------------------- Utilities, Language; //------------------------------------------------------- // //------------------------------------------------------- type PMatch = ^TMatch; TMatch = record valid: boolean; manuell:boolean; leftline: integer; rightline: integer; leftcol: integer; rightcol: integer; MatchString: String; end; //------------------------------------------------------- // //------------------------------------------------------- function ListRec(LV: TListView; ix: integer; left: boolean): String; function importfile(lr: integer; Name: String; VL: TListView; first: boolean): boolean; procedure setmatchbounds(RSI, FSI, FDI, ECI: String); function hasmatch(Left, Right: TListItem): PMatch; function exportfile(Name: String; VL1, VL2: TListView; Regex1, Regex2: String; ron: boolean): integer; procedure getmatchingColumns(); procedure setPivotOnly(); function isinMatches(l, r: integer): integer; function finditem(LV: tlistview; inx: integer): integer; //----------------------------------------------------------- //printable form of e.g. tab is #09 //----------------------------------------------------------- var FSB, //field separator binary RSB, //record separator binary FDB, //field delimiter binary ECB: //escape character binary String; lfs, lrs, lfd, lec: //length of ... integer; numberrecords: array [1 .. 2] of integer; maxfieldsperrecord: array [1 .. 2] of integer; leftwidths, rightwidths: array of integer; Pivot: array [1 .. 2] of array of integer; Matches: array of PMatch; Mostleft, Mostright, RecPos: integer; ActMatch: PMatch; Exportcancel: Cardinal; //------------------------------------------------------- // //------------------------------------------------------- implementation var MF: array [1 .. 2] of TextFile; Filenames: array [1 .. 2] of String; inx: 1 .. 2; //------------------------------------------------------- // //------------------------------------------------------- function endfile(): boolean; begin result := EOF(MF[inx]) end; //------------------------------------------------------- // //------------------------------------------------------- function stripof(S: String): String; var ll: integer; R: String; begin ll := length(S); R := S; if S > '' then begin if MidStr(S, 1, lfd) = FDB then begin if MidStr(S, ll - lfs + 1, lfs) = FSB then R := MidStr(S, 1 + lfd, length(S) - lfs - 2 * lfd) else R := MidStr(S, 1 + lfd, length(S) - 2 * lfd) end else if MidStr(S, ll - lfs + 1, lfs) = FSB then R := MidStr(S, 1, length(S) - lfs) end; result := R end; //------------------------------------------------------------------ // //------------------------------------------------------------------ function finditem(LV: tlistview; inx: integer): integer; var i, res, zwi: integer; begin res := inx; i := 0; while (i < LV.Items.Count) do begin zwi := StrToInt(LV.Items[i].Caption); if zwi = inx then begin res := i; i := lv.Items.Count end; Inc(i) end; result := res end; //------------------------------------------------------- // //------------------------------------------------------- procedure setmatchbounds(RSI, FSI, FDI, ECI: String); begin FSB := Hex2String(FSI); RSB := Hex2String(RSI); FDB := Hex2String(FDI); ECB := Hex2String(ECI); lfs := length(FSB); lrs := length(RSB); lfd := length(FDB); lec := length(ECB); end; //------------------------------------------------------- // //------------------------------------------------------- function getfield(Rec: String): String; var k, i, ll: integer; isinfield: boolean; ch: char; Field: String; //-------------------------------------------- procedure next(); begin i := i + 1; if i <= ll then begin ch := Rec[i]; Field := Field + Ch end else ch := chr(0); end; //-------------------------------------------- procedure skip(); begin while (i < ll) and (Rec[i] = ' ') do Inc(i); end; begin ll := length(Rec); Field := ''; isinfield := false; i := RecPos; while (i < ll) and (Rec[i + 1] = ' ') do i := i + 1; next(); if (FSB > '') and (ch = FSB[1]) then begin for k := 2 to lfs - 1 do next(); skip(); ch := chr(0); end; while (ch <> chr(0)) and (i <= ll) do begin if (ECB > '') and (ch = ECB[1]) then begin for k := 2 to lec - 1 do next(); end else if isinfield then begin if (ch = FDB[1]) then begin isinfield := false; next(); if ch <> FDB[1] then ch := chr(0); end end else if (FDB > '') and (ch = FDB[1]) then begin if lfd + i <= ll then begin isinfield := true; for k := i + 1 to i + lfd - 1 do isinfield := isinfield and (FDB[k - i + 1] = Rec[k]); end; end; if ch <> chr(0) then begin next(); if not isinfield and (FSB > '') and (ch = FSB[1]) then begin for k := 2 to lfs - 1 do next(); skip(); ch := chr(0); end end end; Recpos := i; result := Field; end; //------------------------------------------------------- // //------------------------------------------------------- function getrecord(RS: String): String; var k: integer; itis: boolean; ch: char; Rec: String; //-------------------------------------------- procedure next(); begin if endfile() then ch := chr(0) else read(MF[inx], ch); end; begin Rec := ''; itis := false; while not itis and not endfile() do begin next(); if (RSB > '') and (ch = RSB[1]) then begin itis := true; for k := 2 to length(RSB) do begin if not endfile() then next() else ch := chr(0); itis := itis and (RSB[k] = Ch); end; end else Rec := Rec + ch; end; result := Rec end; //------------------------------------------------------- // //------------------------------------------------------- {$I similarity.inc} //------------------------------------------------------- // //------------------------------------------------------- function ListRec(LV: TListView; ix: integer; left: boolean): String; var i, ll, Nums: integer; F, Sep: String; begin Nums := strtoint(LV.Items[ix].Caption); F := LV.Items[ix].Caption + ': '; for i := 0 to LV.Items[ix].SubItems.Count - 1 do begin F := F + Sep + LV.Items[ix].SubItems[i]; Sep := ';' end; ll := length(Matches); i := 0; while (i < ll) do begin if Matches[i].valid then begin if left and (nums = matches[i].leftline) then begin F := F + ' * ' + trans(54, 'Paar ') + '<' + inttostr(matches[i].leftline) + ',' + inttostr(matches[i].rightline) + '> ' + trans(64, 'mit') + ' ''' + matches[i].MatchString + ' '''; i := ll end else if not left and (nums = matches[i].rightline) then begin F := F + ' * ' + trans(54, 'Paar ') + '<' + inttostr(matches[i].leftline) + ',' + inttostr(matches[i].rightline) + '> ' + trans(64, 'mit') + ' ''' + matches[i].MatchString + ' '''; i := ll end; end; Inc(i) end; result := F end; //------------------------------------------------------- // //------------------------------------------------------- procedure setPivotOnly(); var le, ri, i: integer; begin for i := 0 to length(Matches) - 1 do begin le := Matches[i].leftcol; ri := Matches[i].rightcol; if (le <> Mostleft) or (ri <> Mostright) then Matches[i].valid := false; end; end; //------------------------------------------------------- // //------------------------------------------------------- procedure getmatchingColumns(); var i, m1, m2, ll, lc, rc, c1, c2: integer; begin m1 := 0; m2 := 0; c1 := 0; c2 := 0; ll := Length(Matches); for i := 0 to ll - 1 do begin if Matches[i].valid then begin lc := Matches[i].leftcol; rc := Matches[i].rightcol; if Pivot[1][lc] > m1 then begin c1 := lc; m1 := Pivot[1][lc] end; if Pivot[2][rc] > m2 then begin c2 := rc; m2 := Pivot[2][lc] end; end; end; Mostleft := c1; Mostright := c2 end; //------------------------------------------------------- // //------------------------------------------------------- function isinMatches(l, r: integer): integer; var i, ll: integer; res: integer; begin res := -1; i := 0; ll := length(Matches); while (res < 0) and (i < ll) do begin if l = Matches[i].leftline then begin res := i; ActMatch := Matches[i] end; if r = Matches[i].rightline then begin res := i; ActMatch := Matches[i] end; i := i + 1; end; result := res end; //------------------------------------------------------- // //------------------------------------------------------- function hasmatch(Left, Right: TListItem): PMatch; var i, j, ll1, ll2, bound: integer; M1, M2: String; aMatch: PMatch; begin aMatch := nil; ll1 := Left.SubItems.count; ll2 := Right.SubItems.count; bound := min(ll1, ll2); i := 1; while (aMatch = nil) and (i < bound) do begin M1 := Left.subitems[i]; j := 1; while (aMatch = nil) and (j < bound) do begin M2 := Right.subitems[j]; if issimilar(M1, M2) then begin aMatch := new(PMatch); aMatch.valid := true; aMatch.manuell:=false; aMatch.MatchString := M1; aMatch.leftline := StrToInt(Left.Caption); aMatch.rightline := StrToInt(Right.Caption); aMatch.leftcol := i; aMatch.rightcol := j; Inc(Pivot[1][i]); Inc(Pivot[2][j]); end; Inc(j); end; Inc(i) end; result := aMatch end; //------------------------------------------------------- //NYI //------------------------------------------------------- procedure importexcelfile(Name: String; VL: TListView; first: boolean); //var //Excel, XLSheet: Variant; //Rows, Cols: integer; begin //Excel := CreateOleObject('Excel.Application'); //Excel.visible := false; //Excel.WorkBooks.Open(Name); //XLSheet := Excel.Worksheets[1]; //Cols := XLSheet.UsedRange.Columsn.count; //Rows := XLSheet.UsedRange.Columsn.count; end; //------------------------------------------------------- //NYI //------------------------------------------------------- procedure importofficefile(Name: String; VL: TListView; first: boolean); //var //Office, OOSheet: Variant; //Rows, Cols: integer; begin //Office := CreateOleObject('com.sun.star.ServiceManager'); //Office.visible := false; //Office.WorkBooks.Open(Name); //OOSheet := Office.Worksheets[1]; //Cols := OOSheet.UsedRange.Columsn.count; //Rows := OOSheet.UsedRange.Columsn.count; end; //------------------------------------------------------- //NYI //------------------------------------------------------- procedure importxmlfile(Name: String; VL: TListView; first: boolean); //var //Office, OOSheet: Variant; //Rows, Cols: integer; begin //Office := CreateOleObject('com.sun.star.ServiceManager'); //Office.visible := false; //Office.WorkBooks.Open(Name); //OOSheet := Office.Worksheets[1]; //Cols := OOSheet.UsedRange.Columsn.count; //Rows := OOSheet.UsedRange.Columsn.count; end; //------------------------------------------------------- // //------------------------------------------------------- function importcsvfile(Name: String; VL: TListView; first: boolean): boolean; var i, j: integer; open: boolean; Rec, Field, This: String; LI: TListItem; begin if FileExists(Name) then begin AssignFile(MF[inx], Name); try Reset(MF[inx]); open := true except open := false; end; if open then begin VL.Clear; VL.Items.Clear; VL.Columns.Add(); VL.Columns[0].Caption := '#'; //set headers //-------------------------------------------- //now get records //-------------------------------------------- maxfieldsperrecord[inx] := 0; i := -1; while not endfile() do begin Rec := getrecord(RSB); Inc(i); LI := nil; VL.Hint := ''; RecPos := 0; j := 0; field := getfield(Rec); while Field <> '' do begin Inc(j); if j > maxfieldsperrecord[inx] then begin VL.Columns.Add(); Inc(maxfieldsperrecord[inx]); end; This := stripof(Field); if (i = 0) then begin if first then VL.Columns[j].Caption := This else VL.Columns[j].Caption := inttostr(j); end; if not first or (i <> 0) then begin if LI = nil then begin LI := VL.Items.Add(); LI.Caption := inttostr(i); end; LI.SubItems.Add(This); end; VL.Hint := VL.Hint + This; field := getfield(Rec); end; end; end; closefile(MF[inx]); VL.Columns[0].Width := vl.Width div (maxfieldsperrecord[inx] + 1); for j := 1 to maxfieldsperrecord[inx] - 1 do VL.Columns[j].Width := vl.Width div (maxfieldsperrecord[inx] + 1); setlength(Pivot[inx], maxfieldsperrecord[inx] + 1); for i := 1 to length(Pivot[inx]) do Pivot[inx][i] := 0; result := true; end else begin result := ask(47, 'Kann die Datei nicht lesen', ' ', [mbOK, mbCancel]) = mrCancel; end; end; //------------------------------------------------------- // //------------------------------------------------------- function importfile(lr: integer; Name: String; VL: TListView; first: boolean): boolean; var ext: String; begin screen.Cursor := crHourGlass; result := true; inx := lr; Filenames[inx] := Name; ext := ExtractFileExt(Name); if Ext = '.xls' then errorn(37, 'Filter für Excel noch nicht implementiert') else if Ext = '.ods' then errorn(37, 'Filter für OpenOffice noch nicht implementiert') else result := importcsvfile(Name, VL, first); Screen.Cursor := crDefault; end; //------------------------------------------------------- // //------------------------------------------------------- function exportfile(Name: String; VL1, VL2: TListView; Regex1, Regex2: String; ron: boolean): integer; var cc1, cc2, su1, su2, i, j, numrec: integer; Outx: Textfile; open: boolean; Rec1, Rec2, Rec, sep, sepf: String; lcols, rcols: array of integer; //------------------------------------------------ procedure collist(Rex: String; left: boolean); var i, ll, num, al: integer; begin al := 0; ll := length(Rex); i := 1; num := 0; while i <= ll do begin if (i = ll) or (Rex[i] = ',') then begin if i = ll then num := num * 10 + ord(Rex[i]) - ord('0'); if left then begin SetLength(lcols, al + 1); lcols[al] := num; Inc(al); end else begin SetLength(rcols, al + 1); rcols[al] := num; Inc(al); end; num := 0; end else num := num * 10 + ord(Rex[i]) - ord('0'); Inc(i); end; end; begin collist(Regex1, true); collist(Regex2, false); // numrec := 0; exportcancel := 0; AssignFile(Outx, Name); try Rewrite(Outx); open := true except open := false; end; if open then begin cc1 := VL1.Items.Count; cc2 := VL2.Items.Count; for i := 0 to max(cc1, cc2) - 1 do begin if not ron then begin Rec1 := ''; if i < cc1 then begin su1 := VL1.Items[i].SubItems.Count; Sep := ''; for j := 0 to su1 - 1 do begin Rec1 := Rec1 + Sep + VL1.Items[i].SubItems[j]; Sep := FSB end; end; Rec2 := ''; if i < cc2 then begin su2 := VL2.Items[i].SubItems.Count; Sep := ''; for j := 0 to su2 - 1 do begin Rec2 := Rec2 + Sep + VL2.Items[i].SubItems[j]; Sep := FSB end; end; if Rec1 > '' then Rec := Rec1 + FSB + Rec2 else Rec := Rec2; Write(Outx, Rec + RSB); Inc(numrec) end else if (i < min(cc1, cc2)) then begin Rec1 := ''; Sep := ''; Sepf := FDB; ListRec(vl1,i,true); for j := 0 to length(lcols) - 1 do if lcols[j] < vl1.Items[i].SubItems.Count then begin Rec1 := Rec1 + Sep + Sepf + vl1.Items[i].SubItems[lcols[j]] + sepf; Sep := FSB; end; Rec2 := ''; Sep := ''; for j := 0 to length(rcols) - 1 do if rcols[j] < vl2.Items[i].SubItems.Count then begin Rec2 := Rec2 + Sep + sepf + vl2.Items[i].SubItems[rcols[j]] + sepf; Sep := FSB; end; Rec := Rec1 + FSB + Rec2; Write(Outx, Rec + RSB); Inc(numrec) end; end; CloseFile(Outx); end else begin exportcancel := ask(46, 'Kann die Datei nicht auf die Festplatte schreiben', ' ', [mbOK, mbCancel]); end; result := numrec end; end.