TDigits Komponente

[surfer007]

Ich habe nun eine eigene Digits Komponente erstellt.
Hier der Source Code:

Code:

{************************************************}
{ TGfxDigits Version 1.1 (15.04.2011)            }
{************************************************}

unit GfxDigits;

interface

uses
  Windows, SysUtils, Classes, Controls, Graphics, Types;

type
  TGfxDigits = class(TGraphicControl)
  private
    { Private declarations }
    FDigitsCount: Byte;
    FValue: Integer;
    FDigits: TPicture;
    FShowZeros: Boolean;
    procedure DigitsChanged(Sender: TObject);
    procedure SetDigits(const Value: TPicture);
    procedure SetDigitsCount(const Value: Byte);
    procedure SetValue(const Value: Integer);
    procedure SetShowZeros(const Value: Boolean);
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Visible;
    property Value : Integer read FValue write SetValue;
    property DigitsCount : Byte read FDigitsCount write SetDigitsCount;
    property Digits : TPicture read FDigits write SetDigits;
    property ShowZeros : Boolean read FShowZeros write SetShowZeros;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

{$R digit.RES}

procedure Register;
begin
  RegisterComponents('Samples', [TGfxDigits]);
end;

{ TGfxDigits }

constructor TGfxDigits.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  parent := TWINControl(AOwner);

  FDigitsCount := 1;
  FDigits := TPicture.Create;

  // load default bitmap from resource
  FDigits.bitmap.handle := LoadBitMap(HInstance, 'digit');

  FDigits.OnChange := DigitsChanged;
  Paint;
end;

destructor TGfxDigits.Destroy;
begin
  FDigits.Free;
  FDigits := nil;
  inherited Destroy;
end;

procedure TGfxDigits.DigitsChanged(Sender: TObject);
begin
  Paint;
end;

procedure TGfxDigits.Paint;
var
  i, k, dw : Integer;
  s : string;
  SrcRect, DstRect : TRect;
  bBitmap : TBitmap;
begin
  inherited;

  // Value to String
  s := IntToStr(FValue);

  // AutoReSize
  if (Length(s) > FDigitsCount) then FDigitsCount := Length(s);

  dw := (FDigits.Width div 11);             // width of 1 digit
  Width := FDigitsCount * dw;               // total width
  Height := FDigits.Height;                 // total height

  // Adjust String to DigitsCount
  if Length(s) < FDigitsCount then begin
    k := FDigitsCount - Length(s);
    for i := 1 to k do begin
      s := 'x' + s;                         // eg. 98 with 3 digits becomes x98
    end;
  end;

  bBitmap := TBitmap.Create;
  bBitmap.Width := Width;
  bBitmap.Height := Height;

  // Copy the numbers to the canvas
  for i := 1 to FDigitsCount do begin
    k := StrToIntDef(s[i], 10);
    if FShowZeros AND (k = 10) then k := 0;
    SrcRect := Rect(k*dw, 0, k*dw + dw, FDigits.Height);
    DstRect := Rect((i-1)*dw, 0, (i-1)*dw + dw, FDigits.Height);
    bBitmap.Canvas.CopyRect(DstRect, FDigits.Bitmap.Canvas, SrcRect);
  end;

  Canvas.CopyRect(Rect(0,0,Width,Height), bBitmap.Canvas, Rect(0,0,Width,Height));

  bBitmap.Free;

end;

procedure TGfxDigits.SetDigits(const Value: TPicture);
begin
  FDigits.Assign(Value);
  Paint;
end;

procedure TGfxDigits.SetDigitsCount(const Value: Byte);
begin
  FDigitsCount := Value;
  Paint;
end;

procedure TGfxDigits.SetShowZeros(const Value: Boolean);
begin
  FShowZeros := Value;
  Paint;
end;

procedure TGfxDigits.SetValue(const Value: Integer);
begin
  FValue := Value;
  Paint;
end;

end.

Da dies meine erste Komponente ist bitte mal den Code anschauen und evtl. Verbesserungsvorschläge machen!

Grüsse,
Surfer007

[shmia]

Ich würde das Bitmap, dass du in procedure TGfxDigits.Paint verwendest, nicht jedesmal neu erzeugen und freigeben.
Die Paint-Methode kann sehr häufig aufgerufen werden und erzeugt so "Stress" für den Memory-Manager von Delphi als auch für Windows (Handle erzeugen/zerstören).

