Image mit Label erstellen

galagher · Verfasst: So 28.10.07 17:24

Hallo!
Also, jetzt liess mir das doch keine Ruhe und ich wollte mir so eine Komponente basteln:

Narses hat folgendes geschrieben:

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:

type
   TLabledImage = class(TImage)
   private
     FLabel: TLabel;
     FImageList: TImageList;
     FCaptions: TStringList;
     FRefIndex: Integer;
    procedure SetRefIndex(const Value: Integer);
   public
     constructor Create(AOwner: TComponent; AImageList: TImageList; ACaptions: TStringList);
     property RefIndex: Integer read FRefIndex write SetRefIndex;
     property TheLabel: TLabel read FLabel;
   end;

Klappte auch (mit einigen Änderungen), lässt sich installieren und läuft dann auch, aber das Label wird einfach irgendwo auf dem Formular erstellt und "gehört" nicht dem LabledImage. Ich dachte, wenn ich im Create die Position angebe, sollte es gehen, aber ist nicht so:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:

constructor TLabledImage.Create(AOwner: TComponent; AImageList: TImageList; ACaptions: TStringList);
begin
  inherited Create(AOwner);
  Parent := TWinControl(AOwner);
  FLabel := TLabel.Create(AOwner);
  FLabel.Parent := TWinControl(AOwner);  //-> AOwner ist doch das TLabledImage, oder?
  Flabel.Top  := Top+Height+10;  //Top, Height und Left beziehen sich doch auf TLabledImage, oder?
  Flabel.Left := 0;  //Mit 0 meine ich nicht 0 auf der Form, sondern den linken Rand vom LabledImage!
end;

Das geht so nicht! Ich habe dann eine TLabledImage-Kompo auf dem Formular und ein unbenanntes Label, das aber nicht mit dem LabledImage "verbunden" ist, sondern separat auf der Form rumliegt. Ich meine das so, wie es bei LabeledEdit ist - da ist das Label "Teil" der Komponente.

Da tritt auch gleich das nächste Problem auf: Wenn ich es also hinbekomme, dass das Label zu TLabledImage gehört, wie erreiche ich, dass es bei Grössenänderung des TLabledImage's relativ zum TLabledImage seine Position behält, also immer 10 Pixel unterhalb (Top+Height+10) und immer am linken Rand vom TLabledImage?

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

Shorty · Verfasst: So 28.10.07 21:55

Ich bin nicht ganz fit in Komponentenentwicklung, aber ich würde es mal mit FLabel.Parent := self;
Da dann in diesem Fall deine Klasse, bzw deine Komponente mit angesprochen wird.
Wenn du das so änderst, sollten Top und Left sich auch auf das TabledImage beziehen.

Du würdest deine Komponente ja so erzeugen:

markieren

Delphi-Quelltext

1:	LabeledImage:= TLabledImage.Create(self, ImageList, Captions)

Also gibst du die Form als Owner der Komponente an, daher wird das Label auch auf der Form und nicht auf deinem LabeledImage angezeigt :idea:

MfG Shorty

Narses · Verfasst: Mo 29.10.07 00:06

Moin!

galagher hat folgendes geschrieben:

Klappte auch (mit einigen Änderungen)

Hm, welche (ausser den FLabel.Top/Left-Zuweisungen) sind denn das wohl? :gruebel:

Weil der Rest oben ist identisch mein Code... :zwinker:

Du musst natürlich die Positionen noch behandeln, das hatte ich aber bereits erwähnt.

Ich hab mal eine Demo angehängt, wie man es lösen könnte.

Du brauchst die Kompo übrigens nicht extra in der IDE registrieren, das geht auch ganz einfach dynamisch. :idea:

cu
Narses

Einloggen, um Attachments anzusehen!

_________________
There are 10 types of people - those who understand binary and those who don´t.

galagher · Verfasst: Mo 29.10.07 17:41

Narses hat folgendes geschrieben:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:

