Link to home
Start Free TrialLog in
Avatar of PeterDelphin
PeterDelphin

asked on

Show a thumbnail hint when hovering mouse-ponter over menu-item?

In a Delphi Vcl Application, when I hover the mouse-pointer over a menu-item then I would like to dynamically show a thumbnail hint (determined at runtime) next to the menu item:

User generated image
Does anybody know how to achieve this?
Avatar of Sinisa Vuk
Sinisa Vuk
Flag of Croatia image

It is possible. Just to know - I'm working on example but short on time right now...
Ok. here it is.
1. you need to use TAction-s assigned to each MenuItem you use for hints.
uses ... ClipBrd, ActnList;

...

procedure TForm1.Action1Execute(Sender: TObject);
begin
 //do something with Clipboard bitmap
end;

procedure TForm1.Action1Update(Sender: TObject);
begin
  TAction(Sender).Enabled := Clipboard.HasFormat(CF_BITMAP);

  if TAction(Sender).Enabled then TAction(Sender).Hint := 'CF_BITMAP'
  else TAction(Sender).Hint := '';
end;

procedure TForm1.Action2Execute(Sender: TObject);
begin
 //do something with Clipboard text
end;

procedure TForm1.Action2Update(Sender: TObject);
begin
  TAction(Sender).Enabled := Clipboard.HasFormat(CF_TEXT);

  if TAction(Sender).Enabled then TAction(Sender).Hint := 'CF_TEXT'
  else TAction(Sender).Hint := '';
end;

Open in new window


This way your Hint will assigned if some Clipboard format is ready and force to start showing Hint - this is big.
Make own inherited THintWindow:
...
type
  //TMyAppHook = class(TApplication);

  TMenuItemPreviewHint = class(THintWindow)
    private
      showTimer : TTimer;
      hideTimer : TTimer;
      HintBmp: TPicture;
      procedure DoHide(Sender : TObject);
      procedure DoShow(Sender : TObject);
    protected
      procedure Paint; override;
    public
      constructor Create(AOwner : TComponent); override;
      destructor Destroy; override;
      procedure DoActivateHint(HintPos: TPoint; HintText: String);
   end;

type
  TForm1 = class(TForm)
    Button1: TButton;
    PopupMenu1: TPopupMenu;
    Panel1: TPanel;
    PasteImage1: TMenuItem;
    PasteText1: TMenuItem;
    Label1: TLabel;
    Edit1: TEdit;
    ActionList1: TActionList;
    Action1: TAction;
    Action2: TAction;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Action1Execute(Sender: TObject);
    procedure Action1Update(Sender: TObject);
    procedure Action2Execute(Sender: TObject);
    procedure Action2Update(Sender: TObject);
  private
    MyPicHint: TMenuItemPreviewHint;
    procedure DisplayHint(Sender: TObject);
    { Private declarations }
  public
    { Public declarations }
  end;
...
//http://smiguel.free.fr/exempledetaille/juin01/exemplejuin01.htm
//http://capecodgunny.blogspot.hr/2014/12/how-to-display-menu-item-hints-in.html
//https://www.thoughtco.com/how-to-display-menu-item-hints-1058397
//https://svn.code.sf.net/p/monex/code/trunk/Komponente/KalkulatorEdit/MultiLineHint.pas
//form *****************
procedure TForm1.DisplayHint(Sender: TObject);
var
  P: TPoint;
  sHint: String;
begin
  if Application.Hint = '' then
  begin
    Application.CancelHint;
    MyPicHint.Hide;
  end
  else
  begin
    sHint := Application.Hint;
    GetCursorPos(P);

    //show build in
    if (sHint = 'CF_BITMAP') or (sHint = 'CF_TEXT') then
    begin
      //comes from menuitem
      MyPicHint.DoActivateHint(P, sHint); //show custom hint
    end
    else
    begin
      //all other
      Application.ActivateHint(P); //show build in hint
    end;
  end;
end;

//do some initialization here ....
procedure TForm1.FormCreate(Sender: TObject);
begin
  MyPicHint := TMenuItemPreviewHint.Create(nil);
  Application.OnHint := DisplayHint;
  Application.HideHint;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Application.HideHint;
  Application.OnHint := nil;
  MyPicHint.Free;
end;

Open in new window


... TMenuItemPreviewHint implementation - with two timers - one - time to show and one - time to hide (after showing)
{ TMenuItemPreviewHint }

constructor TMenuItemPreviewHint.Create(AOwner: TComponent);
begin
  inherited;
  
  showTimer := TTimer.Create(self) ;
  showTimer.Interval := Application.HintPause;

  hideTimer := TTimer.Create(self) ;
  hideTimer.Interval := Application.HintHidePause;

  HintBmp := TPicture.Create;
end;

destructor TMenuItemPreviewHint.Destroy;
begin
  hideTimer.OnTimer := nil;
  showTimer.OnTimer := nil;
  HintBmp.Free;
  self.ReleaseHandle;

  hideTimer.Free;
  showTimer.Free;
  inherited;
end;

procedure TMenuItemPreviewHint.DoActivateHint(HintPos: TPoint; HintText: String);
begin
  //force remove of the "old" hint window
  DoHide(self) ;

  Self.Hint := HintText;
  Self.Color := Application.HintColor;

  showTimer.OnTimer := DoShow;
  hideTimer.OnTimer := DoHide;
end;

procedure TMenuItemPreviewHint.DoHide(Sender: TObject);
begin
  self.ReleaseHandle;
  hideTimer.OnTimer := nil;
end;

procedure TMenuItemPreviewHint.Paint;
var
  R: TRect;
begin
  //draw internal image if exists
  if HintBmp.Width>0 then
  begin
    R := ClientRect;
    Canvas.Draw(R.Left+1, R.Top+1, HintBmp.Graphic);
  end
  else
    inherited;  //draw common text
end;

procedure TMenuItemPreviewHint.DoShow(Sender: TObject);
var
  p: TPoint;
  r : TRect;
  iHintControl: integer;
  s, sHint: String;
  bmp: TPicture;
begin
  sHint := Self.Hint;

  iHintControl := 0;
   //show build in
  if (sHint = 'CF_BITMAP') then iHintControl := 1
  else if (sHint = 'CF_TEXT') then iHintControl := 2;  //... and so on ...

  GetCursorPos(p);
  //free old info
  HintBmp.Assign(nil);

  case iHintControl of
    1: //bitmap
      begin
        //MyPicHint.DoActivateHint(PasteImage1);
        bmp := TPicture.Create;
        try
          try
            bmp.Assign(Clipboard);
            if bmp.Width>0 then
            begin
              r := Rect(1, 1, bmp.Width+2, bmp.Height+2);
              HintBmp.Assign(bmp);
              OffsetRect(r, p.X + 100, p.Y);
              ActivateHint(r, '');
            end;
          except
            // Can't convert
          end;
        finally
          bmp.Free;
        end;
      end;
    2: //text
      begin
        try
          sHint := Clipboard.AsText;
          s := GetLongHint(sHint);
          r := Rect(0, 0, 0, 0);
          //calc size
          r := CalcHintRect(200, s, nil);

          OffsetRect(r, p.X + 100, p.Y);
          ActivateHint(r, s);
        except
        end;
      end;
  end;

  showTimer.OnTimer := nil;
end;

Open in new window


I implement two common Clipboard formats: text and bitmap. When text is detected - it calls common Hint window, but on bitmap - shows custom made: TMenuItemPreviewHint class.
This question needs an answer!
Become an EE member today
7 DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform.
View membership options
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.