Как изменить текст подсказки, пока подсказка отображается в TBalloonHint?

Question

Раньше я THint, и он работал с этим кодом:

procedure TMainForm.FormCreate(Sender: TObject); 
begin 
    Application.OnShowHint := AppShowHint; 
end; 

procedure TMainForm.AppShowHint(var HintStr: String; var CanShow: Boolean; var HintInfo: Controls.THintInfo); 
begin 
    HintInfo.ReshowTimeout := 1; 
end; 

Теперь я использую TBalloonHint и хочу изменить текст подсказки, когда подсказка отображаются. Вышеуказанная процедура не запускается.

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

Как достичь этого с помощью TBalloonHint?

Answer 1

TBalloonHint не поддерживает эту функцию. Следующий код (Delphi XE3) добавляет его.

Минусы:

• CPU нагрузка - каждый вызов TBalloonHint.ShowHint создает новый TCustomHintWindow
• мерцание при перерисовке

type 
    TMyHintWindow = class(THintWindow) 
    public 
    function CalcHintRect(MaxWidth: Integer; const AHint: string; 
     AData: TCustomData): TRect; override; 
    function ShouldHideHint: Boolean; override; 
    end; 

var BalloonHint: TBalloonHint; 
    _HintPos: TPoint; 

function TMyHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; 
    AData: TCustomData): TRect; 
begin 
    Result := Rect(0,0,0,0); 
end; 

function TMyHintWindow.ShouldHideHint: Boolean; 
begin 
    Result := True; 
    BalloonHint.Free; BalloonHint := nil; 
end; 

procedure TMainForm.FormCreate(Sender: TObject); 
begin 
    HintWindowClass := TMyHintWindow; 
    Application.OnShowHint := AppShowHint; 
end; 

procedure TMainForm.AppShowHint(var HintStr: String; var CanShow: Boolean; var HintInfo: THintInfo); 
begin 
    HintInfo.ReshowTimeout := 1; 

    if not Assigned(BalloonHint) 
    then begin 
    BalloonHint := TBalloonHint.Create(Self); 
    _HintPos := Point(MaxInt, MaxInt); 
    end; 

    if (_HintPos <> HintInfo.HintPos) or (BalloonHint.Description <> HintStr) 
    then begin 
    _HintPos := HintInfo.HintPos; 
    BalloonHint.Description := HintStr; 
    BalloonHint.ShowHint(_HintPos); 
    end; 
end; 

Другого пути:

• переписывает TMyHintWindow.CalcHintRect и .Paint принимая код из TBalloonHint

• переписывания TMyHintWindow использования Tooltip Controls

Добавить: контроля использования подсказки. Попробуйте также установить HintInfo.ReshowTimeout := 25.

uses Windows, Vcl.Controls, System.Classes, Winapi.CommCtrl, Winapi.Messages; 

type 
    TTooltipHintWindow = class(THintWindow) 
    private 
    TooltipWnd: HWND; 
    TooltipInfo: TToolInfo; 
    TooltipText: string; 
    TooltipPos: TPoint; 
    public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
    procedure ActivateHint(Rect: TRect; const AHint: string); override; 
    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: TCustomData): TRect; override; 
    function ShouldHideHint: Boolean; override; 
    end; 

implementation 

procedure TTooltipHintWindow.ActivateHint(Rect: TRect; const AHint: string); 
begin 
    inherited; 
    if (TooltipText <> AHint) 
    then begin // update text 
    TooltipText := AHint; 
    TooltipInfo.lpszText := PChar(TooltipText); 
    SendMessage(TooltipWnd, TTM_UPDATETIPTEXT, 0, LParam(@TooltipInfo)); 
    end; 
    if (TooltipPos <> Rect.TopLeft) 
    then begin // update position 
    TooltipPos := Rect.TopLeft; 
    SendMessage(TooltipWnd, TTM_TRACKPOSITION, 0, PointToLParam(TooltipPos)); 
    end; 
    // show 
    SendMessage(TooltipWnd, TTM_TRACKACTIVATE, WParam(True), LParam(@TooltipInfo)); 
end; 

function TTooltipHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; 
    AData: TCustomData): TRect; 
begin 
    Result := Rect(0,0,0,0); 
end; 

constructor TTooltipHintWindow.Create(AOwner: TComponent); 
var font, boldfont: HFONT; 
    logfont: TLogFont; 
begin 
    inherited; 
    // create tooltip 
    TooltipWnd := CreateWindowEx(WS_EX_TOPMOST or WS_EX_TRANSPARENT, 
    TOOLTIPS_CLASS, nil, 
    TTS_NOPREFIX or TTS_ALWAYSTIP or TTS_BALLOON, 
    0, 0, 0, 0, 0, 0, HInstance, nil); 
    // set bold font 
    font := SendMessage(TooltipWnd, WM_GETFONT, 0, 0); 
    if (font <> 0) 
    then begin 
    if GetObject(font, SizeOf(logfont), @logfont) > 0 
    then begin 
     logfont.lfWeight := FW_BOLD; 
     boldfont := CreateFontIndirect(logfont); 
     SendMessage(TooltipWnd, WM_SETFONT, boldfont, 0); 
    end; 
    end; 
    // set maximum width 
    SendMessage(TooltipWnd, TTM_SETMAXTIPWIDTH, 0 , 400); 
    // init 
    FillChar(TooltipInfo, SizeOf(TooltipInfo), 0); 
    TooltipInfo.cbSize := SizeOf(TooltipInfo); 
    TooltipInfo.uFlags := TTF_TRACK or TTF_TRANSPARENT; 
    TooltipInfo.uId := 1; 
    SendMessage(TooltipWnd, TTM_ADDTOOL, 0, LParam(@TooltipInfo)); 
end; 

destructor TTooltipHintWindow.Destroy; 
begin 
    DestroyWindow(TooltipWnd); 
    inherited; 
end; 

function TTooltipHintWindow.ShouldHideHint: Boolean; 
begin 
    inherited; 
    // hide 
    SendMessage(TooltipWnd, TTM_TRACKACTIVATE, WParam(False), LParam(@TooltipInfo)); 
    TooltipPos := Point(MaxInt, MaxInt); 
    TooltipText := ''; 
end;