type
   TLabledImage = class(TImage)
   private
     FLabel: TLabel;
     FImageList: TImageList;
     FCaptions: TStringList;
     FRefIndex: Integer;
    procedure SetRefIndex(const Value: Integer);
   public
     constructor Create(AOwner: TComponent; AImageList: TImageList; ACaptions: TStringList);
     property RefIndex: Integer read FRefIndex write SetRefIndex;
     property TheLabel: TLabel read FLabel;
   end;

Narses hat folgendes geschrieben:

galagher hat folgendes geschrieben:

Klappte auch (mit einigen Änderungen)

Hm, welche (ausser den FLabel.Top/Left-Zuweisungen) sind denn das wohl?

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:

type
   TLabeledImage = class(TImage)
   private
     FLabel: TLabel;
     FCaptions: TStringList;
   public
     constructor Create(AOwner: TComponent; ACaptions: TStringList);
   //Wenn man TLabeledImage als VCL-Kompo registrieren will, muss das unter "published",
   published  //sonst gibt's im OI kein property Label!
     property ImageLabel: TLabel read FLabel;
   end;

Ich möchte die Komponente als zur Designzeit auf die Form setzen können, und das Label soll sich bei Grössenänderungen anpassen. mal sehen, ob ich das hinbekomme!

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

Narses · Verfasst: Mo 29.10.07 17:46

Moin!

galagher hat folgendes geschrieben:

Ich möchte die Komponente als zur Designzeit auf die Form setzen können, und das Label soll sich bei Grössenänderungen anpassen. mal sehen, ob ich das hinbekomme!

Als Designtime-Kompo taugt mein Ansatz mit dem FLabelallerdings nicht viel, zugegebenermaßen.

Da gibt´s einige (und nicht zu knapp schwierige) Probleme. In diesem Fall solltest du besser ein TBoundLabelals Komponententeil einbinden. Schau mal in den Source zu TLabledEdit, da wird das auch so gemacht. :idea:

cu
Narses

_________________
There are 10 types of people - those who understand binary and those who don´t.

galagher · Verfasst: Mo 29.10.07 18:34

Ich krieg's nicht hin. Jetzt brich das Programm mit der Meldung ab:
---------------------------
Anwendungsfehler
---------------------------
Exception EReadError in Modul Project1.exe bei 0001CDD3.

Fehler beim Lesen von LabeledImage1.Left: Zugriffsverletzung bei Adresse 00458DCC in Modul 'Project1.exe'. Lesen von Adresse 00000000.

Es gibt ein property Caption, aber kein Label. Gibt's ein label, wird dieses nicht gezeigt. Gibt's ein TBoundLabel, kann dieses keinen Text aufnehmen. Ich dachte einfach, ich erzeuge ein Label, definiere LabeledImage als Parent und das ist es. Geht aber nicht!

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

galagher · Verfasst: Di 30.10.07 18:45

Hallo!

Kann mir jemand sagen, warum das schon beim Auf-die-Form-ziehen einen Fehler verursacht, sich aber problemlos als visuelle Kompo installieren liess? Fehlermeldung:
Zugriffsverletzung bei Adresse 401059B0 in Modul 'vcl60.bpl'. Lesen von Adresse 00000048.

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:

{-------------------------------------------------------------------------------
 TLabeledImage - Image mit Label. Basierend auf dem Code von Narses vom
 Delphi-Forum.
 http://www.delphi-forum.de/viewtopic.php?p=469135
-------------------------------------------------------------------------------}


unit LabeledImage;

interface

uses
  SysUtils, Classes, Graphics, Controls, StdCtrls, ExtCtrls;

type
  TLabeledImage = class(TImage)
  private
    FLabel: TLabel;
    FCaption: String;
    FCaptionTop: Integer;
    procedure SetCaption(const Value: String);
    procedure SetCaptionTop(Value: Integer);
    function GetTop: Integer;
    procedure SetTop(const Value: Integer);
    function GetLeft: Integer;
    procedure SetLeft(const Value: Integer);
    function GetWidth: Integer;
    procedure SetWidth(const Value: Integer);
    function GetHeight: Integer;
    procedure SetHeight(const Value: Integer);
  protected
    procedure SetName(const Value: TComponentName); override;
  public
    constructor Create(AOwner: TComponent); reintroduce;
    destructor Destroy; override;
    procedure Paint; override;
  published
    property Caption: String read FCaption write SetCaption;
    property CaptionTop: Integer read FCaptionTop write SetCaptionTop;
    property Top: Integer read GetTop write SetTop;
    property Left: Integer read GetLeft write SetLeft;
    property Width: Integer read GetWidth write SetWidth;
    property Height: Integer read GetHeight write SetHeight;
   end;

