DBR Delphi-Ecke

// Getestet mit D4 unter XP

// Manchmal möchte man in einer Spalte eines Stringgrids Zahlen untereinander-
// schreiben, um sie später zu addieren. Um beim Addieren aber keine Über-
// raschung zu erleben, wäre es gut, gleich bei der Eingabe (hier beim Verlassen
// einer Zelle) festzustellen, ob man wirklich eine Zahl eingetippt hat.
// Der folgende Code erlaubt darüber hinaus auch noch, Eingaben zusätzlich
// zu formatieren, z.B. in eine Währung mit zwei Dezimalstellen.
// Bei Datums- oder Zahlenspalten werden zunächst sogenannte Raw-Data gebildet,
// welche in einer Stringliste gespeichert werden. Hat eine Zelle den Fokus,
// werden diese Raw-Data in Label1 angezeigt und können mit der Zelle verglichen
// werden. Beispielsweise für eine Zahlen-Spalte:

Eingabe	formatieren	mitZeichen	Zelle	Label1 (Raw-Data)
+0	False	False	+0	0
0,0	False	True (kein Einfluss)	0,0	0
- 0,019€	True	True	-0,02 €	(Rundung!) -0,019
00000	True	False	0,00	0
- 0,200	False	False	- 0,200	-0,2
0001,1000	True	False	1,10	1,1
€ 35 -	True	True	-35,00 €	-35
20e+30	True	True	2E31 €	2E31

// Oder für eine Datum-Spalte:

Eingabe	formatieren	Zelle	Label1 (Raw-Data)
1.1.05	False	1.1.05	1.1.05
10122005	False	10122005	10.12.2005
3092005	True	03.09.2005	3.09.2005
21005	True	02.10.2005	2.10.05
05.07.05	True	05.07.2005	5.07.05

// Man setzt ein TStringGrid und zwei TLabel auf die Form und erzeugt
// alle Events mittels Doppelklick im Objektinspektor. Dann ergänzt man den Code
// wie hier unten gezeigt.
// Button1 wurde zusätzlich dazu genommen, um zu zeigen, wie mittels der
// Raw-Data eine genaue Addierung erfolgt.

// Variante 1
// Format pro Spalte, Formatierung ist vor Programmstart festgelegt.
// Raw-Data werden in einer Stringliste gehalten.

unit Unit1; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Forms, StdCtrls, Grids, Controls, Dialogs; 
 
