products/Sources/formale Sprachen/Delphi/Bille 0.71/__history/  image not shown  

Quellcode-Bibliothek

© Kompilation durch diese Firma

[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]

Datei:   Sprache: Unknown

rahmenlose Ansicht.~497~ DruckansichtCS {CS[125] Ada[128] Abap[1337]}Datei anzeigen

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, LV2: 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; left: boolean): 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 := 1 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 (LV1.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]) = mrCancel;
  end;
  result := numrec
end;

end.

[ Verzeichnis aufwärts0.235unsichere Verbindung  ]