procedure Register;

implementation

constructor TLabeledImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
//  Parent := TWinControl(AOwner);
  FLabel := TLabel.Create(AOwner);
//  FLabel.Parent := TWinControl(AOwner);
end;

destructor TLabeledImage.Destroy;
begin
 Flabel.Free;

 inherited;
end;

procedure TLabeledImage.Paint;
begin
 inherited;

 FLabel.Top := Top+Height+FCaptionTop;
end;

procedure TLabeledImage.SetCaption(const Value: String);
begin
 FCaption := Value;

 FLabel.Caption := Value;

 Invalidate;
end;

procedure TLabeledImage.SetCaptionTop(Value: Integer);
begin
 FCaptionTop := Value;
 Paint;
end;

function TLabeledImage.GetTop: Integer;
begin
 Result := inherited Top;
end;

procedure TLabeledImage.SetTop(const Value: Integer);
begin
 inherited Top := Value;
end;

function TLabeledImage.GetLeft: Integer;
begin
 Result := inherited Left;
end;

procedure TLabeledImage.SetLeft(const Value: Integer);
begin
  inherited Left := Value;
  FLabel.Left := Value;
end;

function TLabeledImage.GetWidth: Integer;
begin
  Result := inherited Width;
end;

procedure TLabeledImage.SetWidth(const Value: Integer);
begin
  inherited Width := Value;
  FLabel.Width := Value;
end;

function TLabeledImage.GetHeight: Integer;
begin
  Result := inherited Height;
end;

procedure TLabeledImage.SetHeight(const Value: Integer);
begin
  inherited Height := Value;
end;

procedure TLabeledImage.SetName(const Value: TComponentName);
var OldName: TComponentName;
begin
  OldName := Name; inherited SetName(Value);
  if FLabel.Caption = OldName then Flabel.Caption := Value;
end;

procedure Register;
begin
 RegisterComponents('Diverses', [TLabeledImage]);
end;


end.

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

galagher · Verfasst: Mi 31.10.07 18:14

galagher hat folgendes geschrieben:

Kann mir jemand sagen, warum das schon beim Auf-die-Form-ziehen einen Fehler verursacht, sich aber problemlos als visuelle Kompo installieren liess?

... weil der Code zwar syntaktisch, aber nicht logisch bzw. funktional korrekt ist! Hier die vorerst fertige Komponente, für Änderungen/Verbesserungen/Korrekturen bin ich offen und dankbar!

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:

{-------------------------------------------------------------------------------
 TLabeledImage - Image mit Label, basierend auf dem Code von Narses vom
 Delphi-Forum.

 Diesen Code kann jeder benutzen, verändern und tun damit, was er will!

 galagher, 31.10.2007
-------------------------------------------------------------------------------}


unit LabeledImage;

interface

uses
  SysUtils, Classes, Graphics, Controls, StdCtrls, ExtCtrls;

