Create a balloon-shaped tooltip

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.