PS:

Delphi-Quellcode:

procedure TGfxDigits.SetValue(const Value: Integer);
begin
  if Value<>FValue then // nur wenn sich der Wert ändert etwas tun
  begin
    FValue := Value;
    Paint;
  end;
end;

[surfer007]

Ok, das Temp Bitmap ist nun Global und SetValue arbeitet nur bei einer Änderung

Delphi-Quellcode:

{************************************************}
{ TGfxDigits Version 1.1 (15.04.2011)            }
{************************************************}

unit GfxDigits;

interface

uses
  Windows, SysUtils, Classes, Controls, Graphics, Types;

type
  TGfxDigits = class(TGraphicControl)
  private
    { Private declarations }
    FDigitsCount: Byte;
    FValue: Integer;
    FDigits: TPicture;
    FShowZeros: Boolean;
    procedure DigitsChanged(Sender: TObject);
    procedure SetDigits(const Value: TPicture);
    procedure SetDigitsCount(const Value: Byte);
    procedure SetValue(const Value: Integer);
    procedure SetShowZeros(const Value: Boolean);
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Visible;
    property Value : Integer read FValue write SetValue;
    property DigitsCount : Byte read FDigitsCount write SetDigitsCount;
    property Digits : TPicture read FDigits write SetDigits;
    property ShowZeros : Boolean read FShowZeros write SetShowZeros;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

var
  bBitmap : TBitmap;

procedure Register;

implementation

{$R digit.RES}

procedure Register;
begin
  RegisterComponents('Samples', [TGfxDigits]);
end;

{ TGfxDigits }

constructor TGfxDigits.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  parent := TWINControl(AOwner);

  FDigitsCount := 1;
  FDigits := TPicture.Create;

  bBitmap := TBitmap.Create;

  // load default bitmap from resource
  FDigits.bitmap.handle := LoadBitMap(HInstance, 'digit');

  FDigits.OnChange := DigitsChanged;
  Paint;
end;

destructor TGfxDigits.Destroy;
begin
  bBitmap.Free;
  bBitmap := nil;
  FDigits.Free;
  FDigits := nil;
  inherited Destroy;
end;

procedure TGfxDigits.DigitsChanged(Sender: TObject);
begin
  Paint;
end;

procedure TGfxDigits.Paint;
var
  i, k, dw : Integer;
  s : string;
  SrcRect, DstRect : TRect;
begin
  inherited;

  // Value to String
  s := IntToStr(FValue);

  // AutoReSize
  if (Length(s) > FDigitsCount) then FDigitsCount := Length(s);

  dw := (FDigits.Width div 11);             // width of 1 digit
  Width := FDigitsCount * dw;               // total width
  Height := FDigits.Height;                 // total height

  // Adjust String to DigitsCount
  if Length(s) < FDigitsCount then begin
    k := FDigitsCount - Length(s);
    for i := 1 to k do begin
      s := 'x' + s;                         // eg. 98 with 3 digits becomes x98
    end;
  end;

  bBitmap.Width := Width;
  bBitmap.Height := Height;

  // Copy the numbers to the canvas
  for i := 1 to FDigitsCount do begin
    k := StrToIntDef(s[i], 10);
    if FShowZeros AND (k = 10) then k := 0;
    SrcRect := Rect(k*dw, 0, k*dw + dw, FDigits.Height);
    DstRect := Rect((i-1)*dw, 0, (i-1)*dw + dw, FDigits.Height);
    bBitmap.Canvas.CopyRect(DstRect, FDigits.Bitmap.Canvas, SrcRect);
  end;

  Canvas.CopyRect(Rect(0,0,Width,Height), bBitmap.Canvas, Rect(0,0,Width,Height));

end;

procedure TGfxDigits.SetDigits(const Value: TPicture);
begin
  FDigits.Assign(Value);
  Paint;
end;

procedure TGfxDigits.SetDigitsCount(const Value: Byte);
begin
  FDigitsCount := Value;
  Paint;
end;

procedure TGfxDigits.SetShowZeros(const Value: Boolean);
begin
  FShowZeros := Value;
  Paint;
end;

procedure TGfxDigits.SetValue(const Value: Integer);
begin
  if Value <> FValue then begin
    FValue := Value;
    Paint;
  end;
end;

end.