type
  TLabeledImage = class(TImage)
  private
    FLabel: TLabel;
    FCaption: String;
    FCaptionTop: Integer;
    FColor: TColor;
    FFont: TFont;
    FCaptionTransparent: Boolean;
    FCaptionShowHint: Boolean;
    FShowAccelChar: Boolean;
    FPassCaptionWidth: Boolean;
    procedure SetCaption(const Value: String);
    procedure SetCaptionTop(Value: Integer);
    procedure SetColor(Value: TColor);
    function GetFont: TFont;
    procedure SetFont(const Value: TFont);
    procedure SetCaptionTransparent(Value: Boolean);
    procedure SetCaptionShowHint(Value: Boolean);
    procedure SetShowAccelChar(Value: Boolean);
    procedure SetPassCaptionWidth(Value: Boolean);
    procedure LabelClick(Sender: TObject);
    procedure LabelMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure LabelMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure LabelMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure LabelDblClick(Sender: TObject);
  protected
    procedure Paint; override;
    procedure SetName(const Value: TComponentName); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Caption: String read FCaption write SetCaption;
    property CaptionTop: Integer read FCaptionTop write SetCaptionTop;
    property CaptionColor: TColor read FColor write SetColor;
    property CaptionFont: TFont read GetFont write SetFont;
    property CaptionTransparent: Boolean read FCaptionTransparent write SetCaptionTransparent;
    property CaptionShowHint: Boolean read FCaptionShowHint write SetCaptionShowHint;
    property ShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar;
    property PassCaptionWidth: Boolean read FPassCaptionWidth write SetPassCaptionWidth;
  end;

procedure Register;

implementation

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

 FLabel := TLabel.Create(Self);
 FLabel.Parent := TWinControl(AOwner);

 CaptionColor := clBtnFace;
 CaptionShowHint := True;

 FLabel.ShowHint := True;

 FLabel.OnClick := LabelClick;
 Flabel.OnMouseMove := LabelMouseMove;
 FLabel.OnMouseUp := LabelMouseUp;
 FLabel.OnMouseDown := LabelMouseDown;
 FLabel.OnDblClick := LabelDblClick;
end;

destructor TLabeledImage.Destroy;
begin
 Flabel.Free;

 inherited;
end;

procedure TLabeledImage.Paint;
begin
 inherited;

 FLabel.Top := Top+Height+FCaptionTop;
 Flabel.Left := Left;
 if FPassCaptionWidth then Flabel.Width := Width;
end;

procedure TLabeledImage.SetCaption(const Value: String);
begin
 FCaption := Value;
 FLabel.Caption := Value;
end;

procedure TLabeledImage.SetCaptionTop(Value: Integer);
begin
 FCaptionTop := Value;
 Paint;
end;

procedure TLabeledImage.SetColor(Value: TColor);
begin
 FColor := Value;
 FLabel.Color := Value;
end;

function TLabeledImage.GetFont: TFont;
begin
 Result := FLabel.Font;
end;

procedure TLabeledImage.SetFont(const Value: TFont);
begin
 FFont := Value;
 FLabel.Font := Value;
end;

procedure TLabeledImage.SetCaptionTransparent(Value: Boolean);
begin
 FCaptionTransparent := Value;
 FLabel.Transparent := Value;
end;

procedure TLabeledImage.SetCaptionShowHint(Value: Boolean);
begin
 FCaptionShowHint := Value;
 FLabel.ShowHint := Value;
end;

procedure TLabeledImage.SetShowAccelChar(Value: Boolean);
begin
 FShowAccelChar := Value;
 FLabel.ShowAccelChar := Value;
end;

procedure TLabeledImage.SetPassCaptionWidth(Value: Boolean);
begin
 FPassCaptionWidth := Value;
 Paint;
end;

procedure TLabeledImage.LabelClick(Sender: TObject);
begin
 Click;
end;

procedure TLabeledImage.LabelMouseMove;
begin
 FLabel.Hint := Hint;
 FLabel.Cursor := Cursor;
 if Assigned(OnMouseMove) then OnMouseMove(Self, Shift, X, Y); 
end;

procedure TLabeledImage.LabelMouseUp;
begin
 if Assigned(OnMouseUp) then OnMouseUp(Self, Button, Shift, X, Y);
end;

procedure TLabeledImage.LabelMouseDown;
begin
 FLabel.PopupMenu := PopupMenu;
 if Assigned(OnMouseDown) then OnMouseDown(Self, Button, Shift, X, Y);
end;

procedure TLabeledImage.LabelDblClick(Sender: TObject);
begin
 if Assigned(OnDblClick) then OnDblClick(Self);
end;

procedure TLabeledImage.SetName(const Value: TComponentName);
begin
 inherited SetName(Value);

 FLabel.Caption := Value;
 Caption := Value;
