I’m trying to implement a simple Balloon Hint, using the tooltips_class32. In fact, all

Question

0

Asked: May 27, 20262026-05-27T13:08:23+00:00 2026-05-27T13:08:23+00:00

I’m trying to implement a simple Balloon Hint, using the tooltips_class32. In fact, all

0

I’m trying to implement a simple Balloon Hint, using the “tooltips_class32”. In fact, all behaviour is correct except the links on balloon.

My balloons are being correctly created and I can see the link, but when i click the link nothing happens.

I tried to trap the TTN_LINKCLICK notification on two Window Procedures. The one of my Tooltip and the one of the parent window of my Tooltip.

I know this notification is sent as WM_NOTIFY, but nothing is done when I clik the link.

So, how to trap the TTN_LINKCLICK notification? How to make this works on Delphi?

Below is the full code of my TKRKBalloonHint component.

unit KRKBalloonHint;

interface

uses
  SysUtils, Classes, Graphics, ExtCtrls, Types, CommCtrl, Controls, Messages,
  Windows;

type
  TTipIcon = (tiNone,tiInfo,tiWarning,tiError,tiInfoLarge,tiWarningLarge,tiErrorLarge);

  TTipAlignment = (taTopLeft,taTopMiddle,taTopRight,taLeftMiddle,taRightMiddle,taBottomLeft,taBottomMiddle,taBottomRight,taCustom);

  TMaxWidth = 0..320;

  TKRKBalloonHintOption = (kbhoActivateOnShow, kbhoSetFocusToAssociatedWinContronOnDeactivate, kbhoHideOnDeactivate, kbhoHideWithEnter, kbhoHideWithEsc, kbhoSelectAllOnFocus);
  TKRKBalloonHintOptions = set of TKRKBalloonHintOption;

  TKRKBalloonHint = class(TComponent)
  private
    FParentHandle: HWND;
    FAutoGetTexts: Boolean;
    FMaxWidth: TMaxWidth;
    FBackColor: TColor;
    FForeColor: TColor;
    FVisibleTime: Word;
    FDelayTime: Word;
    FTipHandle: THandle;
    FAssociatedWinControl: TWinControl;
    FTipTitle: String;
    FTipText: String;
    FTipIcon: TTipIcon;
    FTipAlignment: TTipAlignment;
    FShowWhenRequested: Boolean;
    FCentered: Boolean;
    FForwardMessages: Boolean;
    FAbsolutePosition: Boolean;
    FShowCloseButton: Boolean;
    FParseLinks: Boolean;
    FFont: TFont;
    FPosition: TPoint;
    FCustomXPosition: Word;
    FCustomYPosition: Word;
    FToolInfo: TToolInfo;
    FOptions: TKRKBalloonHintOptions;

    FOnMouseDown: TMouseEvent;
    FOnMouseUp: TMouseEvent;
    FOnMouseMove: TMouseMoveEvent;

    procedure SetMaxWidth(const Value: TMaxWidth);
    procedure SetBackColor(const Value: TColor);
    procedure SetForeColor(const Value: TColor);
    procedure SetDelayTime(const Value: Word);
    procedure SetTipIcon(const Value: TTipIcon);
    procedure SetTipText(const Value: String);
    procedure SetTipTitle(const Value: String);
    procedure SetVisibleTime(const Value: Word);
    procedure SetTipAlignment(const Value: TTipAlignment);
    procedure SetPosition(const Value: TPoint);
    procedure SetCustomXPosition(const Value: Word);
    procedure SetCustomYPosition(const Value: Word);
    procedure SetAbsolutePosition(const Value: Boolean);
    procedure SetShowCloseButton(const Value: Boolean);
    procedure SetFont(const Value: TFont);
    procedure SetAssociatedWinControl(const Value: TWinControl);
    procedure SetAutoGetTexts(const Value: Boolean);
    procedure SetParseLinks(const Value: Boolean);
    procedure SetCentered(const Value: Boolean);
    procedure SetForwardMessages(const Value: Boolean);
    procedure SetShowWhenRequested(const Value: Boolean);
    procedure DoFontChange(Sender: TObject);
    procedure DestroyToolTip;
    procedure CreateToolTip;
    procedure UnlinkToolTip;
    procedure LinkToolTip;
    procedure RefreshToolTip;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    procedure Show(TipAlignment: TTipAlignment); overload;
    procedure Show; overload;
    procedure Show(X, Y: Word); overload;
    procedure Hide;
    procedure Move(X, Y: Word);
    property Handle: THandle read FTipHandle;
    property Position: TPoint read FPosition;
  published
    property ParseLinks: Boolean read FParseLinks write SetParseLinks default False;
    property AutoGetTexts: Boolean read FAutoGetTexts write SetAutoGetTexts default False;
    property AssociatedWinControl: TWinControl read FAssociatedWinControl write SetAssociatedWinControl;
    property MaxWidth: TMaxWidth read FMaxWidth write SetMaxWidth default 0;
    property BackColor: TColor read FBackColor write SetBackColor default $00E1FFFF;
    property ForeColor: TColor read FForeColor write SetForeColor default $00000000;
    property VisibleTime: Word read FVisibleTime write SetVisibleTime default 3000;
    property DelayTime: Word read FDelayTime write SetDelayTime default 1000;
    property TipTitle: String read FTipTitle write SetTipTitle;
    property TipText: String read FTipText write SetTipText;
    property TipIcon: TTipIcon read FTipIcon write SetTipIcon default tiInfo;
    property TipAlignment: TTipAlignment read FTipAlignment write SetTipAlignment default taTopLeft;
    property CustomXPosition: Word read FCustomXPosition write SetCustomXPosition default 0;
    property CustomYPosition: Word read FCustomYPosition write SetCustomYPosition default 0;
    property ShowWhenRequested: Boolean read FShowWhenRequested write SetShowWhenRequested default True;
    property Centered: Boolean read FCentered write SetCentered default False;
    property ForwardMessages: Boolean read FForwardMessages write SetForwardMessages default False;
    property AbsolutePosition: Boolean read FAbsolutePosition write SetAbsolutePosition default False;
    property ShowCloseButton: Boolean read FShowCloseButton write SetShowCloseButton default False;
    property Font: TFont read FFont write SetFont;
    property Options: TKRKBalloonHintOptions read FOptions write FOptions default [];
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
  end;

