Quellcode-Bibliothek
© Kompilation durch diese Firma
[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]
Datei:
Mainboard.dfm.~60~
Sprache: Unknown
rahmenlose Ansicht.~502~ DruckansichtCS {CS[125] Ada[128] Abap[1337]} [Methode: Schwerpunktbildung, einfache Gewichte, sechs Dimensionen]
unit Matching;
interface
//-------------------------------------------------------
//
//-------------------------------------------------------
uses
Dialogs, ExtCtrls, Grids, ValEdit, Menus, Options,
ComCtrls, SysUtils, StrUtils, Classes, Math, Forms,
Controls, //OleAuto,
//-------------------------------------------------------
//
//-------------------------------------------------------
Utilities, Language;
//-------------------------------------------------------
//
//-------------------------------------------------------
procedure setWidths(VL: TListView);
function ListRec(LV1: 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): String;
function exportfile(Name: String; VL1, VL2: TListView; ron: boolean): integer;
procedure getmatchingColumns();
procedure setPivotOnly();
function isinMatches(l, r: integer): integer;
//-------------------------------------------------------
//
//-------------------------------------------------------
type
TMatch = record
valid: boolean;
leftline: integer;
rightline: integer;
leftcol: integer;
rightcol: integer;
MatchString: String;
end;
//-----------------------------------------------------------
//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;
RecMatch1, RecMatch2: integer;
Record1, Record2: String;
ColMatch1, ColMatch2: integer;
Pivot: array [1 .. 2] of array of integer;
Matches: array of TMatch;
Mostleft, Mostright, RecPos: integer;
ActMatch: TMatch;
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;
//-------------------------------------------------------
//
//-------------------------------------------------------
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;
//-------------------------------------------------------
//
//-------------------------------------------------------
procedure setWidths(VL: TListView);
var
j: integer;
begin
for j := 1 to VL.Columns.Count - 1 do
VL.Columns[j].Width := VL.Width div (VL.Columns.Count + 1);
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(LV1, LV2: TListView; ix: integer): String;
var
i, ll: integer;
F, Sep: String;
begin
F := LV1.Items[ix].Caption + ': ';
for i := 0 to LV1.Items[ix].SubItems.Count - 1 do begin
F := F + Sep + LV1.Items[ix].SubItems[i];
Sep := ';'
end;
ll := length(Matches);
for i := 0 to ll - 1 do begin
if Matches[i].valid then begin
if left and (LV1.Items[ix].Index = matches[i].leftline) then
F := F + ' * ' + trans(54, 'Paar ') + '<' + LV1.items
[matches[i].leftline].caption + ',' + LV2.items[matches[i].rightline]
.Caption + ' ''' + matches[i].MatchString + '''>'
else if not left and (LV2.Items[ix].Index = matches[i].rightline) then
F := F + ' * ' + trans(54, 'Paar ') + '<' + LV1.items
[matches[i].leftline].caption + ',' + LV2.items[matches[i].rightline]
.Caption + ' ''' + matches[i].MatchString + '''>'
end;
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): String;
var
i, j, ll1, ll2, bound: integer;
res: boolean;
M1, M2: String;
begin
res := false;
ll1 := Left.SubItems.count;
ll2 := Right.SubItems.count;
bound := min(ll1, ll2);
i := 1;
while not res and (i < bound) do begin
M1 := Left.subitems[i];
j := 1;
while not res and (j < bound) do begin
M2 := Right.subitems[j];
if issimilar(M1, M2) then begin
RecMatch1 := left.Index;
RecMatch2 := Right.Index;
ColMatch1 := i;
ColMatch2 := j;
Inc(Pivot[1][ColMatch1]);
Inc(Pivot[2][ColMatch2]);
res := true;
end;
Inc(j);
end;
Inc(i)
end;
if res then
result := M1
else
result := ''
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; ron: boolean): integer;
var
cc1, cc2, su1, su2, i, j, numrec: integer;
Outx: Textfile;
open: boolean;
Rec1, Rec2, Rec, sep: String;
begin
exportcancel:=0;
AssignFile(Outx, Name);
open := false;
try
Rewrite(Outx);
open := true
except
//errorn(0, 'I have control again', '')
end;
if open then begin
cc1 := VL1.Items.Count;
cc2 := VL2.Items.Count;
numrec:=0;
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 := vl1.Items[i].Caption;
Rec2 := vl2.Items[i].Caption;
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.
[ Verzeichnis aufwärts0.554unsichere Verbindung
]
|
|