end;

procedure Register;
begin
 RegisterComponents('Diverses', [TLabeledImage]);
end;

end.

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

galagher · Verfasst: Do 01.11.07 09:40

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:

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

 FLabel := TLabel.Create(Self);
 FLabel.Parent := TWinControl(AOwner);  //Das Formular! Und zwar immer, egal, auf welcher Kompo das LabeledImage liegt!

Wie kriege ich es hin, dass FLabel.Parent nicht immer das Formular ist, sondern die Koponente, zB. ein Panel, auf dem das LabeledImage liegt? Ist doch unschön, wenn das Label irgendwo links daneben auf der Form ist anstatt auch auf dem Panel!

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

galagher · Verfasst: Do 01.11.07 11:22

Wenn ich FLabel.Parent := Parent im Create schreibe, nützt das nichts. Man muss Parent anders setzen:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:

procedure TLabeledImage.SetParent(AParent: TWinControl);
begin
 inherited SetParent(AParent);
 FLabel.Parent := AParent;
end;

So klappt es auch, aber beim Beenden des Programms oder beim Entfernen der Komponente aus dem Formular zur Designzeit kommt es zu einem Fehler, und zwar beim Beenden:
Exception EAccessViolation in Modul Project1.exe bei 0002261D.
Zugriffsverletzung bei Adresse 0042261D in Modul 'Project1.exe'. Schreiben von Adresse 7ACB0E13.

Beim Entfernen:
Zugriffsverletzung bei Adresse 6562614C. Lesen von Adresse 6562614C.
oder auch:
[...] privilegierte Anweisung [...]

Wie bekomme ich das sauber hin?

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

galagher · Verfasst: Do 01.11.07 17:16

Egal, wo man Parent ändert, es kommt beim Beenden des Programs oder wenn man das LabeledImage von der Form entfernen will immer zu Fehlern.

galagher hat folgendes geschrieben:

markieren

Delphi-Quelltext

1:
2:
3:
4:

procedure TLabeledImage.Sonstwas;
begin
 FLabel.Parent := Parent;
end;

Und im Create wird Flabel nicht angezeigt, wenn Parent so zugwiesen wird:
FLabel.Parent := Parent;
Bei FLabel.Parent := TWinControl(AOwner); gilt dann die Form als Parent.
Jede Parent-Zuweisung, egal wo, ausser im Create führt zu den obigen Fehlern. Es muss irgendwas mit dem Destroy von FLabel zu tun haben, aber wenn ich das Destroy weglasse, ändert das nichts.

Ich möchte doch nur statt der Form einfach die der Komponente übergeordnete Kompo als Parent, also zB ein Panel, auf dem das LabeledImage liegt!
Das Beispielbild zeigt, was ich meine - LabeledImage2 liegt auf Form1 und wird korrekt dargestellt. LabeledImage1 liegt auf einem Panel und wird nicht wie erwartet dargestellt - das Label mit der Beschriftung "LabeledImage1' erscheint auf Form1 statt auf Panel1:

Einloggen, um Attachments anzusehen!

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

galagher · Verfasst: Fr 02.11.07 17:06

Alle Probleme gelöst! Hier die fertige Kompo:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:

{-------------------------------------------------------------------------------
 TLabeledImage - Image mit Label, basierend auf dem Code von Narses vom
 Delphi-Forum.
 Diesen Code kann jeder benutzen, verändern und tun damit, was er will!
 galagher, November 2007
-------------------------------------------------------------------------------}
unit LabeledImage;

interface

uses
  Windows, SysUtils, Classes, Graphics, Controls, StdCtrls, ExtCtrls;