implementation

const
  TOOLTIPS_CLASS = 'tooltips_class32';
  TTM_SETTITLE = (WM_USER + 32);
  TTS_BALLOON = $40;
  TTS_CLOSE = $80;
  TTF_PARSELINKS = $1000;
  TTN_LINKCLICK = TTN_FIRST - 3;

var
  OriginalToolTipWNDPROC: Pointer = nil;

function NewToolTipWNDPROC(aWindowHandle: HWND; aMessage: UINT; aWParam: WPARAM; aLParam: LPARAM): LRESULT; stdcall;
var
  ShiftState: TShiftState;
  Button: TMouseButton;
  KRBH: TKRKBalloonHint;
begin
  Button := mbLeft;

  KRBH := TKRKBalloonHint(GetWindowLong(aWindowHandle,GWL_USERDATA));

  if KRBH.FShowWhenRequested then
    case aMessage of
      WM_KEYUP:
        case aWParam of
          13:
            if kbhoHideWithEnter in KRBH.Options then
              KRBH.Hide;
          27:
            if kbhoHideWithEsc in KRBH.Options then
              KRBH.Hide;
        end;
      WM_MOUSEMOVE:
        if Assigned(KRBH.FOnMouseMove) then
        begin
          ShiftState := [];

          if (MK_CONTROL and aWParam) = MK_CONTROL  then
            ShiftState := ShiftState + [ssCtrl];

          if (MK_SHIFT and aWParam) = MK_SHIFT then
            ShiftState := ShiftState + [ssShift];

          if GetKeyState(VK_MENU) < 0 then
            ShiftState := ShiftState + [ssAlt];

          if (MK_LBUTTON and aWParam) = MK_LBUTTON then
            ShiftState := ShiftState + [ssLeft];

          if (MK_MBUTTON and aWParam) = MK_MBUTTON then
            ShiftState := ShiftState + [ssMiddle];

          if (MK_RBUTTON and aWParam) = MK_RBUTTON then
            ShiftState := ShiftState + [ssRight];

          KRBH.FOnMouseMove(KRBH,ShiftState,LOWORD(aLParam),HIWORD(aLParam));
        end;

      WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN:
        if Assigned(KRBH.FOnMouseDown) then
        begin
          ShiftState := [];

          if (MK_CONTROL and aWParam) = MK_CONTROL  then
            ShiftState := ShiftState + [ssCtrl];

          if (MK_SHIFT and aWParam) = MK_SHIFT then
            ShiftState := ShiftState + [ssShift];

          if GetKeyState(VK_MENU) < 0 then
            ShiftState := ShiftState + [ssAlt];

          if (MK_LBUTTON and aWParam) = MK_LBUTTON then
          begin
            ShiftState := ShiftState + [ssLeft];
            Button := mbLeft;
          end
          else if (MK_MBUTTON and aWParam) = MK_MBUTTON then
          begin
            ShiftState := ShiftState + [ssMiddle];
            Button := mbMiddle;
          end
          else if (MK_RBUTTON and aWParam) = MK_RBUTTON then
          begin
            ShiftState := ShiftState + [ssRight];
            Button := mbRight;
          end;

            KRBH.FOnMouseDown(KRBH,Button,ShiftState,LOWORD(aLParam),HIWORD(aLParam));
        end;

      WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP:
        if Assigned(KRBH.FOnMouseUp) then
        begin
          ShiftState := [];

          if (MK_CONTROL and aWParam) = MK_CONTROL  then
            ShiftState := ShiftState + [ssCtrl];

          if (MK_SHIFT and aWParam) = MK_SHIFT then
            ShiftState := ShiftState + [ssShift];

          if GetKeyState(VK_MENU) < 0 then
            ShiftState := ShiftState + [ssAlt];

          if (MK_LBUTTON and aWParam) = MK_LBUTTON then
          begin
            ShiftState := ShiftState + [ssLeft];
            Button := mbLeft;
          end;

          if (MK_MBUTTON and aWParam) = MK_MBUTTON then
          begin
            ShiftState := ShiftState + [ssMiddle];
            Button := mbMiddle;
          end;

          if (MK_RBUTTON and aWParam) = MK_RBUTTON then
          begin
            ShiftState := ShiftState + [ssRight];
            Button := mbRight;
          end;

          KRBH.FOnMouseUp(KRBH,Button,ShiftState,LOWORD(aLParam),HIWORD(aLParam));
        end;
        WM_KILLFOCUS:
        begin
          if Assigned(KRBH.AssociatedWinControl) and (kbhoSetFocusToAssociatedWinContronOnDeactivate in KRBH.Options) then
            SetFocus(KRBH.AssociatedWinControl.Handle);

          if Assigned(KRBH.AssociatedWinControl) and (kbhoSelectAllOnFocus in KRBH.Options) then
            SendMessage(KRBH.AssociatedWinControl.Handle, EM_SETSEL, 0, -1);

          if kbhoHideOnDeactivate in KRBH.Options then
            KRBH.Hide;
        end;
    end;

  Result := CallWindowProc(OriginalToolTipWNDPROC,aWindowHandle,aMessage,aWParam,aLParam);
end;

{ TKRKBalloonHint }

constructor TKRKBalloonHint.Create(aOwner: TComponent);
begin
  inherited;
  FParentHandle := 0;

  if Assigned(aOwner) and (aOwner is TWinControl) then
    FParentHandle := TWinControl(aOwner).Handle;

  FMaxWidth  := 0;
  FBackColor := $00E1FFFF;
  FForeColor := $00000000;
  FOptions := [];

  FVisibleTime := 3000;
  FDelayTime := 1000;
  FTipHandle := 0;
  FAssociatedWinControl := nil;
  FTipTitle := 'Balão sem título';
  FTipText := 'Você esqueceu de por um texto. Configure a propriedade TipText corretamente';
  FAutoGetTexts := False;
  FTipIcon := tiInfo;
  FTipAlignment := taTopLeft;
  FShowWhenRequested := True;
  FCentered := False;
  FForwardMessages := False;
  FAbsolutePosition := False;
  FShowCloseButton := False;
  FParseLinks := False;
  FFont := TFont.Create;

  FFont.OnChange := DoFontChange;
  FPosition := Point(0,0);
  FCustomXPosition := 0;
  FCustomYPosition := 0;

  ZeroMemory(@FToolInfo, SizeOf(TToolInfo));

  with FToolInfo do
  begin
    cbSize := SizeOf(TToolInfo);

    if FAbsolutePosition then
      uFlags := uFlags or TTF_ABSOLUTE;

    if FCentered then
      uFlags := uFlags or TTF_CENTERTIP;

    if FParseLinks then
      uFlags := uFlags or TTF_PARSELINKS;

    if FShowWhenRequested then
      FToolInfo.uFlags := FToolInfo.uFlags or TTF_TRACK
    else
      FToolInfo.uFlags := FToolInfo.uFlags or TTF_SUBCLASS;

    if FForwardMessages then
      uFlags := uFlags or TTF_TRANSPARENT;
  end;

  CreateToolTip;
end;

destructor TKRKBalloonHint.Destroy;
begin
  FFont.Free;
  DestroyToolTip;
  inherited;
end;

procedure TKRKBalloonHint.DestroyToolTip;
begin
  if FTipHandle <> 0 then
    DestroyWindow(FTipHandle);
end;

procedure TKRKBalloonHint.CreateToolTip;
var
  Style: Cardinal;
begin
  Style := TTS_NOPREFIX or TTS_BALLOON;

  if FShowCloseButton then
    Style := Style or TTS_CLOSE;

  FTipHandle := CreateWindowEx(WS_EX_NOACTIVATE or WS_EX_TOPMOST,TOOLTIPS_CLASS,nil,Style,0,0,0,0,FParentHandle,0,0,nil);

  SetWindowLong(FTipHandle,GWL_USERDATA,Integer(Self));

  OriginalToolTipWNDPROC := Pointer(SetWindowLong(FTipHandle,GWL_WNDPROC,LongInt(@NewToolTipWNDPROC)));

  LinkToolTip;
end;

procedure TKRKBalloonHint.LinkToolTip;
begin
  if FTipHandle <> 0 then
    SendMessage(FTipHandle,TTM_ADDTOOL,0,LPARAM(@FToolInfo));
end;

procedure TKRKBalloonHint.UnlinkToolTip;
begin
  if FTipHandle <> 0 then
  begin
    Hide;
    SendMessage(FTipHandle,TTM_DELTOOL,0,LPARAM(@FToolInfo));
  end;
end;

procedure TKRKBalloonHint.SetShowWhenRequested(const Value: Boolean);
begin
  UnlinkToolTip;
  try
    FShowWhenRequested := Value;

    FToolInfo.uFlags := FToolInfo.uFlags or TTF_SUBCLASS or TTF_TRACK;

    if not FShowWhenRequested then
      FToolInfo.uFlags := FToolInfo.uFlags xor TTF_TRACK // Tira TTF_TRACK e mantém TTF_SUBCLASS
    else
      FToolInfo.uFlags := FToolInfo.uFlags xor TTF_SUBCLASS; // Tira TTF_SUBCLASS e mantém TTF_TRACK
  finally
    LinkToolTip;
  end;
end;

procedure TKRKBalloonHint.SetForwardMessages(const Value: Boolean);
begin
  UnlinkToolTip;
  try
    FForwardMessages := Value;

    FToolInfo.uFlags := FToolInfo.uFlags or TTF_TRANSPARENT;

    if not FForwardMessages then
      FToolInfo.uFlags := FToolInfo.uFlags xor TTF_TRANSPARENT;
  finally
    LinkToolTip;
  end;
end;

procedure TKRKBalloonHint.SetCentered(const Value: Boolean);
begin
  UnlinkToolTip;
  try
    FCentered := Value;

    FToolInfo.uFlags := FToolInfo.uFlags or TTF_CENTERTIP;

    if not FCentered then
      FToolInfo.uFlags := FToolInfo.uFlags xor TTF_CENTERTIP;
  finally
    LinkToolTip;
  end;
end;

procedure TKRKBalloonHint.SetForeColor(const Value: TColor);
begin
  FForeColor := Value;

  if FTipHandle <> 0 then
    SendMessage(FTipHandle,TTM_SETTIPTEXTCOLOR,FForeColor,0);
end;

procedure TKRKBalloonHint.SetBackColor(const Value: TColor);
begin
  FBackColor := Value;

  if FTipHandle <> 0 then
    SendMessage(FTipHandle,TTM_SETTIPBKCOLOR,FBackColor,0);
end;

procedure TKRKBalloonHint.SetMaxWidth(const Value: TMaxWidth);
begin
  FMaxWidth := Value;

  if FTipHandle <> 0 then
    SendMessage(FTipHandle,TTM_SETMAXTIPWIDTH,0,FMaxWidth);

  RefreshToolTip;
end;

procedure TKRKBalloonHint.SetVisibleTime(const Value: Word);
begin
  FVisibleTime := Value;

  if FTipHandle <> 0 then
    SendMessage(FTipHandle,TTM_SETDELAYTIME,TTDT_AUTOPOP,Value);
end;

procedure TKRKBalloonHint.SetDelayTime(const Value: Word);
begin
  FDelayTime := Value;

  if FTipHandle <> 0 then
     SendMessage(FTipHandle,TTM_SETDELAYTIME,TTDT_INITIAL,Value);
end;

procedure TKRKBalloonHint.SetTipTitle(const Value: String);
var
  Title: LPCSTR;
begin
  if not FAutoGetTexts then
  begin
    FTipTitle := Value;

    if (FTipHandle <> 0) and (Trim(FTipTitle) <> '') then
    begin
      GetMem(Title,256);
      try
        StrPCopy(Title,AnsiString(FTipTitle));
        SendMessage(FTipHandle,TTM_SETTITLE,WPARAM(FTipIcon),LPARAM(Title));
      finally
        FreeMem(Title);
      end;
    end;

    RefreshToolTip;
  end
  else if (csDesigning in ComponentState) and not (csLoading in ComponentState) then
    raise Exception.Create('Não é possível mudar o título da dica pois a propriedade AutoGetTexts está ativada. Para poder mudar o título da dica, primeiramente desative a propriedade AutoGetTexts');
end;

procedure TKRKBalloonHint.SetTipText(const Value: String);
begin
  if not FAutoGetTexts then
  begin
    FTipText := Value;

    FToolInfo.lpszText := PChar(FTipText);

    if FTipHandle <> 0 then
      SendMessage(FTipHandle,TTM_UPDATETIPTEXT,0,LPARAM(@FToolInfo));
  end
  else if (csDesigning in ComponentState) and not (csLoading in ComponentState) then
    raise Exception.Create('Não é possível mudar o texto da dica pois a propriedade AutoGetTexts está ativada. Para poder mudar o texto da dica, primeiramente desative a propriedade AutoGetTexts');
end;

procedure TKRKBalloonHint.SetTipIcon(const Value: TTipIcon);
var
  Title: LPCSTR;
begin
  FTipIcon := Value;

  if (FTipHandle <> 0) and (Trim(FTipTitle) <> '') then
  begin
    GetMem(Title,256);
    try
      StrPCopy(Title,AnsiString(FTipTitle));
      SendMessage(FTipHandle,TTM_SETTITLE,WPARAM(FTipIcon),LPARAM(Title));
    finally
      FreeMem(Title);
    end;
  end;

  RefreshToolTip;
end;

procedure TKRKBalloonHint.SetTipAlignment(const Value: TTipAlignment);
var
  TmpPoint: TPoint;
begin
  FTipAlignment := Value;

  if not FShowWhenRequested then
    Exit;

  if (FToolInfo.hwnd <> 0) and (FTipHandle <> 0) then
  begin
    GetClientRect(FToolInfo.hwnd,FToolInfo.Rect);

    ClientToScreen(FToolInfo.hwnd,FToolInfo.Rect.TopLeft);
    FToolInfo.Rect.Right := FToolInfo.Rect.Left + FToolInfo.Rect.Right;
    FToolInfo.Rect.Bottom := FToolInfo.Rect.Top + FToolInfo.Rect.Bottom;

    case Value of
      taTopMiddle:
      begin
        TmpPoint.X := (FToolInfo.Rect.Left + FToolInfo.Rect.Right) div 2;
        TmpPoint.Y := FToolInfo.Rect.Top;
      end;
      taTopRight:
      begin
        TmpPoint.X := FToolInfo.Rect.Right;
        TmpPoint.Y := FToolInfo.Rect.Top;
      end;
      taLeftMiddle:
      begin
        TmpPoint.X := FToolInfo.Rect.Left;
        TmpPoint.Y := (FToolInfo.Rect.Top + FToolInfo.Rect.Bottom) div 2;
      end;
      taRightMiddle:
      begin
        TmpPoint.X := FToolInfo.Rect.Right;
        TmpPoint.Y := (FToolInfo.Rect.Top + FToolInfo.Rect.Bottom) div 2;
      end;
      taBottomLeft:
      begin
        TmpPoint.X := FToolInfo.Rect.Left;
        TmpPoint.Y := FToolInfo.Rect.Bottom;
      end;
      taBottomMiddle:
      begin
        TmpPoint.X := (FToolInfo.Rect.Left + FToolInfo.Rect.Right) div 2;
        TmpPoint.Y := FToolInfo.Rect.Bottom;
      end;
      taBottomRight:
      begin
        TmpPoint.X := FToolInfo.Rect.Right;
        TmpPoint.Y := FToolInfo.Rect.Bottom;
      end;
      taTopLeft:
      begin
        TmpPoint.X := FToolInfo.Rect.Left;
        TmpPoint.Y := FToolInfo.Rect.Top;
      end;
      else { taCustom }
        TmpPoint := Point(FCustomXPosition,FCustomYPosition);
    end;

    SetPosition(TmpPoint);
  end;
end;

procedure TKRKBalloonHint.SetPosition(const Value: TPoint);
begin
  FPosition := Value;

   if FTipHandle <> 0 then
    SendMessage(FTipHandle,TTM_TRACKPOSITION,0,MakeLong(FPosition.X,FPosition.Y));
end;

procedure TKRKBalloonHint.SetAbsolutePosition(const Value: Boolean);
begin
  UnlinkToolTip;
  try
    FAbsolutePosition := Value;

    FToolInfo.uFlags := FToolInfo.uFlags or TTF_ABSOLUTE; { Adiciona o flag }

    if not FAbsolutePosition then
      FToolInfo.uFlags := FToolInfo.uFlags xor TTF_ABSOLUTE; { Retira o flag }
  finally
    LinkToolTip;
  end;
end;

procedure TKRKBalloonHint.SetShowCloseButton(const Value: Boolean);
begin
  FShowCloseButton := Value;

  if FTipHandle <> 0 then
  begin
    SetWindowLong(FTipHandle,GWL_STYLE,GetWindowLong(FTipHandle,GWL_STYLE) or TTS_CLOSE);

    if not FShowCloseButton then
      SetWindowLong(FTipHandle,GWL_STYLE,GetWindowLong(FTipHandle,GWL_STYLE) xor TTS_CLOSE);

    RefreshToolTip;
  end;
end;

procedure TKRKBalloonHint.SetFont(const Value: TFont);
begin
  FFont.Assign(Value);

  if FTipHandle <> 0 then
    SendMessage(FTipHandle,WM_SETFONT,FFont.Handle,1);
end;

procedure TKRKBalloonHint.SetAssociatedWinControl(const Value: TWinControl);
begin
  UnlinkToolTip;
  try
    FAssociatedWinControl := Value;

    if Assigned(FAssociatedWinControl) then
    begin
      FToolInfo.hwnd := FAssociatedWinControl.Handle;
      SetAutoGetTexts(FAutoGetTexts);
      SetTipAlignment(FTipAlignment);
    end;
  finally
    LinkToolTip;
  end;
end;

procedure TKRKBalloonHint.SetAutoGetTexts(const Value: Boolean);
var
  Title: LPCSTR;
  i: Byte;
begin
    FAutoGetTexts := Value;

  if FAutoGetTexts and Assigned(FAssociatedWinControl) then
  begin
    FTipTitle := 'Controle associado sem hint';
    FTipText  := 'AutoGetTexts está ativo mas o controle associado não contém hint';
    FTipIcon  := tiInfo;

    if Trim(FAssociatedWinControl.Hint) <> '' then
      with TStringList.Create do
        try
          Text := StringReplace(Trim(FAssociatedWinControl.Hint),'|',#13#10,[rfReplaceAll]);
          for i := 0 to Pred(Count) do
            case i of
              0: FTipTitle := Strings[0];
              1: FTipText  := Strings[1];
              2: FTipIcon  := TTipIcon(StrToIntDef(Strings[2],0));
            end;
        finally
          Free;
        end;

    FToolInfo.lpszText := PWideChar(FTipText);

    if FTipHandle <> 0 then
    begin
      GetMem(Title,256);
      try
        StrPCopy(Title,AnsiString(FTipTitle));
        SendMessage(FTipHandle,TTM_SETTITLE,WPARAM(FTipIcon),LPARAM(Title));
      finally
        FreeMem(Title);
      end;
      SendMessage(FTipHandle,TTM_UPDATETIPTEXT,0,LPARAM(@FToolInfo));
    end;
  end;
end;

procedure TKRKBalloonHint.SetParseLinks(const Value: Boolean);
begin
  UnlinkToolTip;
  try
    FParseLinks := Value;

    FToolInfo.uFlags := FToolInfo.uFlags or TTF_PARSELINKS; { Adiciona o flag }

    if not FParseLinks then
      FToolInfo.uFlags := FToolInfo.uFlags xor TTF_PARSELINKS; { Retira o flag }
  finally
    LinkToolTip;
  end;
end;

procedure TKRKBalloonHint.Show;
begin
  if FTipHandle <> 0 then
  begin
    SendMessage(FTipHandle,TTM_TRACKACTIVATE,1,LPARAM(@FToolInfo));

    if kbhoActivateOnShow in FOptions then
      SetForegroundWindow(FTipHandle);
  end
  else
    raise Exception.Create('Não é possível exibir o balão, pois o mesmo não foi criado. Use o método CreateToolTip antes de chamar o método Show');
end;

procedure TKRKBalloonHint.Show(TipAlignment: TTipAlignment);
begin
  SetTipAlignment(TipAlignment);
  Show;
end;

procedure TKRKBalloonHint.Show(X,Y: Word);
begin
  SetPosition(Point(X,Y));
  Show;
end;

procedure TKRKBalloonHint.Move(X,Y: Word);
var
  TmpRect: TRect;
begin
   if FTipHandle <> 0 then
  begin
    GetClientRect(FTipHandle,TmpRect);
    MoveWindow(FTipHandle,X,Y,TmpRect.right,TmpRect.bottom,True);
  end;
end;

procedure TKRKBalloonHint.Hide;
begin
  if FTipHandle <> 0 then
    SendMessage(FTipHandle,TTM_TRACKACTIVATE,0,LPARAM(@FToolInfo));
end;

procedure TKRKBalloonHint.RefreshToolTip;
begin
  if FTipHandle <> 0 then
    SendMessage(FTipHandle,TTM_UPDATE,0,0);
end;

procedure TKRKBalloonHint.SetCustomXPosition(const Value: Word);
begin
  FCustomXPosition := Value;
end;

procedure TKRKBalloonHint.SetCustomYPosition(const Value: Word);
begin
  FCustomYPosition := Value;
end;

procedure TKRKBalloonHint.DoFontChange(Sender: TObject);
begin
  SetFont(FFont);
end;

end.

The Delphi help says TTN_LINKCLICK the message is sent as WM_NOTIFY notification. And in several places on the Internet is said that this message is sent to the parent window of the balloon. So merely on the parent form of my balloon I created a method like this:

interface

TForm1 = class(TForm)
  KRKBalloonHint1: TKRKBalloonHint;
private
  { Private declarations }
  procedure HandleWM_NOTIFY(var aMsg: TWMNotify); message WM_NOTIFY;
end;

implementation

procedure TForm1.HandleWM_NOTIFY(var aMsg: TWMNotify);
begin
  if Assigned(aMsg.NMHdr) and (aMsg.NMHdr.code = TTN_LINKCLICK) then
    ShowMessage('Link clicado!');
end;

When i clicked on Link, the showmessage NEVER fires. What to do now?

Report

Leave an answer
Cancel reply

You must login to add an answer.

Need An Account,

1 Answer

Editorial Team · Answer 1 · 2026-05-27T13:08:24+00:00

I would redirect the TControl.WindowProc of your associated control and fire the event in case of WM_NOTIFY message with TTN_LINKCLICK notification. So I would do it like this.

Anyway, very well readable code though, but you have some minor issues in there. E.g. in SetAutoGetTexts you should check if the string list has some items before you iterate, it fails in case when FAssociatedWinControl.Hint is empty 😉

type
  TKRKBalloonHint = class(TComponent)
  private
    ...
    FOnLinkClick: TNotifyEvent;
    FOldWindowProc: TWndMethod;
    procedure WinControlWndProc(var AMessage: TMessage);
    procedure SetAssociatedWinControl(const Value: TWinControl);
  published
    ...
    property OnLinkClick: TNotifyEvent read FOnLinkClick write FOnLinkClick;
  end;

procedure TKRKBalloonHint.WinControlWndProc(var AMessage: TMessage);
begin
  if AMessage.Msg = WM_NOTIFY then
    if Assigned(TWMNotify(AMessage).NMHdr) and (TWMNotify(AMessage).NMHdr^.code = TTN_LINKCLICK) then
      if Assigned(FOnLinkClick) then
        FOnLinkClick(Self);

  FOldWindowProc(AMessage);
end;

procedure TKRKBalloonHint.SetAssociatedWinControl(const Value: TWinControl);
begin
  UnlinkToolTip;
  try
    if Assigned(FAssociatedWinControl) then
      FAssociatedWinControl.WindowProc := FOldWindowProc;

    FAssociatedWinControl := Value;

    if Assigned(FAssociatedWinControl) then
    begin
      FToolInfo.hwnd := FAssociatedWinControl.Handle;
      FOldWindowProc := FAssociatedWinControl.WindowProc;
      FAssociatedWinControl.WindowProc := WinControlWndProc;
      SetAutoGetTexts(FAutoGetTexts);
      SetTipAlignment(FTipAlignment);
    end;
  finally
    LinkToolTip;
  end;
end;

Now you will have published OnLinkClick event which fires on tooltip link click.
Here is the example of usage at runtime:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, KRKBalloonHint;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    BalloonHint: TKRKBalloonHint;
    procedure OnLinkClick(Sender: TObject);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.OnLinkClick(Sender: TObject);
begin
  ShowMessage('Link clicked !');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  BalloonHint.TipText := 'This is a <A href="www.google.com">link</A>.';
  BalloonHint.Show;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  BalloonHint := TBalloonHint.Create(Self);
  BalloonHint.ParseLinks := True;
  BalloonHint.OnLinkClick := OnLinkClick;
  BalloonHint.AssociatedWinControl := Edit1;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  BalloonHint.Free;
end;

end.

Sign Up

Sign In

Forgot Password

The Archive Base Latest Questions

I’m trying to implement a simple Balloon Hint, using the tooltips_class32. In fact, all

Leave an answerCancel reply

1 Answer

Leave an answer
Cancel reply