Create a balloon-shaped tooltip (Views: 704)
Problem/Question/Abstract: 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. { ... } var FTTHandle: THandle; const TTM_SETTITLE = $0420; TTS_BALLOON = $040; procedure TForm1.SpeedButton2Click(Sender: TObject); var ti: TOOLINFO; XRect: TRect; begin FTTHandle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, WS_POPUP or TTS_NOPREFIX or TTS_BALLOON, 0, 0, 0, 0, Handle, 0, Application.Handle, nil); ti.cbSize := sizeof(TOOLINFO); ti.uFlags := TTF_SUBCLASS or TTF_DI_SETITEM; ti.hwnd := Handle; ti.hinst := Application.Handle; ti.uId := 0; ti.lpszText := 'First line' + #$0D#$0A + 'Second line' + #$0D#$0A + {...} + 'Last Line'; {ti.lpszText := LPSTR_TEXTCALLBACK;} XRect := ClientRect; ti.rect.left := XRect.left; ti.rect.top := XRect.top; ti.rect.right := XRect.right; ti.rect.bottom := XRect.bottom; SendMessage(FTTHandle, TTM_ADDTOOL, 0, integer(@ti)); SendMessage(FTTHandle, TTM_SETTITLE, 1, integer(PChar('Title'))); SendMessage(FTTHandle, TTM_SETMAXTIPWIDTH, 0, 100); SendMessage(FTTHandle, TTM_SETTIPBKCOLOR, clMoneyGreen, 0); SendMessage(FTTHandle, TTM_SETTIPTEXTCOLOR, clNavy, 0); end; Basically, you could even perform some custom painting on the tooltip's surface. In order to do this add a WM_NOTIFY message handler to the form and handle the NM_CUSTOMDRAW notification. Below is an example: { ... } type TForm1 = class(TForm) SpeedButton2: TSpeedButton; procedure SpeedButton2Click(Sender: TObject); protected procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY; end; { ... } procedure TForm1.WMNotify(var Message: TWMNotify); var XCanvas: TCanvas; XRect: TRect; begin inherited; if integer(Message.NMHdr.hwndFrom) = integer(FTTHandle) then begin case Message.NMHdr.code of TTN_POP: begin {do something here, when tooltip hides} end; TTN_SHOW: begin {do something here, when tooltip show itself} end; TTN_NEEDTEXT: begin PTOOLTIPTEXT(Message.NMHdr).lpszText := 'some text...'; {here you could set new text to the tooltip, but only in case you've specified a LPSTR_TEXTCALLBACK constant in the lpszText identifier, in the SpeedButton2Click method} end; NM_CUSTOMDRAW: begin with PNMCustomDraw(Message.NMHdr)^ do begin if dwDrawStage = CDDS_PREPAINT then begin Message.Result := CDRF_NOTIFYPOSTPAINT; end else if dwDrawStage = CDDS_POSTPAINT then begin XCanvas := TCanvas.Create; try XCanvas.Handle := hdc; XRect := PNMCustomDraw(Message.NMHdr)^.rc; XRect.Left := XRect.Right - 40; XRect.Bottom := XRect.Top + 30; XCanvas.Brush.Color := clBlue; XCanvas.FillRect(RECT(XRect.Left, XRect.Top, XRect.Right, XRect.Top + 15)); XCanvas.Brush.Color := clYellow; XCanvas.FillRect(RECT(XRect.Left, XRect.Top + 15, XRect.Right, XRect.Top + 30)); XCanvas.Brush.Color := clBlack; XCanvas.FrameRect(XRect); finally XCanvas.Free; end; end; end; end; end; end; end; Solve 2: unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, CommCtrl, StdCtrls; const TTS_BALLOON = $40; TTM_SETTITLE = (WM_USER + 32); type TForm1 = class(TForm) Memo1: TMemo; procedure FormCreate(Sender: TObject); private {Private declarations} public {Public declarations} end; var Form1: TForm1; hTooltip: Cardinal; ti: TToolInfo; buffer: array[0..255] of char; implementation {$R *.dfm} procedure CreateToolTips(hWnd: Cardinal); begin hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON, Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil); if hToolTip <> 0 then begin SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE); ti.cbSize := SizeOf(TToolInfo); ti.uFlags := TTF_SUBCLASS; ti.hInst := hInstance; end; end; procedure AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer; Text, Title: PChar); var Item: THandle; Rect: TRect; begin Item := hWnd; if (Item <> 0) and (GetClientRect(Item, Rect)) then begin lpti.hwnd := Item; lpti.Rect := Rect; lpti.lpszText := Text; SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti)); FillChar(buffer, sizeof(buffer), #0); lstrcpy(buffer, Title); if (IconType > 3) or (IconType < 0) then IconType := 0; SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer)); end; end; procedure TForm1.FormCreate(Sender: TObject); begin CreateToolTips(Form1.Handle); AddToolTip(Memo1.Handle, @ti, 1, Memo1.Lines.GetText, 'Memo Text'); end; end. |