source: trunk/Sibyl/Addon/HINTS.PAS@ 145

Last change on this file since 145 was 7, checked in by RBRi, 19 years ago

+ sibyl staff
  • Property svn:eol-style set to native
File size: 14.2 KB
Line 
1Unit Hints;
2
3
4Interface
5
6Uses
7 Classes,Forms;
8
9Type
10 {$M+}
11 TShadowStyle=(shsSolid,shsShadowed);
12 {$M-}
13
14 TCustomHint=Class(TComponent)
15 Private
16 FOutlined:BOOLEAN;
17 FOutlineColor:TColor;
18 FShadowSize:LONGINT;
19 FShadowStyle:TShadowStyle;
20 FShadowColor:TColor;
21 FHintPenColor:TColor;
22 FHintColor:TColor;
23 FMaxWidth:LONGINT;
24 FHintOrigin:THintOrigin;
25 Procedure SetShadowSize(NewValue:LONGINT);
26 Procedure SetHintOrigin(NewValue:THintOrigin);
27 Protected
28 Procedure SetupComponent;Override;
29 Public
30 Destructor Destroy;Override;
31 Published
32 Property Outlined:BOOLEAN read FOutlined write FOutLined;
33 Property OutlineColor:TColor read FOutlineColor write FOutlineColor;
34 Property ShadowSize:LONGINT read FShadowSize write SetShadowSize;
35 Property ShadowStyle:TShadowStyle read FShadowStyle write FShadowStyle;
36 Property ShadowColor:TColor read FShadowColor write FShadowColor;
37 Property HintPenColor:TColor read FHintPenColor write FHintPenColor;
38 Property HintColor:TColor read FHintColor write FHintColor;
39 Property MaxWidth:LONGINT read FMaxWidth write FMaxWidth;
40 Property Origin:THintOrigin read FHintOrigin write SetHintOrigin;
41 End;
42
43
44 {$M+}
45 TBalloonShape=(basRectangle,basRounded);
46 {$M-}
47
48 TBalloonHint=Class(TCustomHint)
49 Private
50 FBalloonShape:TBalloonShape;
51 Property Origin;
52 Protected
53 Procedure SetupComponent;Override;
54 Public
55 Destructor Destroy;Override;
56 Published
57 Property BalloonShape:TBalloonShape read FBalloonShape write FBalloonShape;
58 End;
59
60
61Implementation
62
63Const
64 CustomHint:TCustomHint=Nil;
65 BalloonHint:TBalloonHint=Nil;
66
67{
68ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
69º º
70º Speed-Pascal/2 Version 2.0 º
71º º
72º Speed-Pascal Component Classes (SPCC) º
73º º
74º This section: TCustomHintWindow Class implementation º
75º º
76º Last modified: September 1995 º
77º º
78º (C) 1995 SpeedSoft. All rights reserved. Disclosure probibited ! º
79º º
80ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
81}
82
83Type
84 TCustomHintWindow=Class(THintWindow)
85 Private
86 FCustomHint:TCustomHint;
87 Protected
88 Procedure SplitText(Bubble:String;Ret:TStrings;Var CX,CY:LONGINT);Virtual;
89 Procedure DrawBubbleShape(Const rec:TRect);Virtual;
90 Procedure DrawBubbleText(Const Bubble:String;Const rec:TRect);Virtual;
91 Public
92 Procedure Redraw(Const rec:TRect);Override;
93 Procedure ActivateHint(Rect:TRect; Const AHint:String);Override;
94 End;
95
96
97Procedure TCustomHintWindow.SplitText(Bubble:String;Ret:TStrings;Var CX,CY:LONGINT);
98Const
99 Separators:Set Of CHAR = [' ','.',',',':',';',')',']','!','?'];
100Var
101 CX1,CY1:LONGINT;
102 t:LONGINT;
103 s:String;
104 LastFound:LONGINT;
105Begin
106 CY := 0;
107 CX := 0;
108 While Bubble <> '' Do
109 Begin
110 LastFound := 0;
111 For t := 1 To length(Bubble) Do
112 If Bubble[t] In Separators Then
113 Begin
114 s := Copy(Bubble,1,t);
115 Canvas.GetTextExtent(s,CX1,CY1);
116 If CX1 < CustomHint.FMaxWidth - CustomHint.FShadowSize Then
117 Begin
118 LastFound := t;
119 If CX1 > CX Then CX := CX1;
120 End
121 Else break;
122 End;
123
124 If LastFound=0 Then //no separator, split at will
125 Begin
126 For t := 1 To length(Bubble) Do
127 Begin
128 s := Copy(Bubble,1,t);
129 Canvas.GetTextExtent(s,CX1,CY1);
130 If CX1 < CustomHint.FMaxWidth - CustomHint.FShadowSize Then
131 Begin
132 LastFound := t;
133 If CX1 > CX Then CX := CX1;
134 End
135 Else break;
136 End;
137 End;
138
139 If LastFound = 0 Then LastFound := 1;
140
141 s := Copy(Bubble,1,LastFound);
142 Delete(Bubble,1,LastFound);
143 Ret.Add(s);
144 inc(CY,Canvas.Font.Height);
145 End;
146End;
147
148
149Procedure TCustomHintWindow.DrawBubbleShape(Const rec:TRect);
150Begin
151 Canvas.Rectangle(rec);
152End;
153
154
155Procedure TCustomHintWindow.DrawBubbleText(Const Bubble:String;Const rec:TRect);
156Var
157 CX,CY:LONGINT;
158 X,Y:LONGINT;
159 Strings:TStringList;
160 t:LONGINT;
161Begin
162 {Draw Text}
163 Canvas.ClipRect := rec;
164 Canvas.GetTextExtent(Bubble,CX,CY);
165 Canvas.Brush.Mode := bmTransparent;
166
167 If CX < CustomHint.FMaxWidth - CustomHint.FShadowSize Then
168 Begin
169 //Center text within the rectangle
170 X := rec.Left+((rec.Right-rec.Left-CX) Div 2);
171 If X < rec.Left Then X := rec.Left;
172
173 Y := rec.Bottom+((rec.Top-rec.Bottom-CY) Div 2);
174 If Y < rec.Bottom Then Y := rec.Bottom;
175 Canvas.TextOut(X,Y,Bubble);
176 End
177 Else //split
178 Begin
179 Strings.Create;
180 SplitText(Bubble,Strings,CX,CY);
181
182 X := rec.Left+((rec.Right-rec.Left-CX) Div 2);
183 If X < rec.Left Then X := rec.Left;
184 Y := rec.Top-Canvas.Font.Height-((rec.Top-rec.Bottom-CY) Div 2);
185 For t := 0 To Strings.Count-1 Do
186 Begin
187 Canvas.TextOut(X,Y,Strings[t]);
188 dec(Y,Canvas.Font.Height);
189 End;
190
191 Strings.Destroy;
192 End;
193
194 Canvas.Brush.Mode := bmOpaque;
195 Canvas.DeleteClipRegion;
196End;
197
198
199Procedure TCustomHintWindow.ActivateHint(Rect:TRect; Const AHint:String);
200Var
201 Strings:TStringList;
202 CX:LONGINT;
203 w,h:LONGINT;
204Begin
205 Canvas.Font := Font;
206
207 Canvas.GetTextExtent(AHint,w,h);
208
209 If w >= CustomHint.FMaxWidth - CustomHint.FShadowSize Then
210 Begin
211 //Split
212 w := CustomHint.FMaxWidth - CustomHint.FShadowSize;
213 Strings.Create;
214 SplitText(AHint,Strings,CX,h);
215 w := CX;
216 Strings.Destroy;
217 End;
218
219 inc(w,CustomHint.FShadowSize+16);
220 inc(h,CustomHint.FShadowSize+10);
221
222 If Application.HintOrigin = hiTop Then Rect.Bottom := Screen.MousePos.Y
223 Else Rect.Bottom := Screen.MousePos.Y - 15 - h;
224
225 Rect.Right := Rect.Left + w;
226 Rect.Top := Rect.Bottom + h;
227
228 Inherited ActivateHint(Rect,AHint);
229End;
230
231
232Procedure TCustomHintWindow.Redraw(Const rec:TRect);
233Var
234 Target:TRect;
235Begin
236 Canvas.Pen.Color := CustomHint.FHintColor;
237 Canvas.Pen.Width := 1;
238 Canvas.Brush.Style := bsSolid;
239
240 Canvas.ClipRect := rec;
241
242 Target := ClientRect;
243 dec(Target.Right,4+CustomHint.FShadowSize);
244 dec(Target.Top,4);
245 inc(Target.Bottom,CustomHint.FShadowSize);
246
247 Canvas.BeginPath;
248 DrawBubbleShape(Target);
249 Canvas.EndPath;
250 Canvas.FillPath;
251
252 If CustomHint.FOutlined Then
253 Begin
254 Canvas.Pen.Color := CustomHint.FOutlineColor;
255 DrawBubbleShape(Target);
256 End;
257
258 {Draw shadow}
259 If CustomHint.FShadowSize > 0 Then
260 Begin
261 Canvas.Pen.Color:=CustomHint.FShadowColor;
262
263 {Create complex clip region}
264 Canvas.BeginPath;
265 DrawBubbleShape(Target);
266 Canvas.EndPath;
267 Canvas.PathToClipRegion(paSubtract);
268
269 If CustomHint.FShadowStyle = shsShadowed Then
270 Begin
271 Canvas.Pen.Mode := pmMerge;
272 Canvas.Brush.Style := bsDiagCross;
273 Canvas.Pen.Color := clBlack;
274 Canvas.Brush.Color := clBlack;
275 End;
276
277 Target := rec;
278 dec(Target.Right,4);
279 dec(Target.Top,4+CustomHint.FShadowSize);
280 inc(Target.Left,CustomHint.FShadowSize);
281
282 Canvas.BeginPath;
283 DrawBubbleShape(Target);
284 Canvas.EndPath;
285 Canvas.FillPath;
286 End;
287
288 Canvas.Pen.Mode := pmCopy;
289 Canvas.DeleteClipRegion;
290
291 Target := rec;
292 inc(Target.Bottom,CustomHint.FShadowSize);
293 dec(Target.Right,CustomHint.FShadowSize+3);
294 Canvas.Pen.Color := CustomHint.FHintPenColor;
295 DrawBubbleText(Caption,Target);
296End;
297
298
299{
300ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
301º º
302º Speed-Pascal/2 Version 2.0 º
303º º
304º Speed-Pascal Component Classes (SPCC) º
305º º
306º This section: TCustomHint Class implementation º
307º º
308º Last modified: September 1995 º
309º º
310º (C) 1995 SpeedSoft. All rights reserved. Disclosure probibited ! º
311º º
312ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
313}
314
315Procedure TCustomHint.SetupComponent;
316Begin
317 Inherited SetupComponent;
318
319 If Not InDesigner Then
320 Begin
321 HintWindowClass := TCustomHintWindow;
322 CustomHint := Self;
323 End;
324
325 Name := 'CustomHint';
326 FOutlined := TRUE;
327 FShadowSize := 10;
328 FShadowStyle := shsShadowed;
329 FShadowColor := clBlack;
330 FHintPenColor := Application.HintPenColor;
331 FHintColor := Application.HintColor;
332 FHintOrigin := Application.HintOrigin;
333 FMaxWidth := 200;
334End;
335
336
337Destructor TCustomHint.Destroy;
338Begin
339 If CustomHint = Self Then CustomHint := Nil;
340 Inherited Destroy;
341End;
342
343
344Procedure TCustomHint.SetHintOrigin(NewValue:THintOrigin);
345Begin
346 If Not InDesigner Then Application.HintOrigin := NewValue;
347 FHintOrigin := NewValue;
348End;
349
350
351Procedure TCustomHint.SetShadowSize(NewValue:LONGINT);
352Begin
353 If (NewValue < 0) Or (NewValue > 50) Then exit;
354 FShadowSize := NewValue;
355End;
356
357
358{
359ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
360º º
361º Speed-Pascal/2 Version 2.0 º
362º º
363º Speed-Pascal Component Classes (SPCC) º
364º º
365º This section: TBallonHintWindow Class implementation º
366º º
367º Last modified: September 1995 º
368º º
369º (C) 1995 SpeedSoft. All rights reserved. Disclosure probibited ! º
370º º
371ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
372}
373
374Type
375 TBalloonHintWindow=Class(TCustomHintWindow)
376 Protected
377 Procedure DrawBubbleShape(Const rec:TRect);Override;
378 Procedure DrawBubbleText(Const Bubble:String;Const rec:TRect);Override;
379 Public
380 Procedure ActivateHint(Rect:TRect; Const AHint:String);Override;
381 End;
382
383
384Procedure TBalloonHintWindow.DrawBubbleShape(Const rec:TRect);
385Begin
386 Canvas.PenPos := Point(rec.Left,rec.Bottom);
387
388 Canvas.LineTo(rec.Left+20,rec.Bottom+15);
389
390 If BalloonHint.FBalloonShape = basRectangle Then
391 Begin
392 Canvas.LineTo(rec.Right,rec.Bottom+15);
393 Canvas.LineTo(rec.Right,rec.Top);
394 Canvas.LineTo(rec.Left+5,rec.Top);
395 Canvas.LineTo(rec.Left+5,rec.Bottom+15);
396 Canvas.LineTo(rec.Left+10,rec.Bottom+15);
397 Canvas.LineTo(rec.Left,rec.Bottom);
398 End
399 Else
400 Begin
401 Canvas.LineTo(rec.Right-8,rec.Bottom+15);
402 Canvas.Arc(rec.Right-8,rec.Bottom+23,8,8,270,90);
403 Canvas.LineTo(rec.Right,rec.Top-8);
404 Canvas.Arc(rec.Right-8,rec.Top-8,8,8,0,90);
405 Canvas.LineTo(rec.Left+13,rec.Top);
406 Canvas.Arc(rec.Left+13,rec.Top-8,8,8,90,90);
407 Canvas.LineTo(rec.Left+5,rec.Bottom+23);
408 Canvas.Arc(rec.Left+13,rec.Bottom+23,8,8,180,70);
409 Canvas.LineTo(rec.Left+10,rec.Bottom+15);
410 Canvas.LineTo(rec.Left,rec.Bottom);
411 End;
412End;
413
414
415Procedure TBalloonHintWindow.DrawBubbleText(Const Bubble:String;Const rec:TRect);
416Var
417 rc1:TRect;
418Begin
419 rc1 := rec;
420 inc(rc1.Left,4);
421 inc(rc1.Bottom,15);
422
423 Inherited DrawBubbleText(Bubble,rc1);
424End;
425
426
427Procedure TBalloonHintWindow.ActivateHint(Rect:TRect; Const AHint:String);
428Var
429 Strings:TStringList;
430 CX:LONGINT;
431 w,h:LONGINT;
432Begin
433 Canvas.Font := Font;
434
435 Canvas.GetTextExtent(AHint,w,h);
436
437 If w >= CustomHint.FMaxWidth - CustomHint.FShadowSize Then
438 Begin
439 //Split
440 w := CustomHint.FMaxWidth - CustomHint.FShadowSize;
441 Strings.Create;
442 SplitText(AHint,Strings,CX,h);
443 w := CX;
444 Strings.Destroy;
445 End;
446
447 inc(w,CustomHint.FShadowSize+16);
448 inc(h,CustomHint.FShadowSize+10);
449
450 If Application.HintOrigin = hiTop Then Rect.Bottom := Screen.MousePos.Y
451 Else Rect.Bottom := Screen.MousePos.Y - 15 - h;
452
453 inc(w,8);
454 inc(h,15);
455
456 Rect.Right := Rect.Left + w;
457 Rect.Top := Rect.Bottom + h;
458
459 THintWindow.ActivateHint(Rect,AHint);
460End;
461
462
463{
464ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
465º º
466º Speed-Pascal/2 Version 2.0 º
467º º
468º Speed-Pascal Component Classes (SPCC) º
469º º
470º This section: TBalloonHint Class implementation º
471º º
472º Last modified: September 1995 º
473º º
474º (C) 1995 SpeedSoft. All rights reserved. Disclosure probibited ! º
475º º
476ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
477}
478
479Procedure TBalloonHint.SetupComponent;
480Begin
481 Inherited SetupComponent;
482
483 If Not InDesigner Then
484 Begin
485 HintWindowClass := TBalloonHintWindow;
486 BalloonHint := Self;
487 Application.HintOrigin := hiTop;
488 End;
489
490 Name := 'BalloonHint';
491 FBalloonShape := basRounded;
492End;
493
494
495Destructor TBalloonHint.Destroy;
496Begin
497 If BalloonHint = Self Then BalloonHint := Nil;
498 Inherited Destroy;
499End;
500
501
502
503Begin
504 RegisterClasses([TCustomHint,TBalloonHint]);
505End.
Note: See TracBrowser for help on using the repository browser.