[DeddyH]

Mach doch aus der globalen Variablen ein privates Feld der Komponente. Und benutze bitte Delphi- statt Code-Tags.

[sx2008]

Ich sehe da noch zwei weitere Fehler im Konstruktor (aber keine Bange, das wird schon noch).

1. Problem: der Owner und das Property Parent sind nicht zwingend identisch
Parent wird automatisch von der VCL gesetzt, sobald man ein Control auf einem Formular
platziert.
Das bedeutet also, dass ein Control das Property Parent nicht selbst zuweisen darf;
das erledigt die VCL von Aussen.

Delphi-Quellcode:

constructor TGfxDigits.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  parent := TWINControl(AOwner);  // Zeile weglassen

2. Problem: Methode Paint wird im Konstruktor aufgerufen,
obwohl das Control zu diesem Zeitpunkt noch gar nicht sichtbar ist

Delphi-Quellcode:

constructor TGfxDigits.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
....
  FDigits.OnChange := DigitsChanged;
  Paint;  // Zeile weglassen
end;

Und dann noch eine Unschönheit im Destruktor.
Das explizite Setzen von FDigits := nil ist sinnlos, da ja FDigits direkt vom dem "Tode" steht.
Es besteht keine Gefahr, dass FDigits noch irgendwie nachdem das Objekt der Klasse TGfxDigits destroyed wurde noch angesprochen wird.
Ich empfehle, die Unterobjekte FBitmap und FDigits in umgekehrter Reihenfolge freizugeben wie sie im Konstruktor angelegt wurde.
Dieses Freigeben in umgekehrter Reihenfolge gilt ganz generell für alle Objekte und Resourcen

Delphi-Quellcode:

destructor TGfxDigits.Destroy;
begin
  FBitmap.Free;
  FDigits.Free;
  inherited Destroy;
end;

[surfer007]

Da ich zum testen die Komponente mit
mydigit := TGfxDigits.Create(Self); zur Laufzeit erstelle gibt das dann eine Fehlermeldung "Control has no parent window" an der Stelle
Canvas.CopyRect(Rect(0,0,Width,Height), FBitmap.Canvas, Rect(0,0,Width,Height)); siehe Screenshot...

Durch Setzen des Property Parent war die Fehlermeldung dann weg. Das Paint im Konstruktor habe ich gemacht da ohne das Paint nichts passiert (wenn zur Laufzeit erzeugt!).

Ok, ich habe nun die Parent Anweisung + das Paint im Konstruktor gelöscht. Im Destruktor die Reihenfolge optimiert und die nil Anweisungen gelöscht. Das Temp Bitmap FBitmap ist nun auch Private. Klappt auch gut wenn man die Komponente auf das Formular legt und nicht zur Laufzeit erzeugt

Ist zwar nicht von Nöten, aber was ist wenn man die Komponente zur Laufzeit erzeugt? Ich habe das nun so gemacht (dazu muss die Paint Procedure Public sein):

Delphi-Quellcode:

procedure TForm1.Button1Click(Sender: TObject);
begin
  mydigit := TGfxDigits.Create(Form1);
  mydigit.Parent := Form1;
  mydigit.Paint;
end;

Aktuelle Version v1.2:

Delphi-Quellcode:

{************************************************}
{ TGfxDigits Version 1.2 (16.04.2011)            }
{************************************************}

unit GfxDigits;

interface

uses
  Windows, SysUtils, Classes, Controls, Graphics, Types;

type
  TGfxDigits = class(TGraphicControl)
  private
    { Private declarations }
    FDigitsCount: Byte;
    FValue: Integer;
    FDigits: TPicture;
    FBitmap : TBitmap;
    FShowZeros: Boolean;
    procedure DigitsChanged(Sender: TObject);
    procedure SetDigits(const Value: TPicture);
    procedure SetDigitsCount(const Value: Byte);
    procedure SetValue(const Value: Integer);
    procedure SetShowZeros(const Value: Boolean);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
  published
    { Published declarations }
    property Visible;
    property Value : Integer read FValue write SetValue;
    property DigitsCount : Byte read FDigitsCount write SetDigitsCount;
    property Digits : TPicture read FDigits write SetDigits;
    property ShowZeros : Boolean read FShowZeros write SetShowZeros;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

{$R digit.RES}