type 
  TForm1 = class(TForm) 
    StringGrid1: TStringGrid; 
    Label1: TLabel; 
    Label2: TLabel;
    Button1: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure StringGrid1SetEditText(Sender: TObject; ACol, ARow: Integer; 
      const Value: string); 
    procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; 
      var CanSelect: Boolean); 
    procedure Button1Click(Sender: TObject); 
    procedure StringGrid1KeyUp(Sender: TObject; var Key: Word; 
      Shift: TShiftState); 
    procedure StringGrid1MouseUp(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
  private 
    { Private-Deklarationen } 
  public 
    procedure beiFehler; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
 
{$R *.DFM} 
 
type 
  ColType = (Num, Dat, Txt); // Zahl,  Datum,  Text 
 
const 
  Spaltenzahl = 5; 
  aoct: array[0..Spaltenzahl - 1] of ColType = 
  (Txt, Txt, Txt, Dat, Num); // Grid hat 5 Spalten; 
 
  WZeichen = '€'; 
  dtm = 'dd.mm.yyyy'; 
  whrg: string = '#,##0.00'; 
 
  ueberwachen = true; 
  formatieren = true; 
  mitZeichen = true; 
 
  fehler: boolean = false; 
 
  merkCol: integer = -1; 
  merkRow: integer = -1; 
 
var 
  ts: TStrings; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  ts := TStringlist.create; 
  ts.add(#1); 
  Label1.Caption := ''; 
  Label2.Caption := ''; 
  with StringGrid1 do begin 
    FixedCols := 1; 
    ColCount := Spaltenzahl; 
    Options := Options + [goEditing]; 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var x, y: integer; 
begin 
  with StringGrid1 do 
    for x := 0 to ColCount - 1 do 
      for y := 0 to RowCount - 1 do 
        Objects[x, y] := nil; 
  ts.free; 
end; 
 
procedure TForm1.StringGrid1SetEditText(Sender: TObject; ACol, 
  ARow: Integer; const Value: string); 
var 
  i: integer; 
  n: double; 
  d: TDateTime; 
  V, s: string; 
  procedure anzeige; 
  begin 
    with StringGrid1 do 
      if (ACol = Col) and (ARow = Row) then 
        Label1.Caption := V; 
  end; 
begin 
  with StringGrid1 do begin 
    if not editormode and (ueberwachen or formatieren) then begin 
      V := Value; 
      Objects[ACol, ARow] := nil; 
      anzeige; 
      if (V = '') or not (aoct[ACol] in [Num, Dat]) then exit; 
      try 
        if aoct[ACol] = Num then begin 
          V := stringreplace(stringreplace(V, #32, '', [rfreplaceall]), 
            ThousandSeparator, '', [rfreplaceall]); 
          if mitZeichen then 
            V := stringreplace(V, WZeichen, '', []); 
          i := pos('+', V); 
          if (i = 1) or (i = length(V)) then delete(V, i, 1); 
          i := pos('-', V); 
          if (i = length(V)) then V := '-' + copy(V, 1, length(V) - 1); 
          if (V = DecimalSeparator) or (V = '-') or (V = '') then V := '0'; 
          n := strtofloat(V); 
          V := floattostr(n); 
          anzeige; 
          if formatieren then begin 
            s := formatfloat(whrg, n); 
            if mitZeichen then s := s + #32 + WZeichen; 
            Cells[ACol, ARow] := s; 
          end; 
        end else begin 
          if (pos(DateSeparator, V) = 0) and (pos(TimeSeparator, V) = 0) 
            then begin 
            case length(V) of 
              5, 7: begin 
                  insert(DateSeparator, V, 2); 
                  insert(DateSeparator, V, 5); 
                end; 
              6, 8: begin 
                  insert(DateSeparator, V, 3); 
                  insert(DateSeparator, V, 6); 
                end; 
            end; 
            anzeige; 
          end; 
          d := strtodate(V); 
          if formatieren then 
            Cells[ACol, ARow] := formatdatetime(dtm, d); 
        end; 
        i := ts.indexof(V); 
        if i < 0 then begin 
          ts.add(V); 
          i := ts.count - 1; 
        end; 
        Objects[ACol, ARow] := TObject(i); 
      except 
        beep; 
        Objects[ACol, ARow] := nil; 
        Cells[ACol, ARow] := ''; 
        Label1.Caption := ''; 
        Row := ARow; 
        Col := ACol; 
        fehler := true; 
        Label2.Caption := 'Falsche Eingabe in Zelle ' + 
          inttostr(ACol) + '/' + inttostr(ARow); 
      end; 
    end else begin 
      Label1.Caption := Value; 
      Label2.Caption := ''; 
      fehler := false; 
      merkCol := ACol; 
      merkRow := ARow; 
    end; 
  end; 
end; 
 
procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, 
  ARow: Integer; var CanSelect: Boolean); 
var s: string; 
begin 
  with StringGrid1 do begin 
    if editormode then begin 
      editormode := false; 
      StringGrid1SetEditText(self, merkCol, merkRow, Cells[merkCol, merkRow]); 
    end; 
    s := ts[integer(Objects[ACol, ARow])]; 
    if s = #1 then Label1.Caption := Cells[ACol, ARow] 
    else Label1.Caption := s; 
  end; 
end; 
 
procedure TForm1.beiFehler; 
begin 
  with StringGrid1 do 
    if fehler then begin 
      Row := merkRow; 
      Col := merkCol; 
      fehler := false; 
    end; 
end; 
 
procedure TForm1.StringGrid1KeyUp(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
begin 
  beiFehler; 
end; 
 
procedure TForm1.StringGrid1MouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  beiFehler; 
end; 
 
 
 
// genaues Addieren einer Spalte 

procedure TForm1.Button1Click(Sender: TObject); 
var 
  s: string; 
  x: integer; 
  y: extended; 
  spalte: byte; 
begin 
  y := 0; 
  spalte := 4; 
  if (spalte <= high(aoct)) and (aoct[spalte] = Num) then begin 
    with StringGrid1 do begin 
      for x := FixedRows to RowCount - 1 do begin 
        s := ts[integer(Objects[spalte, x])]; 
        if s <> #1 then y := y + strtofloat(s); 
      end; 
    end; 
    Showmessage(Floattostr(y)); 
  end else Showmessage('Keine Zahlenspalte'); 
end; 
 
end.

// -------------------------------------------------------

// Variante 2
// Format pro Zelle, Formatierung während der Laufzeit.
// Raw-Data werden in einem dynamischen Array gehalten. Diese muss bei
// Änderung des Grids (z.B. Zeilen oder Spalten hizufügen) ebenfalls
// geändert werden!!!
// Die Variable reagierenBeiFehler legt fest, ob Eingaben, welche dem
// Zellenformat widersprechen, gelöscht oder kommentarlos beibehalten werden.

unit Unit1; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Forms, StdCtrls, Grids, Controls, Dialogs; 
 
type 
  TForm1 = class(TForm) 
    StringGrid1: TStringGrid; 
    Label1: TLabel; 
    Label2: TLabel; 
    Button1: TButton; 
    Button2: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure StringGrid1SetEditText(Sender: TObject; ACol, ARow: Integer; 
      const Value: string); 
    procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; 
      var CanSelect: Boolean); 
    procedure StringGrid1KeyUp(Sender: TObject; var Key: Word; 
      Shift: TShiftState); 
    procedure StringGrid1MouseUp(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    function Zahl(var V: string; ACol, ARow: integer; itg: boolean): boolean; 
    function Datum(var V: string; ACol, ARow: integer): boolean; 
    procedure Gross(var V: string; ACol, ARow: integer); 
    procedure beiFehler; 
    procedure BereichAnpassen(BegCol, EndCol, BegRow, EndRow: integer); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
 
{$R *.DFM} 
 
type 
  CellType = (Txt, Upcs, Num, Intg, Dat); 
  //  Unformatiert, Großbuchstaben, Gleitkommazahl, Ganzzahl, Datum 
 
  fRecord = record 
    Typ: CellType; 
    Text, Frmt: string; 
    WZeichen: Char; 
  end; 
 
const 
  Spaltenzahl = 5; 
 
  merkCol: integer = -1; 
  merkRow: integer = -1; 
 
  falsch: boolean = false; 
  reagierenBeiFehler: boolean = true; 
 
var 
  aofr: array of array of fRecord; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Label1.Caption := ''; 
  Label2.Caption := ''; 
  with StringGrid1 do begin 
    FixedCols := 1; 
    ColCount := Spaltenzahl; 
    Options := Options + [goEditing]; 
    setlength(aofr, ColCount, RowCount); 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  aofr := nil; 
end; 
 
procedure TForm1.Gross(var V: string; ACol, ARow: integer); 
begin 
  with stringgrid1 do begin 
    aofr[ACol, ARow].Text := V; 
    Cells[ACol, ARow] := AnsiUppercase(V); 
  end; 
end; 
 
function TForm1.Zahl(var V: string; ACol, ARow: integer; itg: boolean): boolean; 
var 
  i, z: integer; 
  n: extended; 
  s: string; 
begin 
  with stringgrid1 do begin 
    try 
      V := stringreplace(stringreplace(V, #32, '', [rfreplaceall]), 
        ThousandSeparator, '', [rfreplaceall]); 
      if aofr[ACol, ARow].WZeichen <> #0 then 
        V := stringreplace(V, aofr[ACol, ARow].WZeichen, '', []); 
      i := pos('+', V); 
      if (i = 1) or (i = length(V)) then delete(V, i, 1); 
      i := pos('-', V); 
      if (i = length(V)) then V := '-' + copy(V, 1, length(V) - 1); 
      if (V = DecimalSeparator) and not itg or (V = '-') or (V = '') 
        then V := '0'; 
      if itg then z := strtoint(V) else 
        n := strtofloat(V); 
      if itg then 
        V := inttostr(z) else 
        V := floattostr(n); 
      if aofr[ACol, ARow].Frmt <> '' then begin 
        if itg then n := z; 
        s := formatfloat(aofr[ACol, ARow].Frmt, n); 
        if aofr[ACol, ARow].WZeichen <> #0 then s := s + #32 + 
          aofr[ACol, ARow].WZeichen; 
        Cells[ACol, ARow] := s; 
      end; 
    except 
      result := false; 
      exit; 
    end; 
    result := true; 
  end; 
end; 
 
function TForm1.Datum(var V: string; ACol, ARow: integer): boolean; 
var 
  d: TDateTime; 
begin 
  with stringgrid1 do begin 
    try 
      if (pos(DateSeparator, V) = 0) and (pos(TimeSeparator, V) = 0) 
        then begin 
        case length(V) of 
          5, 7: begin 
              insert(DateSeparator, V, 2); 
              insert(DateSeparator, V, 5); 
            end; 
          6, 8: begin 
              insert(DateSeparator, V, 3); 
              insert(DateSeparator, V, 6); 
            end; 
        end; 
      end; 
      d := strtodate(V); 
      if aofr[ACol, ARow].Frmt <> '' then 
        Cells[ACol, ARow] := formatdatetime(aofr[ACol, ARow].Frmt, d); 
    except 
      result := false; 
      exit; 
    end; 
    result := true; 
  end; 
end; 
 
procedure TForm1.StringGrid1SetEditText(Sender: TObject; ACol, 
  ARow: Integer; const Value: string); 
var 
  V: string; 
  procedure anzeige; 
  begin 
    with stringgrid1 do 
      if (ACol = Col) and (ARow = Row) then 
        Label1.Caption := V; 
  end; 
  procedure fehler; 
  begin 
    with stringgrid1 do begin 
      beep; 
      Row := ARow; 
      Col := ACol; 
      aofr[ACol, ARow].Text := ''; 
      Cells[ACol, ARow] := ''; 
      Label1.Caption := ''; 
      falsch := true; 
      Label2.Caption := 'Falsche Eingabe in Zelle ' + inttostr(ACol) + 
        '/' + inttostr(ARow); ; 
    end; 
  end; 
begin 
  with StringGrid1 do begin 
    if not editormode then begin 
      V := Value; 
      anzeige; 
      if (Value = '') then begin 
        aofr[ACol, ARow].Text := ''; 
        exit; 
      end; 
      case aofr[ACol, ARow].Typ of 
        Intg: if not Zahl(V, ACol, ARow, true) then begin 
            if reagierenBeiFehler then begin 
              fehler; 
              exit; 
            end else aofr[ACol, ARow].Text := Value; 
          end else aofr[ACol, ARow].Text := V; 
        Num: if not Zahl(V, ACol, ARow, false) then begin 
            if reagierenBeiFehler then begin 
              fehler; 
              exit; 
            end else aofr[ACol, ARow].Text := Value; 
          end else aofr[ACol, ARow].Text := V; 
        Dat: if not Datum(V, ACol, ARow) then begin 
            if reagierenBeiFehler then begin 
              fehler; 
              exit; 
            end else aofr[ACol, ARow].Text := Value; 
          end else aofr[ACol, ARow].Text := V; 
        Upcs: Gross(V, ACol, ARow); 
      else aofr[ACol, ARow].Text := V; 
      end; 
      anzeige; 
    end else begin 
      Label1.Caption := Value; 
      Label2.Caption := ''; 
      falsch := false; 
      merkCol := ACol; 
      merkRow := ARow; 
    end; 
  end; 
end; 
 
procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, 
  ARow: Integer; var CanSelect: Boolean); 
begin 
  with StringGrid1 do begin 
    if editormode then begin 
      editormode := false; 
      StringGrid1SetEditText(Form1, merkCol, merkRow, Cells[merkCol, merkRow]); 
    end; 
    Label1.Caption := aofr[ACol, ARow].Text; 
  end; 
end; 
 
procedure TForm1.BereichAnpassen(BegCol, EndCol, BegRow, EndRow: integer); 
var 
  x, y, z: integer; 
  s: string; 
begin 
  z := 0; 
  with StringGrid1 do begin 
    editormode := false; 
    for x := BegCol to EndCol do 
      for y := BegRow to EndRow do begin 
        s := aofr[x, y].Text; 
        if s <> '' then 
          case aofr[x, y].Typ of 
            Upcs: Gross(aofr[x, y].Text, x, y); 
            Num: if not Zahl(aofr[x, y].Text, x, y, false) then 
                if reagierenBeiFehler then begin 
                  aofr[x, y].Text := ''; 
                  Cells[x, y] := ''; 
                  inc(z); 
                end else aofr[x, y].Text := s; 
            Intg: if not Zahl(aofr[x, y].Text, x, y, true) then 
                if reagierenBeiFehler then begin 
                  aofr[x, y].Text := ''; 
                  Cells[x, y] := ''; 
                  inc(z); 
                end else aofr[x, y].Text := s; 
            Dat: if not Datum(aofr[x, y].Text, x, y) then 
                if reagierenBeiFehler then begin 
                  aofr[x, y].Text := ''; 
                  Cells[x, y] := ''; 
                  inc(z); 
                end else aofr[x, y].Text := s; 
          else Cells[x, y] := aofr[x, y].Text; 
          end; 
      end; 
    Label1.Caption := aofr[Col, Row].Text; 
    if z > 0 then begin 
      beep; 
      Label2.Caption := inttostr(z) + ' Zellen mussten eliminiert werden'; 
    end else 
      if not falsch then Label2.Caption := ''; 
  end; 
  falsch := false; 
end; 
 
procedure TForm1.beiFehler; 
begin 
  with StringGrid1 do 
    if falsch then begin 
      Row := merkRow; 
      Col := merkCol; 
      falsch := false; 
    end; 
end; 
 
procedure TForm1.StringGrid1KeyUp(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
begin 
  beiFehler; 
end; 
 
procedure TForm1.StringGrid1MouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  beiFehler; 
end; 
 
 
 
// Beispiel der Formatzuweisung für eine einzelne Zelle 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  aofr[1, 2].Typ := Dat; 
  aofr[1, 2].Frmt := 'dd.mm.yyyy'; 
  if StringGrid1.Cells[1, 1] <> '' then BereichAnpassen(1, 1, 2, 2); 
end; 



// ein Beispiel, wie man ganzen Bereiche (z.B. Spalten) 
// Formatierungen zuweist 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  x: integer; 
begin 
  with StringGrid1 do begin 
    for x := FixedRows to RowCount - 1 do begin 
      aofr[1, x].Typ := Num; 
      aofr[1, x].Frmt := '#,##0.00'; 
      aofr[1, x].WZeichen := '€'; 
 
      aofr[2, x].Typ := Intg; 
      aofr[2, x].Frmt := '0';
      aofr[2, x].WZeichen := #0;  
 
      aofr[3, x].Typ := Dat; 
      aofr[3, x].Frmt := 'd.m.yy'; 
 
      aofr[4, x].Typ := Upcs; 
    end; 
    BereichAnpassen(1, 4, FixedRows, RowCount - 1); 
  end; 
end;
 
end.