source: cprs/branches/tmg-cprs/TPNGGraphics/pngextra.pas@ 1620

Last change on this file since 1620 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69

File size: 8.9 KB
Line 
1unit pngextra;
2
3interface
4
5uses
6 Windows, Graphics, Messages, SysUtils, Classes, Controls, pngimage, Buttons,
7 ExtCtrls;
8
9type
10 TPNGButtonStyle = (pbsDefault, pbsFlat);
11 TPNGButtonLayout = (pbsImageAbove, pbsImageBellow);
12 TPNGButtonState = (pbsNormal, pbsDown, pbsDisabled);
13
14 TPNGButton = class(TGraphicControl)
15 private
16 {Holds the property values}
17 fButtonStyle: TPNGButtonStyle;
18 fMouseOverControl: Boolean;
19 FCaption: String;
20 FButtonLayout: TPNGButtonLayout;
21 FButtonState: TPNGButtonState;
22 FImageDown: TPNGObject;
23 fImageNormal: TPNGObject;
24 fImageDisabled: TPNGObject;
25 fImageOver: TPNGObject;
26 {Procedures for setting the property values}
27 procedure SetButtonStyle(const Value: TPNGButtonStyle);
28 procedure SetCaption(const Value: String);
29 procedure SetButtonLayout(const Value: TPNGButtonLayout);
30 procedure SetButtonState(const Value: TPNGButtonState);
31 procedure SetImageNormal(const Value: TPNGObject);
32 procedure SetImageDown(const Value: TPNGObject);
33 procedure SetImageOver(const Value: TPNGObject);
34 published
35 {Published properties}
36 property Font;
37 property Visible;
38 property ButtonLayout: TPNGButtonLayout read FButtonLayout write SetButtonLayout;
39 property Caption: String read FCaption write SetCaption;
40 property ImageNormal: TPNGObject read fImageNormal write SetImageNormal;
41 property ImageDown: TPNGObject read FImageDown write SetImageDown;
42 property ImageOver: TPNGObject read FImageOver write SetImageOver;
43 property ButtonStyle: TPNGButtonStyle read fButtonStyle
44 write SetButtonStyle;
45 property Enabled;
46 {Default events}
47 property OnMouseDown;
48 property OnClick;
49 property OnMouseUp;
50 property OnMouseMove;
51 property OnDblClick;
52 public
53 {Public properties}
54 property ButtonState: TPNGButtonState read FButtonState write SetButtonState;
55 protected
56 {Being painted}
57 procedure Paint; override;
58 {Clicked}
59 procedure Click; override;
60 {Mouse pressed}
61 procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
62 X, Y: Integer); override;
63 procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
64 X, Y: Integer); override;
65 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
66 {Mouse entering or leaving}
67 procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
68 procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
69 {Being enabled or disabled}
70 procedure CMEnabledChanged(var Message: TMessage);
71 message CM_ENABLEDCHANGED;
72 public
73 {Returns if the mouse is over the control}
74 property IsMouseOver: Boolean read fMouseOverControl;
75 {Constructor and destructor}
76 constructor Create(AOwner: TComponent); override;
77 destructor Destroy; override;
78 end;
79
80procedure Register;
81procedure MakeImageHalfTransparent(Source, Dest: TPNGObject);
82
83implementation
84
85procedure Register;
86begin
87 RegisterComponents('Samples', [TPNGButton]);
88end;
89
90procedure MakeImageHalfTransparent(Source, Dest: TPNGObject);
91var
92 i, j: Integer;
93begin
94 Dest.Assign(Source);
95 Dest.CreateAlpha;
96 if (Dest.Header.ColorType <> COLOR_PALETTE) then
97 for j := 0 to Source.Height - 1 do
98 for i := 0 to Source.Width - 1 do
99 Dest.AlphaScanline[j]^[i] := Dest.AlphaScanline[j]^[i] div 3;
100end;
101
102{TPNGButton implementation}
103
104{Being created}
105constructor TPNGButton.Create(AOwner: TComponent);
106begin
107 {Calls ancestor}
108 inherited Create(AOwner);
109 {Creates the TPNGObjects}
110 fImageNormal := TPNGObject.Create;
111 fImageDown := TPNGObject.Create;
112 fImageDisabled := TPNGObject.Create;
113 fImageOver := TPNGObject.Create;
114 {Initial properties}
115 ControlStyle := ControlStyle + [csCaptureMouse];
116 SetBounds(Left, Top, 23, 23);
117 fMouseOverControl := False;
118 fButtonLayout := pbsImageAbove;
119 fButtonState := pbsNormal
120end;
121
122destructor TPNGButton.Destroy;
123begin
124 {Frees the TPNGObject}
125 fImageNormal.Free;
126 fImageDown.Free;
127 fImageDisabled.Free;
128 fImageOver.Free;
129
130 {Calls ancestor}
131 inherited Destroy;
132end;
133
134{Being enabled or disabled}
135procedure TPNGButton.CMEnabledChanged(var Message: TMessage);
136begin
137 if not Enabled then MakeImageHalfTransparent(fImageNormal, fImageDisabled);
138 if Enabled then ButtonState := pbsNormal else ButtonState := pbsDisabled
139end;
140
141{Button being painted}
142procedure TPNGButton.Paint;
143const
144 Slide: Array[false..true] of Integer = (0, 2);
145var
146 Area: TRect;
147 TextSize, ImageSize: TSize;
148 TextPos, ImagePos: TPoint;
149 Image: TPNGObject;
150 Pushed: Boolean;
151begin
152 {Prepares the canvas}
153 Canvas.Font.Assign(Font);
154
155 {Determines if the button is pushed}
156 Pushed := (ButtonState = pbsDown) and IsMouseOver;
157
158 {Determines the image to use}
159 if (Pushed) and not fImageDown.Empty then
160 Image := fImageDown
161 else if IsMouseOver and not fImageOver.Empty and Enabled then
162 Image := fImageOver
163 else if (ButtonState = pbsDisabled) and not fImageDisabled.Empty then
164 Image := fImageDisabled
165 else
166 Image := fImageNormal;
167
168 {Get the elements size}
169 ImageSize.cx := Image.Width;
170 ImageSize.cy := Image.Height;
171 Area := ClientRect;
172 if Caption <> '' then
173 begin
174 TextSize := Canvas.TextExtent(Caption);
175 ImageSize.cy := ImageSize.Cy + 4;
176 end;
177
178 {Set the elements position}
179 ImagePos.X := (Width - ImageSize.cx) div 2 + Slide[Pushed];
180 TextPos.X := (Width - TextSize.cx) div 2 + Slide[Pushed];
181 case ButtonLayout of
182 pbsImageAbove: begin
183 ImagePos.Y := (Height - ImageSize.cy - TextSize.cy) div 2;
184 TextPos.Y := ImagePos.Y + ImageSize.cy;
185 end;
186 pbsImageBellow: begin
187 TextPos.Y := (Height - ImageSize.cy - TextSize.cy) div 2;
188 ImagePos.Y := TextPos.Y + TextSize.cy;
189 end
190 end;
191 ImagePos.Y := ImagePos.Y + Slide[Pushed];
192 TextPos.Y := TextPos.Y + Slide[Pushed];
193
194 {Draws the border}
195 if ButtonStyle = pbsFlat then
196 begin
197 if ButtonState <> pbsDisabled then
198 if (Pushed) then
199 Frame3D(Canvas, Area, clBtnShadow, clBtnHighlight, 1)
200 else if IsMouseOver or (ButtonState = pbsDown) then
201 Frame3D(Canvas, Area, clBtnHighlight, clBtnShadow, 1)
202 end
203 else
204 DrawButtonFace(Canvas, Area, 1, bsNew, TRUE, Pushed, FALSE);
205
206 {Draws the elements}
207 Canvas.Brush.Style := bsClear;
208 Canvas.Draw(ImagePos.X, ImagePos.Y, Image);
209 if ButtonState = pbsDisabled then Canvas.Font.Color := clGrayText;
210 Canvas.TextRect(Area, TextPos.X, TextPos.Y, Caption)
211end;
212
213{Changing the button Layout property}
214procedure TPNGButton.SetButtonLayout(const Value: TPNGButtonLayout);
215begin
216 FButtonLayout := Value;
217 Repaint
218end;
219
220{Changing the button state property}
221procedure TPNGButton.SetButtonState(const Value: TPNGButtonState);
222begin
223 FButtonState := Value;
224 Repaint
225end;
226
227{Changing the button style property}
228procedure TPNGButton.SetButtonStyle(const Value: TPNGButtonStyle);
229begin
230 fButtonStyle := Value;
231 Repaint
232end;
233
234{Changing the caption property}
235procedure TPNGButton.SetCaption(const Value: String);
236begin
237 FCaption := Value;
238 Repaint
239end;
240
241{Changing the image property}
242procedure TPNGButton.SetImageNormal(const Value: TPNGObject);
243begin
244 fImageNormal.Assign(Value);
245 MakeImageHalfTransparent(fImageNormal, fImageDisabled);
246 Repaint
247end;
248
249{Setting the down image}
250procedure TPNGButton.SetImageDown(const Value: TPNGObject);
251begin
252 FImageDown.Assign(Value);
253 Repaint
254end;
255
256{Setting the over image}
257procedure TPNGButton.SetImageOver(const Value: TPNGObject);
258begin
259 fImageOver.Assign(Value);
260 Repaint
261end;
262
263{Mouse pressed}
264procedure TPNGButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
265 Y: Integer);
266begin
267 {Changes the state and repaints}
268 if (ButtonState = pbsNormal) and (Button = mbLeft) then
269 ButtonState := pbsDown;
270 {Calls ancestor}
271 inherited
272end;
273
274{Being clicked}
275procedure TPNGButton.Click;
276begin
277 if ButtonState = pbsDown then ButtonState := pbsNormal;
278 inherited Click;
279end;
280
281{Mouse released}
282procedure TPNGButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
283 Y: Integer);
284begin
285 {Changes the state and repaints}
286 if ButtonState = pbsDown then ButtonState := pbsNormal;
287 {Calls ancestor}
288 inherited
289end;
290
291{Mouse moving over the control}
292procedure TPNGButton.MouseMove(Shift: TShiftState; X, Y: Integer);
293begin
294 {In case cursor is over the button}
295 if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) and
296 (fMouseOverControl = False) and (ButtonState <> pbsDown) then
297 begin
298 fMouseOverControl := True;
299 Repaint;
300 end;
301
302 {Calls ancestor}
303 inherited;
304
305end;
306
307{Mouse is now over the control}
308procedure TPNGButton.CMMouseEnter(var Message: TMessage);
309begin
310 fMouseOverControl := True;
311 Repaint
312end;
313
314{Mouse has left the control}
315procedure TPNGButton.CMMouseLeave(var Message: TMessage);
316begin
317 fMouseOverControl := False;
318 Repaint
319end;
320
321
322end.
Note: See TracBrowser for help on using the repository browser.