type
  TLabeledImage = class(TImage)
  private
    FLabel: TLabel;
    FCaption: String;
    FCaptionVisible: Boolean;
    FCaptionBelow: Boolean;
    FCaptionTop: Integer;
    FColor: TColor;
    FFont: TFont;
    FCaptionTransparent: Boolean;
    FCaptionShowHint: Boolean;
    FShowAccelChar: Boolean;
    FPassCaptionWidth: Boolean;
    procedure SetCaption(const Value: String);
    procedure SetCaptionVisible(Value: Boolean);
    procedure SetCaptionBelow(Value: Boolean);
    procedure SetCaptionTop(Value: Integer);
    procedure SetColor(Value: TColor);
    function GetFont: TFont;
    procedure SetFont(const Value: TFont);
    procedure SetCaptionTransparent(Value: Boolean);
    procedure SetCaptionShowHint(Value: Boolean);
    procedure SetShowAccelChar(Value: Boolean);
    procedure SetPassCaptionWidth(Value: Boolean);
    procedure LabelClick(Sender: TObject);
    procedure LabelMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure LabelMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure LabelMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure LabelDblClick(Sender: TObject);
  protected
    procedure Paint; override;
    procedure SetName(const Value: TComponentName); override;
    procedure SetParent(AParent: TWinControl); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Caption: String read FCaption write SetCaption;
    property CaptionVisible: Boolean read FCaptionVisible write SetCaptionVisible;
    property CaptionBelow: Boolean read FCaptionBelow write SetCaptionBelow;
    property CaptionTop: Integer read FCaptionTop write SetCaptionTop;
    property CaptionColor: TColor read FColor write SetColor;
    property CaptionFont: TFont read GetFont write SetFont;
    property CaptionTransparent: Boolean read FCaptionTransparent write SetCaptionTransparent;
    property CaptionShowHint: Boolean read FCaptionShowHint write SetCaptionShowHint;
    property CaptionShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar;
    property CaptionPassWidth: Boolean read FPassCaptionWidth write SetPassCaptionWidth;
    procedure ScaleImage(aWidth, aHeight: Integer);
  end;

procedure Register;

implementation

constructor TLabeledImage.Create(AOwner: TComponent);
begin
 inherited;
end;

destructor TLabeledImage.Destroy;
begin
 inherited;
end;

procedure TLabeledImage.SetCaption(const Value: String);
begin
 FCaption := Value;
 FLabel.Caption := Value;
 Paint;
end;

procedure TLabeledImage.SetCaptionVisible(Value: Boolean);
begin
 FCaptionVisible := Value;
 Paint;
end;

procedure TLabeledImage.SetCaptionBelow(Value: Boolean);
begin
 FCaptionBelow := Value;
 Paint;
end;

procedure TLabeledImage.SetCaptionTop(Value: Integer);
begin
 FCaptionTop := Value;
 Paint;
end;

procedure TLabeledImage.SetColor(Value: TColor);
begin
 FColor := Value;
 FLabel.Color := Value;
end;

function TLabeledImage.GetFont: TFont;
begin
 Result := FLabel.Font;
end;

procedure TLabeledImage.SetFont(const Value: TFont);
begin
 FFont := Value;
 FLabel.Font := Value;
end;

procedure TLabeledImage.SetCaptionTransparent(Value: Boolean);
begin
 FCaptionTransparent := Value;
 FLabel.Transparent := Value;
end;

procedure TLabeledImage.SetCaptionShowHint(Value: Boolean);
begin
 FCaptionShowHint := Value;
 FLabel.ShowHint := Value;
end;

procedure TLabeledImage.SetShowAccelChar(Value: Boolean);
begin
 FShowAccelChar := Value;
 FLabel.ShowAccelChar := Value;
end;

procedure TLabeledImage.SetPassCaptionWidth(Value: Boolean);
begin
 FPassCaptionWidth := Value;
 Paint;
end;

procedure TLabeledImage.ScaleImage(aWidth, aHeight: Integer);
var
  W, H: Double;
  L, T: Integer;
  aRect: TRect;
  aImage: TImage;
begin
 aImage := TImage.Create(Self);

 aImage.Canvas.Brush.Color := FColor;
 aImage.Canvas.FloodFill(0, 0, FColor, fsBorder);

 W := Picture.Width;
 H := Picture.Height;

 while (W > aWidth) or (H > aHeight) do
 begin
  W := W / 1.01;
  H := H / 1.01;
 end;

 L := aWidth+1;
 T := aHeight+1;

 L := L mod Trunc(W) div 2;
 T := T mod Trunc(H) div 2;

 aRect := Rect(L, T, Trunc(W)+L, Trunc(H)+T);

 aImage.Canvas.CopyMode := cmSrcCopy;
 aImage.Canvas.StretchDraw(aRect, Picture.Graphic);

 Picture := aImage.Picture;

 Width := aRect.Right;
 Height := aRect.Bottom;

 aImage.Free;
