Author: Tomas Rutkauskas
How to create a balloon-shaped tooltip
Answer:
Solve 1:
You could show a ToolTip control, which would have the appearance of a cartoon
"balloon", with rounded corners and a stem pointing to the item. Also, there could
be a multiline text and a caption with an icon. But in order to see this, be sure
that there are Version 5.80 of Comctl32.dll and version 5.0 of Shlwapi.dll
installed on your machine. Below is the code which would force the tooltip to show
itself.
1 { ... }
2 var
3 FTTHandle: THandle;
4
5 const
6 TTM_SETTITLE = $0420;
7 TTS_BALLOON = $040;
8
9 procedure TForm1.SpeedButton2Click(Sender: TObject);
10 var
11 ti: TOOLINFO;
12 XRect: TRect;
13 begin
14 FTTHandle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, WS_POPUP or
15 TTS_NOPREFIX or TTS_BALLOON, 0, 0, 0, 0, Handle, 0, Application.Handle, nil);
16 ti.cbSize := sizeof(TOOLINFO);
17 ti.uFlags := TTF_SUBCLASS or TTF_DI_SETITEM;
18 ti.hwnd := Handle;
19 ti.hinst := Application.Handle;
20 ti.uId := 0;
21 ti.lpszText := 'First line' + #$0D#$0A + 'Second line' + #$0D#$0A + {...}
22 + 'Last Line';
23 {ti.lpszText := LPSTR_TEXTCALLBACK;}
24 XRect := ClientRect;
25 ti.rect.left := XRect.left;
26 ti.rect.top := XRect.top;
27 ti.rect.right := XRect.right;
28 ti.rect.bottom := XRect.bottom;
29 SendMessage(FTTHandle, TTM_ADDTOOL, 0, integer(@ti));
30 SendMessage(FTTHandle, TTM_SETTITLE, 1, integer(PChar('Title')));
31 SendMessage(FTTHandle, TTM_SETMAXTIPWIDTH, 0, 100);
32 SendMessage(FTTHandle, TTM_SETTIPBKCOLOR, clMoneyGreen, 0);
33 SendMessage(FTTHandle, TTM_SETTIPTEXTCOLOR, clNavy, 0);
34 end;
35
36 Basically, you could even perform some custom painting on the tooltip's surface. In
37 order to do this add a WM_NOTIFY message handler to the form and handle the
38 NM_CUSTOMDRAW notification. Below is an example:
39
40 { ... }
41 type
42 TForm1 = class(TForm)
43 SpeedButton2: TSpeedButton;
44 procedure SpeedButton2Click(Sender: TObject);
45 protected
46 procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
47 end;
48
49 { ... }
50
51 procedure TForm1.WMNotify(var Message: TWMNotify);
52 var
53 XCanvas: TCanvas;
54 XRect: TRect;
55 begin
56 inherited;
57 if integer(Message.NMHdr.hwndFrom) = integer(FTTHandle) then
58 begin
59 case Message.NMHdr.code of
60 TTN_POP:
61 begin
62 {do something here, when tooltip hides}
63 end;
64 TTN_SHOW:
65 begin
66 {do something here, when tooltip show itself}
67 end;
68 TTN_NEEDTEXT:
69 begin
70 PTOOLTIPTEXT(Message.NMHdr).lpszText := '
71 {here you could set new text to the tooltip, but only in
72 case you've specified a LPSTR_TEXTCALLBACK constant
73 in the lpszText identifier, in the SpeedButton2Click method}
74 end;
75 NM_CUSTOMDRAW:
76 begin
77 with PNMCustomDraw(message.NMHdr)^ do
78 begin
79 if dwDrawStage = CDDS_PREPAINT then
80 begin
81 message.Result := CDRF_NOTIFYPOSTPAINT;
82 end
83 else if dwDrawStage = CDDS_POSTPAINT then
84 begin
85 XCanvas := TCanvas.Create;
86 try
87 XCanvas.Handle := hdc;
88 XRect := PNMCustomDraw(message.NMHdr)^.rc;
89 XRect.Left := XRect.Right - 40;
90 XRect.Bottom := XRect.Top + 30;
91 XCanvas.Brush.Color := clBlue;
92 XCanvas.FillRect(RECT(XRect.Left, XRect.Top, XRect.Right,
93 XRect.Top + 15));
94 XCanvas.Brush.Color := clYellow;
95 XCanvas.FillRect(RECT(XRect.Left, XRect.Top + 15,
96 XRect.Right, XRect.Top + 30));
97 XCanvas.Brush.Color := clBlack;
98 XCanvas.FrameRect(XRect);
99 finally
100 XCanvas.Free;
101 end;
102 end;
103 end;
104 end;
105 end;
106 end;
107 end;
108
109
110 Solve 2:
111
112 unit Unit1;
113
114 interface
115
116 uses
117 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
118 Dialogs, CommCtrl, StdCtrls;
119
120 const
121 TTS_BALLOON = $40;
122 TTM_SETTITLE = (WM_USER + 32);
123
124 type
125 TForm1 = class(TForm)
126 Memo1: TMemo;
127 procedure FormCreate(Sender: TObject);
128 private
129 {Private declarations}
130 public
131 {Public declarations}
132 end;
133
134 var
135 Form1: TForm1;
136 hTooltip: Cardinal;
137 ti: TToolInfo;
138 buffer: array[0..255] of char;
139
140 implementation
141
142 {$R *.dfm}
143
144 procedure CreateToolTips(hWnd: Cardinal);
145 begin
146 hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or
147 TTS_BALLOON,
148 Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
149 Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
150 if hToolTip <> 0 then
151 begin
152 SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
153 SWP_NOSIZE or SWP_NOACTIVATE);
154 ti.cbSize := SizeOf(TToolInfo);
155 ti.uFlags := TTF_SUBCLASS;
156 ti.hInst := hInstance;
157 end;
158 end;
159
160 procedure AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer; Text, Title:
161 PChar);
162 var
163 Item: THandle;
164 Rect: TRect;
165 begin
166 Item := hWnd;
167 if (Item <> 0) and (GetClientRect(Item, Rect)) then
168 begin
169 lpti.hwnd := Item;
170 lpti.Rect := Rect;
171 lpti.lpszText := Text;
172 SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
173 FillChar(buffer, sizeof(buffer), #0);
174 lstrcpy(buffer, Title);
175 if (IconType > 3) or (IconType < 0) then
176 IconType := 0;
177 SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
178 end;
179 end;
180
181 procedure TForm1.FormCreate(Sender: TObject);
182 begin
183 CreateToolTips(Form1.Handle);
184 AddToolTip(Memo1.Handle, @ti, 1, Memo1.Lines.GetText, 'Memo Text');
185 end;
186
187 end.
|