procedure Register;
begin
  RegisterComponents('Samples', [TGfxDigits]);
end;

{ TGfxDigits }

constructor TGfxDigits.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FDigitsCount := 1;
  FDigits := TPicture.Create;
  FBitmap := TBitmap.Create;

  // load default bitmap from resource
  FDigits.bitmap.handle := LoadBitMap(HInstance, 'digit');

  FDigits.OnChange := DigitsChanged;
end;

destructor TGfxDigits.Destroy;
begin
  FBitmap.Free;
  FDigits.Free;
  inherited Destroy;
end;

procedure TGfxDigits.DigitsChanged(Sender: TObject);
begin
  Paint;
end;

procedure TGfxDigits.Paint;
var
  i, k, dw : Integer;
  s : string;
  SrcRect, DstRect : TRect;
begin
  inherited;

  // Value to String
  s := IntToStr(FValue);

  // AutoReSize
  if (Length(s) > FDigitsCount) then FDigitsCount := Length(s);

  dw := (FDigits.Width div 11);             // width of 1 digit
  Width := FDigitsCount * dw;               // total width
  Height := FDigits.Height;                 // total height

  // Adjust String to DigitsCount
  if Length(s) < FDigitsCount then begin
    k := FDigitsCount - Length(s);
    for i := 1 to k do begin
      s := 'x' + s;                         // eg. 98 with 3 digits becomes x98
    end;
  end;

  FBitmap.Width := Width;
  FBitmap.Height := Height;

  // Copy the numbers to the canvas
  for i := 1 to FDigitsCount do begin
    k := StrToIntDef(s[i], 10);
    if FShowZeros AND (k = 10) then k := 0;
    SrcRect := Rect(k*dw, 0, k*dw + dw, FDigits.Height);
    DstRect := Rect((i-1)*dw, 0, (i-1)*dw + dw, FDigits.Height);
    FBitmap.Canvas.CopyRect(DstRect, FDigits.Bitmap.Canvas, SrcRect);
  end;

  Canvas.CopyRect(Rect(0,0,Width,Height), FBitmap.Canvas, Rect(0,0,Width,Height));

end;

procedure TGfxDigits.SetDigits(const Value: TPicture);
begin
  FDigits.Assign(Value);
  Paint;
end;

procedure TGfxDigits.SetDigitsCount(const Value: Byte);
begin
  FDigitsCount := Value;
  Paint;
end;

procedure TGfxDigits.SetShowZeros(const Value: Boolean);
begin
  FShowZeros := Value;
  Paint;
end;

procedure TGfxDigits.SetValue(const Value: Integer);
begin
  if Value <> FValue then begin
    FValue := Value;
    Paint;
  end;
end;

end.

PS: Die uses "Types" kann man sich sparen da in "Windows" mit drin.

[DeddyH]

Zitat:

Delphi-Quellcode:

procedure TForm1.Button1Click(Sender: TObject);
begin
  mydigit := TGfxDigits.Create(Form1);
  mydigit.Parent := Form1;
  mydigit.Paint;
end;

-->

Delphi-Quellcode:

procedure TForm1.Button1Click(Sender: TObject);
begin
  mydigit := TGfxDigits.Create(Form1);
  mydigit.Parent := self;
end;

Und in den Setter-Methoden würde ich das überall nach Muster

Delphi-Quellcode:

procedure TGfxDigits.SetValue(const Value: Integer);
begin
  if Value <> FValue then begin
    FValue := Value;
    Invalidate;
  end;
end;

machen. Es muss ja nur dann neu gezeichnet werden, wenn sich der Wert der Property auch wirklich ändern soll.

P.S.: Den Parameter eines Setters für die Property Value auch Value zu nennen ist eher kontraproduktiv.

[mkinzler]

Hier auch
mydigit := TGfxDigits.Create(Form1); in
mydigit := TGfxDigits.Create(self); ändern

Und Statt Value AValue

[DeddyH]

Stimmt, das habe ich übersehen

[surfer007]

Ich habe ein kleines Problem wenn ich ein TGfxDigits auf ein TImage32 aus der Graphics32 Sammlung lege. Zur Entwurfszeit ist alles ok (Screenshot1) aber zur Laufzeit wird das TImage32 nicht gezeichnet, es erscheint transparent d.h. alles was unter dem Form liegt ist sichtbar (Screenshot2). Was kann man da machen?