source: trunk/Packages/CevoComponents/DrawDlg.pas@ 336

Last change on this file since 336 was 336, checked in by chronos, 8 months ago
  • Modify: Change Notify function to have separate enumeration type and integer value. Previously was combined into single integer.
  • Fixed: Paint correctly loading progress dialog on Linux.
File size: 8.5 KB
Line 
1unit DrawDlg;
2
3{$mode delphi}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, Forms, LCLIntf, LCLType, {$IFDEF LINUX}LMessages,{$ENDIF}
9 Messages, Graphics, Controls, ButtonBase, ButtonA, ButtonB, Area, ScreenTools;
10
11type
12 { TDrawDlg }
13
14 TDrawDlg = class(TForm)
15 private
16 MoveFormPos: TPoint;
17 MoveMousePos: TPoint;
18 MoveActive: Boolean;
19 procedure VisibleChangedHandler(Sender: TObject);
20 procedure DoDeactivate(Sender: TObject);
21 protected
22 TitleHeight: Integer;
23 // defines area to grip the window for moving (from top)
24 procedure InitButtons;
25 procedure OnEraseBkgnd(var m: TMessage); message WM_ERASEBKGND;
26 procedure OnHitTest(var Msg: TMessage); message WM_NCHITTEST;
27 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
28 override;
29 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
30 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
31 procedure MouseLeave; override;
32 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
33 public
34 constructor Create(AOwner: TComponent); override;
35 destructor Destroy; override;
36 procedure SmartInvalidate; virtual;
37 end;
38
39 { TBaseMessgDlg }
40
41 TBaseMessgDlg = class(TDrawDlg)
42 procedure FormCreate(Sender: TObject);
43 procedure FormPaint(Sender: TObject);
44 public
45 MessgText: string;
46 protected
47 Lines, TopSpace: integer;
48 procedure SplitText(preview: boolean);
49 procedure CorrectHeight;
50 end;
51
52const
53 Border = 3;
54 MessageLineSpacing = 20;
55
56procedure Register;
57
58
59implementation
60
61procedure Register;
62begin
63 RegisterNoIcon([TDrawDlg]);
64 RegisterNoIcon([TBaseMessgDlg]);
65end;
66
67{ TDrawDlg }
68
69constructor TDrawDlg.Create(AOwner: TComponent);
70begin
71 inherited;
72 TitleHeight := 0;
73 MoveActive := False;
74 AddHandlerOnVisibleChanged(VisibleChangedHandler);
75 {$IFDEF LINUX}
76 OnDeactivate := DoDeactivate;
77 {$ENDIF}
78end;
79
80destructor TDrawDlg.Destroy;
81begin
82 RemoveHandlerOnVisibleChanged(VisibleChangedHandler);
83 inherited;
84end;
85
86procedure TDrawDlg.OnEraseBkgnd(var m: TMessage);
87begin
88 // Full area should be covered by Paint method
89end;
90
91procedure TDrawDlg.OnHitTest(var Msg: TMessage);
92var
93 I: integer;
94 ControlBounds: TRect;
95 Pos: TPoint;
96begin
97 if BorderStyle <> bsNone then
98 inherited
99 else
100 begin
101 Pos := Point(Integer(Msg.LParam and $ffff),
102 Integer((Msg.LParam shr 16) and $ffff));
103 if Pos.Y >= Top + TitleHeight then
104 Msg.Result := HTCLIENT
105 else
106 begin
107 for I := 0 to ControlCount - 1 do
108 if Controls[I].Visible then
109 begin
110 ControlBounds := Controls[I].BoundsRect;
111 if (Pos.X >= Left + ControlBounds.Left) and
112 (Pos.X < Left + ControlBounds.Right) and
113 (Pos.Y >= Top + ControlBounds.Top) and
114 (Pos.Y < Top + ControlBounds.Bottom) then
115 begin
116 Msg.result := HTCLIENT;
117 Exit;
118 end;
119 end;
120 Msg.Result := HTCAPTION
121 end;
122 end;
123end;
124
125procedure TDrawDlg.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
126 Y: Integer);
127{$IFDEF LINUX}
128var
129 MousePosNew: TPoint;
130 NewFormPos: TPoint;
131{$ENDIF}
132begin
133 inherited;
134 {$IFDEF LINUX}
135 // Only if client is not doing own mouse move handling
136 if not Assigned(OnMouseDown) or not Assigned(OnMouseMove) or not Assigned(OnMouseUp) then begin
137 // HitTest is not supported under Linux GTK2 so use form inside move mechanizm
138 NewFormPos := ScreenToClient(Mouse.CursorPos);
139 if (NewFormPos.X >= 0) and (NewFormPos.X < Width) and
140 (NewFormPos.Y >= 0) and (NewFormPos.Y < Height) then begin
141 MoveMousePos := ClientToScreen(Point(X, Y));
142 MoveFormPos := Point(Left, Top);
143 MousePosNew := Mouse.CursorPos;
144 // Activate move only if mouse position was not changed during inherited call
145 if (MousePosNew.X = MoveMousePos.X) and (MousePosNew.Y = MoveMousePos.Y) then begin
146 MoveActive := True;
147 end;
148 end else MoveActive := False;
149 end;
150 {$ENDIF}
151end;
152
153procedure TDrawDlg.MouseMove(Shift: TShiftState; X, Y: Integer);
154var
155 MousePos: TPoint;
156begin
157 inherited;
158 if MoveActive then begin
159 MousePos := ClientToScreen(Point(X, Y));
160 SetBounds(MoveFormPos.X + MousePos.X - MoveMousePos.X,
161 MoveFormPos.Y + MousePos.Y - MoveMousePos.Y,
162 Width, Height);
163 end;
164end;
165
166procedure TDrawDlg.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
167 Y: Integer);
168begin
169 MoveActive := False;
170 inherited;
171end;
172
173procedure TDrawDlg.MouseLeave;
174begin
175 MoveActive := False;
176 inherited;
177end;
178
179procedure TDrawDlg.KeyDown(var Key: Word; Shift: TShiftState);
180begin
181 if Key = VK_ESCAPE then Close;
182 inherited;
183end;
184
185procedure TDrawDlg.VisibleChangedHandler(Sender: TObject);
186begin
187 MoveActive := False;
188end;
189
190procedure TDrawDlg.DoDeactivate(Sender: TObject);
191begin
192 MoveActive := False;
193end;
194
195procedure TDrawDlg.InitButtons;
196var
197 cix: integer;
198 // ButtonDownSound, ButtonUpSound: string;
199begin
200 // ButtonDownSound := Sounds.Lookup('BUTTON_DOWN');
201 // ButtonUpSound := Sounds.Lookup('BUTTON_UP');
202 for cix := 0 to ComponentCount - 1 do
203 if Components[cix] is TButtonBase then
204 begin
205 TButtonBase(Components[cix]).Graphic := HGrSystem.Data;
206 // if ButtonDownSound <> '*' then
207 // DownSound := GetSoundsDir + DirectorySeparator + ButtonDownSound + '.wav';
208 // if ButtonUpSound <> '*' then
209 // UpSound := GetSoundsDir + DirectorySeparator + ButtonUpSound + '.wav';
210 if Components[cix] is TButtonA then
211 TButtonA(Components[cix]).Font := UniFont[ftButton];
212 if Components[cix] is TButtonB then
213 TButtonB(Components[cix]).Mask := HGrSystem.Mask;
214 end;
215end;
216
217procedure TDrawDlg.SmartInvalidate;
218var
219 i: integer;
220 r0, r1: HRgn;
221begin
222 r0 := CreateRectRgn(0, 0, ClientWidth, ClientHeight);
223 for i := 0 to ControlCount - 1 do
224 if not(Controls[i] is TArea) and Controls[i].Visible then
225 begin
226 with Controls[i].BoundsRect do
227 r1 := CreateRectRgn(Left, Top, Right, Bottom);
228 CombineRgn(r0, r0, r1, RGN_DIFF);
229 DeleteObject(r1);
230 end;
231 InvalidateRgn(Handle, r0, false);
232 DeleteObject(r0);
233end;
234
235{ TBaseMessgDlg }
236
237procedure TBaseMessgDlg.FormCreate(Sender: TObject);
238begin
239 Left := (Screen.Width - Width) div 2;
240 Canvas.Font.Assign(UniFont[ftNormal]);
241 Canvas.Brush.Style := bsClear;
242 MessgText := '';
243 TopSpace := 0;
244 TitleHeight := Screen.Height;
245 if csDesigning in ComponentState then Exit;
246 InitButtons;
247end;
248
249procedure TBaseMessgDlg.FormPaint(Sender: TObject);
250var
251 i, cix: integer;
252begin
253 if csDesigning in ComponentState then Exit;
254 PaintBackground(self, 3 + Border, 3 + Border, ClientWidth - (6 + 2 * Border),
255 ClientHeight - (6 + 2 * Border));
256 for i := 0 to Border do
257 Frame(Canvas, i, i, ClientWidth - 1 - i, ClientHeight - 1 - i,
258 $000000, $000000);
259 Frame(Canvas, Border + 1, Border + 1, ClientWidth - (2 + Border),
260 ClientHeight - (2 + Border), MainTexture.clBevelLight,
261 MainTexture.clBevelShade);
262 Frame(Canvas, 2 + Border, 2 + Border, ClientWidth - (3 + Border),
263 ClientHeight - (3 + Border), MainTexture.clBevelLight,
264 MainTexture.clBevelShade);
265 SplitText(false);
266
267 for cix := 0 to ControlCount - 1 do
268 if (Controls[cix].Visible) and (Controls[cix] is TButtonBase) then
269 BtnFrame(Canvas, Controls[cix].BoundsRect, MainTexture);
270end;
271
272procedure TBaseMessgDlg.SplitText(preview: boolean);
273var
274 Start, Stop, OrdinaryStop, LinesCount: integer;
275 s: string;
276begin
277 Start := 1;
278 LinesCount := 0;
279 while Start < Length(MessgText) do
280 begin
281 Stop := Start;
282 while (Stop < Length(MessgText)) and (MessgText[Stop] <> '\') and
283 (BiColorTextWidth(Canvas, Copy(MessgText, Start, Stop - Start + 1)) <
284 ClientWidth - 56) do
285 inc(Stop);
286 if Stop <> Length(MessgText) then
287 begin
288 OrdinaryStop := Stop;
289 repeat
290 dec(OrdinaryStop)
291 until (MessgText[OrdinaryStop + 1] = ' ') or
292 (MessgText[OrdinaryStop + 1] = '\');
293 if (OrdinaryStop + 1 - Start) * 2 >= Stop - Start then
294 Stop := OrdinaryStop
295 end;
296 if not preview then
297 begin
298 s := Copy(MessgText, Start, Stop - Start + 1);
299 LoweredTextOut(Canvas, -1, MainTexture,
300 (ClientWidth - BiColorTextWidth(Canvas, s)) div 2,
301 19 + Border + TopSpace + LinesCount * MessageLineSpacing, s);
302 end;
303 Start := Stop + 2;
304 inc(LinesCount)
305 end;
306 if preview then
307 Lines := LinesCount;
308end;
309
310procedure TBaseMessgDlg.CorrectHeight;
311var
312 i: integer;
313begin
314 ClientHeight := 72 + Border + TopSpace + Lines * MessageLineSpacing;
315 Top := (Screen.Height - ClientHeight) div 2;
316 for i := 0 to ControlCount - 1 do
317 Controls[i].Top := ClientHeight - (34 + Border);
318end;
319
320end.
321
Note: See TracBrowser for help on using the repository browser.