|
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, test: 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;
test := 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] - 1] + 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] - 1] + 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.
¤ Dauer der Verarbeitung: 0.21 Sekunden
(vorverarbeitet)
¤
|
schauen Sie vor die Tür
Fenster
Die Firma ist wie angegeben erreichbar.
Die farbliche Syntaxdarstellung ist noch experimentell.
|