end;

procedure TLabeledImage.LabelClick(Sender: TObject);
begin
 Click;
end;

procedure TLabeledImage.LabelMouseMove;
begin
 FLabel.Hint := Hint;
 FLabel.Cursor := Cursor;
 if Assigned(OnMouseMove) then OnMouseMove(Self, Shift, X, Y); 
end;

procedure TLabeledImage.LabelMouseUp;
begin
 if Assigned(OnMouseUp) then OnMouseUp(Self, Button, Shift, X, Y);
end;

procedure TLabeledImage.LabelMouseDown;
begin
 FLabel.PopupMenu := PopupMenu;
 if Assigned(OnMouseDown) then OnMouseDown(Self, Button, Shift, X, Y);
end;

procedure TLabeledImage.LabelDblClick(Sender: TObject);
begin
 if Assigned(OnDblClick) then OnDblClick(Self);
end;

procedure TLabeledImage.Paint;
begin
 inherited;

 Flabel.Visible := FCaptionVisible;

 if not FCaptionVisible then exit;

 if FCaptionBelow then
  FLabel.Top := Top+Height+FCaptionTop
 else
  FLabel.Top := Top-FLabel.Height-FCaptionTop;

 Flabel.Left := Left;
 if FPassCaptionWidth then Flabel.Width := Width;
end;

procedure TLabeledImage.SetName(const Value: TComponentName);
begin
 inherited SetName(Value);

 FLabel.Caption := Value;
 Caption := Value;
end;

procedure TLabeledImage.SetParent(AParent: TWinControl);
begin
 inherited SetParent(AParent);

 if Assigned(FLabel) then exit;

 FLabel := TLabel.Create(Self);
 FLabel.Parent := AParent;
 FLabel.ShowHint := True;
 FLabel.OnClick := LabelClick;
 Flabel.OnMouseMove := LabelMouseMove;
 FLabel.OnMouseUp := LabelMouseUp;
 FLabel.OnMouseDown := LabelMouseDown;
 FLabel.OnDblClick := LabelDblClick;

 CaptionColor := clBtnFace;
 CaptionShowHint := True;
 CaptionBelow := True;
 CaptionVisible := True;
 FCaptionBelow := True;
 FCaptionVisible := True;
end;

procedure Register;
begin
 RegisterComponents('Diverses', [TLabeledImage]);
end;

end.

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

Narses · Verfasst: Fr 02.11.07 17:29

Moin!

galagher hat folgendes geschrieben:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:

constructor TLabeledImage.Create(AOwner: TComponent);
begin
 inherited;
end;

destructor TLabeledImage.Destroy;
begin
 inherited;
end;

Die Methoden sind "leer", dann kannst du sie auch ganz weglassen. :idea:

cu
Narses

_________________
There are 10 types of people - those who understand binary and those who don´t.

galagher · Verfasst: Fr 02.11.07 19:44

Narses hat folgendes geschrieben:

Die Methoden sind "leer", dann kannst du sie auch ganz weglassen. :idea:

Danke!
Vielleicht weisst du ja auch Rat bei einem kleinen Schönheitsfehler: Wenn Picture leer ist und man die Prozedur ScaleImage aufruft, kommt "Division durch Null"! Es ist auch nicht möglich, if Picture = nil then exit oder if Picture.Graphic.Empty then exit anzugeben, da schon allein das den Fehler verursacht. In welchem "Zustand" ist denn ein TImage das a) nie ein Bild geladen hatte oder b) dem per Picture := nil das Bild entzogen wurde?

Ansonsten sollte man die Prozedur immer in einem try/except-Block ausführen, oder man prüft vorher, ob Picture = nil.

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme