Как перехватить уведомление TTN_LINKCLICK?

Question

Я пытаюсь реализовать простой Balloon Hint, используя "tooltips_class32". На самом деле все поведение корректно, кроме ссылок на воздушном шаре.

Мои воздушные шары создаются правильно, и я вижу ссылку, но когда я нажимаю на ссылку, ничего не происходит.

Я пытался перехватить уведомление TTN_LINKCLICK о двух оконных процедурах. Один из моей подсказки и один из родительского окна моей подсказки.

Я знаю, что это уведомление отправлено как WM_NOTIFY, но ничего не делается, когда я нажимаю на ссылку.

Итак, как перехватить уведомление TTN_LINKCLICK? Как сделать так, чтобы это работало на Delphi?

Ниже приведен полный код моего компонента TKRKBalloonHint.

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.

Справка Delphi сообщает TTN_LINKCLICK, что сообщение отправлено как уведомление WM_NOTIFY. А в нескольких местах в интернете сказано, что это сообщение отправляется в родительское окно всплывающей подсказки. Итак, просто на родительской форме моего воздушного шара я создал такой метод:

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;

Когда я нажимал на ссылку, шоу никогда не срабатывает. Что теперь делать?

Answer 1

Я бы перенаправил TControl.WindowProc вашего связанного элемента управления и вызвал бы событие в случае WM_NOTIFY сообщения с уведомлением TTN_LINKCLICK. Так что я бы сделал это так.

В любом случае, очень хорошо читаемый код, но у вас есть небольшие проблемы. Например. в SetAutoGetTexts вы должны проверить, есть ли в списке строк какие-либо элементы, прежде чем выполнять итерацию, в случае, если FAssociatedWinControl.Hint пусто; произойдет сбой;)

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;

Теперь у вас будет опубликовано OnLinkClick событие, которое срабатывает при щелчке ссылки всплывающей подсказки.
Вот пример использования во время выполнения:

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.