[D7] Hint avec Image

**Charly910** · 27/05/2026, 13h50

Bonjour,
j'ai un Checklistbox, dont les items sont des nom de fichiers image Jpeg ou Bmp. J'aimerais que lorsque le pointeur de la souris survole un item, on affiche une vignette de l'image.

J'ai vu qu'il existe THintWindows, mais je ne trouve pas d'exemple et je ne sais pas comment faire. Il faudrait surement que je fasse une classe dérivée de THintWindows.

Quelqu'un a t il un exemple pour que je puisse démarrer ?

A+
Charly

**ShaiLeTroll** · 27/05/2026, 18h13

Utilise un THintWindowClass pour afficher une vignette ... en théorie c'est possible, en D7, je faisais un Hint HTML, mais je n'utilisais pas le mécanisme de Hint car il fallait un Hint sur un control inactif (enabled à false mais ça n'existe pas), cela passait par un thread, si je retrouve ce vieux code

Même si c'est pas une vignette, dans le mois, un sujet sur un Hint avancé a été lancé, dessiner manuellement un texte et dessiner une image, ce n'est pas très différent.

**Charly910** · 27/05/2026, 18h16

J'ai fait ça, mais après ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
unit ImgHint;
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, JPEG ;
 
type
  TImageHintWindow = class(THintWindow)
  private
    FImage: TImage;                     // Pour afficher l'image
    FImageCache: TStringList;           // Pour stocker le nom des fichiers
 
 
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;
 
 
implementation
 
{ TImageHintWindow }
 
{ ======================================================================= }
constructor TImageHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Color := clInfoBk;
  FImage := TImage.Create(Self);
  FImage.Parent := Self;
  FImage.Align := alClient;
  FImage.Stretch := True;
  FImage.Center := True;
  FImage.Proportional := True;
  FImageCache := TStringList.Create;
end;
{ ======================================================================= }
destructor TImageHintWindow.Destroy;
begin
  FImageCache.Free;
  inherited Destroy;
end;
{ ======================================================================= }
 
initialization
  HintWindowClass := TImageHintWindow;
 
 
end.

A+
Charly

**ShaiLeTroll** · 27/05/2026, 18h18

Oui un début mais c'est surtout la position et les dimensions fournie à Rect de ActivateHint qui sont cruciales

C'est ce qui pose le plus de problème, le calcul du bon Rect

Attention, HintWindowClass va modifier la classe pour tous les hints ... prudence !
Un OnHint + ActivateHint manuel serait plus prudent, surtout pour l'échange du Bitmap, par exemple dans Objects[]

**Andnotor** · 27/05/2026, 19h03

Un peu tard pour certaines remarques mais puisque j'avais déjà commencé à taper cette réponse

Le Hint en soi n'a pas de grandes complications, redéfinir :

ActivateHint pour les initialisations ;
CalcHintRect pour sa taille ;
Paint pour son dessin (mais on pourrait aussi créer des contrôles dynamiquement) ;
ShouldHideHint pour autoriser ou non sa fermeture (sinon jouer sur le délai d'affichage pour une fermeture automatique).

Quelque chose comme ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
type
  TMyHintWindow = class(THintWindow)
  private
    Image: string;
    ShouldHide: boolean;
  protected
    procedure Paint; override;
  public
    procedure ActivateHint(aRect: TRect; const aHint: string); override;
    function CalcHintRect(aMaxWidth: Integer; const aHint: string; aData: TCustomData): TRect; override;
    function ShouldHideHint: Boolean; override;
  end;

En détail.

Le hint ne sait pas quel contrôle l'a fait apparaitre. Pour cela il faut regarder Application.HintControl. On récupére l'élément sous la souris et si dans une zone vide, ferme immédiatement le hint par Application.CancelHint.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
procedure TMyHintWindow.ActivateHint(aRect: TRect; const aHint: string);
var
  i: integer;
begin
  if Application.HintControl is TCheckListBox then
    with TCheckListBox(Application.HintControl) do
    begin
      i := ItemAtPos(ScreenToClient(Mouse.CursorPos), TRUE);
 
      if i > -1 then
      begin
        Image := Items[i];
        inherited;
        Exit;
      end;
    end;
 
  // Zone vide
  ShouldHide := TRUE;
  Application.CancelHint;
end;

La fermeture du hint est normalement automatique après quelques secondes. Ici on le laisse ouvert indéfiniment à moins qu'il n'y ait aucun élément à afficher (ShouldHide ci-dessus).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
function TMyHintWindow.ShouldHideHint: Boolean;
begin
  Result := ShouldHide;
  ShouldHide := FALSE;
end;

Pas grand chose à dire sur les deux autres méthodes.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
function TMyHintWindow.CalcHintRect(aMaxWidth: Integer; const aHint: string; aData: TCustomData): TRect;
begin
  Result := TRect.Create(0, 0, 200, 200);
end;
 
procedure TMyHintWindow.Paint;
var
  Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;
  try
    Bmp.LoadFromFile(Image);
    Canvas.Draw(10, 10, Bmp);
  finally
    Bmp.Free;
  end;
end;

Au niveau de la fiche maintenant. Il faut remplacer la classe Hint de base par la nôtre (variable globale HintWindowClass), et logiquement uniquement dans le CheckListBox pour ne pas altérer le comportement des autres contrôles.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
procedure TForm1.CheckListBox1MouseEnter(Sender: TObject);
begin
  HintWindowClass := TMyHintWindow;
end;
 
procedure TForm1.CheckListBox1MouseLeave(Sender: TObject);
begin
  HintWindowClass := THintWindow;
end;

Mais le hint n'apparait qu'une fois à l'entrée du contrôle, il faut donc le réarmer au déplacement de la souris sur un nouvel élément.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
procedure TForm1.CheckListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  // Code simple avec scintillement. A toi de voir pour t'assurer du changement d'élément.
  Application.ActivateHint(Mouse.CursorPos);
end;

Et même s'il ne sera pas utilisé le contrôle doit avoir un hint pour générer l'affichage.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
procedure TForm1.FormCreate(Sender: TObject);
begin
  CheckListBox1.Hint := '(Pas utilisé)';
  CheckListBox1.ShowHint := TRUE;
end;

Voili, voilou

**ZonZorg** · 27/05/2026, 21h28

Application.HintControl n'existe pas dans [D7]

pourquoi ne pas utiliser une deuxiéme fenêtre sans bordure ?

Nom : Hint_Image1.png
Affichages : 105
Taille : 35,1 Ko

Nom : Hint_Image1.png
Affichages : 105
Taille : 35,1 Ko

mon test:Hint avec Image.zip

(ça m'a l'air plus simple (et donc moins complexe à mettre en place))

maintenant il faut chercher quand la souris est hors de la fenetre ?
je cherche : "delphi mouse not in form"
me donne la fonction onmouseleave, qui n'existe pas dans [D7] (<--- voir la suites des messages pour creer CheckListBox1.OnMouseLeave)

unit1:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
 
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, CheckLst, jpeg, ExtCtrls;
 
type
  TForm1 = class(TForm)
    CheckListBox1: TCheckListBox;
    procedure CheckListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
  itemindexprec:Integer;
implementation
 
uses Unit2;
 
{$R *.dfm}
 
 
procedure TForm1.CheckListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var pt : tPoint;
    APoint: TPoint;
    Fichier:String;
begin
    APoint.X := X;
    APoint.Y := Y;
    CheckListBox1.ItemIndex := CheckListBox1.ItemAtPos(APoint, True);
    if (CheckListBox1.itemindex>=0) and (CheckListBox1.Checked[CheckListBox1.itemindex]) then
    begin
        Fichier:=CheckListBox1.Items[CheckListBox1.itemindex];
        if (fileexists(fichier)) then
        begin
              pt := Mouse.CursorPos;
              form2.Left:=pt.x+10;
              form2.top:=pt.y+10;
              form2.Show;
              if (itemindexprec<>CheckListBox1.itemindex) THEN Form2.image1.Picture.LoadFromFile(Fichier) // pour ne par relire le fichier quand on bouge en laterale
              else itemindexprec:=CheckListBox1.itemindex;
        end
        else
        form2.Hide;
    end
    else
    form2.Hide;
    if not form2.Active then itemindexprec:=-1;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
var i:integer;
begin
    itemindexprec:=-1;
    for i:=0 to pred(CheckListBox1.count) do CheckListBox1.Checked[i]:=true;
end;
 
end.

fiche unit1:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
 
object Form1: TForm1
  Left = 265
  Top = 180
  Width = 153
  Height = 256
  AutoSize = True
  BorderIcons = [biSystemMenu, biMinimize]
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object CheckListBox1: TCheckListBox
    Left = 0
    Top = 0
    Width = 137
    Height = 217
    ItemHeight = 13
    Items.Strings = (
      'Tulip.bmp'
      'Pothos.bmp'
      'Ficus.bmp'
      'Marigold.bmp'
      'Mint.bmp'
      'Rose.bmp'
      'Tulsi.bmp'
      'Bamboo.bmp'
      'Fern.bmp'
      'Orchid.bmp'
      'Peepal.bmp'
      'Cactus.bmp'
      'Lavender.bmp'
      'Lemon.bmp'
      'Banana.bmp')
    ParentShowHint = False
    ShowHint = True
    TabOrder = 0
    OnMouseMove = CheckListBox1MouseMove
  end
end

unit2:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
unit Unit2;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls;
 
type
  TForm2 = class(TForm)
    Image1: TImage;
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;
 
var
  Form2: TForm2;
 
implementation
 
{$R *.dfm}
 
end.

fiche unit 2:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
object Form2: TForm2
  Left = 693
  Top = 222
  AutoSize = True
  BorderIcons = []
  BorderStyle = bsNone
  Caption = 'Form2'
  ClientHeight = 158
  ClientWidth = 212
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Image1: TImage
    Left = 0
    Top = 0
    Width = 212
    Height = 158
    AutoSize = True
  end
end

**ZonZorg** · 28/05/2026, 09h26

en travaillant avec la source de Andnotor

j'ai fini par faire ça:

Nom : Hint avec Image 2.png
Affichages : 88
Taille : 26,5 Ko

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
 
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  pngimage,
  gifimage,
  Dialogs, StdCtrls, CheckLst, jpeg, ExtCtrls;
 
type
  TForm1 = class(TForm)
    CheckListBox1: TCheckListBox;
    procedure FormCreate(Sender: TObject);
    procedure CheckListBox1Enter(Sender: TObject);
    procedure CheckListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
    { Déclarations privées }
  public
  PROCEDURE AppShowHint(VAR HintStr: STRING; VAR CanShow: Boolean; VAR HintInfo: THintInfo); // gestion de l'aide (dans listtitre)
    { Déclarations publiques }
  end;
 
type
  TMyHintWindow = class(THintWindow)
  CONSTRUCTOR Create(AOwner: TComponent); override;
  private
    Image: string;
  protected
    procedure Paint; override;
  public
    procedure ActivateHint(aRect: TRect; const aHint: string); override;
  end;
 
 
var
  Form1: TForm1;
  itemindexprec:Integer;
  MyHintinfo: Thintinfo;
  lzwidth,lzheight:Integer;
  Letext:String;
  JPG_HEADER: array[0..2] of byte = ($FF, $D8, $FF);
  GIF_HEADER: array[0..2] of byte = ($47, $49, $46);
  BMP_HEADER: array[0..1] of byte = ($42, $4D);
  PNG_HEADER: array[0..3] of byte = ($89, $50, $4E, $47);
  TIF_HEADER: array[0..2] of byte = ($49, $49, $2A);
 
implementation
 
{$R *.dfm}
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
FUNCTION Getimagetype(Filename: STRING): STRING;
VAR
      STREAM: Tfilestream;
      Memstr: Tmemorystream;
BEGIN
      Result := '';
      STREAM := Tfilestream.Create(Filename, Fmopenread);
      Memstr := Tmemorystream.Create;
      TRY
            Memstr.COPYFROM(STREAM, 5);
            IF Memstr.SIZE > 4 THEN
            BEGIN
                  IF Comparemem(Memstr.MEMORY, @Jpg_Header, SIZEOF(Jpg_Header)) THEN Result := 'jpg' ELSE
                  IF Comparemem(Memstr.MEMORY, @Gif_Header, SIZEOF(Gif_Header)) THEN Result := 'gif' ELSE
                  IF Comparemem(Memstr.MEMORY, @Png_Header, SIZEOF(Png_Header)) THEN Result := 'png' ELSE
                  IF Comparemem(Memstr.MEMORY, @Bmp_Header, SIZEOF(Bmp_Header)) THEN Result := 'bmp' ELSE
                  IF Comparemem(Memstr.MEMORY, @Tif_Header, SIZEOF(Tif_Header)) THEN Result := 'tif' ELSE
            END;
            FINALLY
            STREAM.FREE;
            Memstr.FREE;
      END; {Try}
END; {Getimagetype}
 
 
CONSTRUCTOR TMyHintWindow.Create(AOwner: TComponent);
BEGIN
      INHERITED Create(AOwner);
END;
 
 
procedure TMyHintWindow.ActivateHint(aRect: TRect; const aHint: string);
var
  i: integer;
begin
  IF (MyHintinfo.Hintcontrol Is TCheckListBox) THEN WITH TCheckListBox(MyHintinfo.Hintcontrol) DO
    begin
          if lzwidth<>0 then
          aRect:=rect(Mouse.CursorPos.X+10,Mouse.CursorPos.Y+10,Mouse.CursorPos.X+11+lzwidth,Mouse.CursorPos.Y+7+lzheight)
          else aRect:=rect(0,0,1,1);
          i := ItemAtPos(ScreenToClient(Mouse.CursorPos), TRUE);
          if (i > -1) and (itemindexprec<>i) then
          begin
              Image := Items[i];
              inherited;
              Exit;
          end
     else itemindexprec:=-1;
    end;
  Application.CancelHint;{}
end;
 
procedure TMyHintWindow.Paint;
var Cpy:String;
    Bmp: TBitmap;
    Jpg: Tjpegimage;
    Png: Tpngobject;
    Gif: TGifImage;
    Tmp: TPicture;
begin
  Cpy:='';
  lzwidth:=0;
  lzheight:=0;
  if fileexists(Image) then
  begin
      Cpy:=Getimagetype(Image);
      Bmp := TBitmap.Create;
      try
            if cpy='bmp' THEN Bmp.LoadFromFile(Image);
            if cpy='jpg' THEN
            BEGIN
                  Jpg := Tjpegimage.Create;
                  try
                      Jpg.LoadFromFile(Image);
                      Bmp.ASSIGN(Jpg);
                  finally
                  Jpg.Free;
                  end;
            end;
            if cpy='png' THEN
            BEGIN
                  Png:= Tpngobject.Create;
                  try
                      Png.Loadfromfile (Image);
                      Bmp.ASSIGN(png);
                      Bmp.Width := Png.Width;
                      Bmp.Height := Png.Height;
                      Png.DRAW(Bmp.Canvas, Bmp.Canvas.Cliprect);
                  finally
                  png.Free;
                  end;
            end;
            if cpy='gif' THEN
            BEGIN
                  Tmp:=TPicture.Create;
                  Gif:=TGifImage.create;
                  try
                      Gif.LoadFromFile(Image);
                      Tmp.assign(Gif.Bitmap);
                      bmp.Assign(Tmp.Bitmap);
                  finally
                  Gif.Free;
                  tmp.Free;
                  end;
            end;{}
            if cpy<>'' then
            begin
                  lzwidth:=Bmp.Width;
                  lzheight:=Bmp.Height;
                  Canvas.Draw(-1, 0, Bmp);
            end;
            finally
            Bmp.Free;
      end;
  end;
end;
 
procedure TForm1.CheckListBox1Enter(Sender: TObject);
begin
   HintWindowClass := TMyHintWindow;
end;
 
procedure TForm1.CheckListBox1MouseMove(Sender: TObject;  Shift: TShiftState; X, Y: Integer);
begin
    Application.ActivateHint(Mouse.CursorPos);
end;
 
PROCEDURE Tform1.Appshowhint(VAR Hintstr: STRING; VAR Canshow: BOOLEAN; VAR Hintinfo: Thintinfo);
BEGIN
    MyHintinfo:=Hintinfo;
    hintstr:=' ';
END;
 
procedure TForm1.FormCreate(Sender: TObject);
var i:integer;
begin
    TMyHintWindow.Create(self);
    Application.OnShowHint := AppShowHint;
    CheckListBox1.Hint := '';
    CheckListBox1.ShowHint := TRUE;
    itemindexprec:=-1;
    for i:=0 to pred(CheckListBox1.count) do CheckListBox1.Checked[i]:=true;
end;
end.

fiche:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
object Form1: TForm1
  Left = 265
  Top = 180
  Width = 153
  Height = 256
  AutoSize = True
  BorderIcons = [biSystemMenu, biMinimize]
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object CheckListBox1: TCheckListBox
    Left = 0
    Top = 0
    Width = 137
    Height = 217
    ItemHeight = 13
    Items.Strings = (
      'Tulip.jpg'
      'Pothos.png'
      'Ficus.bmp'
      'Marigold.bmp'
      'Mint.bmp'
      'Rose.bmp'
      'Tulsi.bmp'
      'Bamboo.bmp'
      'Fern.bmp'
      'Orchid.bmp'
      'Peepal.bmp'
      'Cactus.bmp'
      'Lavender.bmp'
      'Lemon.gif'
      'Banana.jpg')
    ParentShowHint = False
    ShowHint = True
    TabOrder = 0
    OnEnter = CheckListBox1Enter
    OnMouseMove = CheckListBox1MouseMove
  end
end

Hint avec Image 2.zip

gere le bmp,jpg,png et fichier gif

**Andnotor** · 28/05/2026, 10h15

Tu peux ajouter TrackMouseEvent dans OnMouseMove du Checklistbox et ainsi recevoir un message WM_MOUSELEAVE.

A voir s'il n'y a pas de conflit avec la fiche, sinon redéfinir TChecklistbox pour traiter ce message.

**Charly910** · 28/05/2026, 11h39

@ ZonZorg : merci, c'est assez rapide. Effectivement, il faudrait tracker le sortie du CheckListBox. Il faudrait aussi un timer pour temporiser. Je vais aussi tester la solution de ShailLeTroll et AndnotOr

A+
Charly

**ShaiLeTroll** · 28/05/2026, 11h56

Je n'ai plus le code D7 du Hint lancé via un Thread pour gérer les controles disabled, et je n'ai que des fragments pour C++ et TMenuItem

Cependant, je n'utilise pas trop de TListBox mais plutôt une TListView, OnInfoTip est parfait pour ce genre de manip, on peut afficher une TForm, comme évoqué plus haut par ZonZorg, un Timer pour reproduit l'effet d'un Hint, voir en particulier CreateNew (pas de bordure) et CreateParams (pas de focus)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
procedure TxxxHistoricForm.xxxArchivesShowFormattedCommentOnInfoTipEventHandler(Sender: TObject; Item: TListItem; var InfoTip: string);
begin
  if Item is TArchiveListItem then
  begin
    with TArchiveListItem(Item).Entity do
    begin
      if Comment <> '' then
        TMarkdownViewer.ExecuteAsHint(Comment, xxx.Params.xxxArchiveFormattedCommentWithMDComment);
    end;
  end;
end;

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
unit xxx_MDUtilities;
 
interface
 
uses
  System.Classes,
  Vcl.Forms, Vcl.Controls, Vcl.ExtCtrls,
  SHDocVw;
 
type
  TMarkdownViewer = class(TObject)
  strict private
    type
      TFormHint = class(TForm)
      private
        type
          TCloseTimer = class(TTimer)
          private
            procedure TimerEvent(Sender: TObject);
          public
            constructor Create(AOwner: TComponent); override;
          end;
 
      private
        FContent: string;
      protected
        procedure CreateParams(var Params: TCreateParams); override;
      public
        constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
        destructor Destroy(); override;
      end;
  private
    class var
      FForm: TForm;
  private
    class procedure ShowAsHTML(const AContent: string; AShowMDComment: Boolean);
    class function ShapeAsHTML(const AContent: string; AShowMDComment: Boolean): string;
    class procedure SeizureNavigation(ASender: TObject; const pDisp: IDispatch; const URL: OleVariant; const Flags: OleVariant; const TargetFrameName: OleVariant; const PostData: OleVariant; const Headers: OleVariant; var Cancel: WordBool);
    class procedure SeizureScript(ASender: TObject; const pDispWindow: IDispatch);
    class procedure SeizureFileDownload(ASender: TObject; ActiveDocument: WordBool; var Cancel: WordBool);
  public
    class procedure Execute(const AContent: string; AShowMDComment: Boolean = False);
    class procedure ExecuteAsHint(const AContent: string; AShowMDComment: Boolean = False);
  end;
 
implementation
 
uses Vcl.Dialogs, Vcl.Clipbrd,
  System.UITypes,
  System.Variants, System.SysUtils,
  Winapi.Windows, Winapi.ActiveX, MSHTML,
  MarkdownProcessor;
 
{ TMarkdownViewer }
 
//------------------------------------------------------------------------------
class procedure TMarkdownViewer.Execute(const AContent: string; AShowMDComment: Boolean = False);
begin
  if FForm is TFormHint then
    FreeAndNil(FForm);
 
  if not Assigned(FForm) then
  begin
    FForm := TForm.Create(Application);
    FForm.Position := poDesigned;
    FForm.Width := Screen.WorkAreaWidth div 2;
    FForm.Height := Screen.WorkAreaHeight div 2;
    FForm.Top := Mouse.CursorPos.Y;
    FForm.Left := Screen.ActiveForm.Left + 20;
  end;
 
  ShowAsHTML(AContent, AShowMDComment);
  FForm.Show();
  FForm.BringToFront();
end;
 
//------------------------------------------------------------------------------
class procedure TMarkdownViewer.ExecuteAsHint(const AContent: string; AShowMDComment: Boolean = False);
begin
  if Assigned(FForm) then
  begin
    if FForm is TFormHint then
    begin
      if TFormHint(FForm).FContent <> AContent then
        FreeAndNil(FForm);
    end
    else
    begin
      if not FForm.Visible then
        FreeAndNil(FForm)
      else
        Exit;
    end;
  end;
 
  if not Assigned(FForm) then
  begin
    FForm := TFormHint.CreateNew(Application);
    FForm.Position := poDesigned;
    FForm.Width := Screen.WorkAreaWidth div 2;
    FForm.Height := Screen.WorkAreaHeight div 2;
    FForm.Top := Mouse.CursorPos.Y;
    if Mouse.CursorPos.X + 20 + FForm.Width > Screen.WorkAreaWidth then
      FForm.Left := Screen.ActiveForm.Left + 20
    else
      FForm.Left := Mouse.CursorPos.X + 20;
 
    ShowAsHTML(AContent, AShowMDComment);
    TFormHint(FForm).FContent := AContent;
 
    FForm.Show();
    TMarkdownViewer.TFormHint.TCloseTimer.Create(FForm);
  end;
end;
 
//------------------------------------------------------------------------------
class procedure TMarkdownViewer.SeizureFileDownload(ASender: TObject; ActiveDocument: WordBool; var Cancel: WordBool);
begin
  Cancel := True;
  MessageDlg('File Download not allowed', mtWarning, [mbAbort], 0);
end;
 
//------------------------------------------------------------------------------
class procedure TMarkdownViewer.SeizureNavigation(ASender: TObject; const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool);
begin
  Cancel := True;
  Clipboard.AsText := URL;
  MessageDlg('URL copied to Clipboard', mtInformation, [mbOK], 0);
end;
 
//------------------------------------------------------------------------------
class procedure TMarkdownViewer.SeizureScript(ASender: TObject; const pDispWindow: IDispatch);
begin
  MessageDlg('Script not allowed', mtWarning, [mbAbort], 0);
end;
 
//------------------------------------------------------------------------------
class function TMarkdownViewer.ShapeAsHTML(const AContent: string; AShowMDComment: Boolean): string;
const
  COMMENT_START = '&lt;!--';
  COMMENT_END = '--&gt;';
 
  procedure ReProcessComments(var AHTMLContent: string);
  begin
    AHTMLContent := StringReplace(AHTMLContent, COMMENT_START, '<i>', [rfReplaceAll]);
    AHTMLContent := StringReplace(AHTMLContent, COMMENT_END, '</i>', [rfReplaceAll]);
  end;
 
  procedure UnProcessComments(var AHTMLContent: string);
  begin
    AHTMLContent := StringReplace(AHTMLContent, COMMENT_START, '<!--', [rfReplaceAll]);
    AHTMLContent := StringReplace(AHTMLContent, COMMENT_END, '-->', [rfReplaceAll]);
  end;
 
begin
  with TMarkdownProcessor.CreateDialect(mdCommonMark) do
  try
    Result := Process(AContent);
    if AShowMDComment then
      ReProcessComments(Result)
    else
      UnProcessComments(Result);
  finally
    Free();
  end;
end;
 
//------------------------------------------------------------------------------
class procedure TMarkdownViewer.ShowAsHTML(const AContent: string; AShowMDComment: Boolean);
var
  WebBrowser: TWebBrowser;
  Doc: IHTMLDocument2;
  Body: PSafeArray; // https://www.developpez.net/forums/d464072/environnements-developpement/delphi/web-reseau/afficher-page-html-delphi/#post2794797
begin
  WebBrowser := TWebBrowser(FForm.FindComponent('WebBrowser'));
  if Assigned(WebBrowser) then
    FreeAndNil(WebBrowser);
 
  WebBrowser := TWebBrowser.Create(FForm);
  TComponent(WebBrowser).Name := 'WebBrowser';
  WebBrowser.Navigate('about:blank');
  WebBrowser.Align := alClient;
  WebBrowser.SetParentComponent(FForm);
 
  WebBrowser.Offline := True;
  WebBrowser.OnBeforeNavigate2 := SeizureNavigation;
  WebBrowser.OnBeforeScriptExecute := SeizureScript;
  WebBrowser.OnFileDownload := SeizureFileDownload;
 
  Body := PSafeArray(TVarData(VarArrayOf([ShapeAsHTML(AContent, AShowMDComment)])).VArray);
  Doc := WebBrowser.Document as IHTMLDocument2;
  Doc.Write(Body);
end;
 
{ TMarkdownViewer.TFormHint }
 
//------------------------------------------------------------------------------
constructor TMarkdownViewer.TFormHint.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
begin
  inherited CreateNew(AOwner, Dummy);
 
  BorderStyle := bsNone;
  BorderIcons := [];
end;
 
//------------------------------------------------------------------------------
procedure TMarkdownViewer.TFormHint.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
 
  Params.ExStyle := Params.ExStyle or WS_EX_NOACTIVATE or WS_EX_CLIENTEDGE;
end;
 
//------------------------------------------------------------------------------
destructor TMarkdownViewer.TFormHint.Destroy();
begin
  if Self = TMarkdownViewer.FForm then
    TMarkdownViewer.FForm := nil;
 
  inherited Destroy();
end;
 
{ TCloseTimer }
 
//------------------------------------------------------------------------------
constructor TMarkdownViewer.TFormHint.TCloseTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
 
  Interval := Application.HintHidePause; // On ne le laisse pas plus de x secondes !
  OnTimer := TimerEvent;
end;
 
//------------------------------------------------------------------------------
procedure TMarkdownViewer.TFormHint.TCloseTimer.TimerEvent(Sender: TObject);
begin
  if Assigned(Owner) and (Owner is TMarkdownViewer.TFormHint) then
    TMarkdownViewer.TFormHint(Owner).Release();
end;
 
 
end.

Le comportement de Hint est paramétrable

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
      Form := TxxxHistoricForm.Create(nil);
      with Form do
      try
        Caption := Format('Historic of %s (%d)', [Axxx.Name, Axxx.xxxID]);
...
        if xxx.Params.xxxArchivesShowFormattedCommentOnInfoTip then
          lvArchives.OnInfoTip := xxxArchivesShowFormattedCommentOnInfoTipEventHandler
        else if xxx.Params.xxxArchivesShowRawCommentOnInfoTip then
          lvArchives.OnInfoTip := xxxArchivesShowRawCommentOnInfoTipEventHandler
        else
          lvArchives.OnInfoTip := nil;
 
..

Nom : Nouvelle image bitmap.jpg
Affichages : 94
Taille : 73,7 Ko

**Informt2025** · 28/05/2026, 17h16

Une autre alternative via CM_HINTSHOW,
La propriété EnableImgHint est pour éviter que le nouveau comportement du hint soit appliqué sur toutes les listbox

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;
 
type
  TMyHintWindow = class(THintWindow)
  private
    FImage: TImage;
  public
    function CalcHintRect(MaxWidth: Integer; const AHint: string;
         AData: Pointer): TRect; override;
  end;
 
  TListBox = class(StdCtrls.TListBox)
  private
    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  public
    EnableImgHint: boolean;
  end;
 
  TForm1 = class(TForm)
    ListBox1: TListBox;
    ListBox2: TListBox;
    procedure FormCreate(Sender: TObject);
 
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TListBox.CMHintShow(var Message: TMessage);
var
 idx: integer;
begin
  inherited;
  if not EnableImgHint then
     exit;
 
  with PHintInfo(Message.LParam)^ do
  begin
    idx := ItemAtPos(CursorPos, true);
    if idx <> -1 then
    begin
       HintStr := Items[Idx];
       CursorRect := ItemRect(Idx);
       HintPos := ClientToScreen(Point(CursorRect.Right, CursorRect.Top));
       HintData := Self;
       Message.Result := 0;
    end else
        Message.Result := 1;
  end;
end;
 
 
{ TMyHintWindow }
 
function TMyHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string;
  AData: Pointer): TRect;
begin
  if TObject(AData) is TCustomListBox then
  begin
      FImage.Free;
      FImage:= TImage.Create(Self);
      FImage.Parent := Self;
      FImage.AutoSize :=True;
      FImage.Picture.LoadFromFile('C:\Users\...'+ AHint);
      Result := FImage.ClientRect;
  end else
  begin
    FreeAndNil(FImage);
    Result := Inherited CalcHintRect(MaxWidth, AHint, AData);
  end;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
 Listbox1.EnableImgHint := true;
end;
 
 
initialization
 HintWindowClass := TMyHintWindow;
 
end.

**Charly910** · 29/05/2026, 11h41

Bonjour à tous,

j'ai essayé de mettre en œuvre la solution de AndOrNot, mais j'ai de nombreusese erreurs dont :

[Erreur] ImgHint2.pas(22): Identificateur non déclaré : 'TCustomData'
[Erreur] ImgHint2.pas(23): Méthode 'ShouldHideHint' non trouvée dans la classe de base

de plus MouseLeave n'existe pas en D7 (bon, je pourrais essayer en D12)

la deuxième solution de ZonZorg ne fonctionne pas chez moi, le Hint ne s'affiche pas ? j'ai du faire une erreur

A+
Charly

**ZonZorg** · 29/05/2026, 16h53

pour le MouseLeave TrackMouseEvent de "Andnotor"

dans l'exemple de "deuxiéme fenêtre sans bordure"
j'ai ajouté

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
 
type
  TForm1 = class(TForm)
    CheckListBox1: TCheckListBox;
    procedure CheckListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
  private
    procedure CheckListBoxMouseLeave(Sender: TObject);
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;
 
type
  TCheckListBox = class(CheckLst.TCheckListBox)
  private
    FOnMouseLeave: TNotifyEvent;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
  end;
...
procedure TCheckListBox.CMMouseLeave(var Message: TMessage);
begin
  if (Message.LParam = 0) and Assigned(FOnMouseLeave) then
      FOnMouseLeave(Self);
end;
 
procedure TForm1.CheckListBoxMouseLeave(Sender: TObject);
begin
   form2.Hide;
end;
...
procedure TForm1.FormCreate(Sender: TObject);
...
    CheckListBox1.OnMouseLeave:=CheckListBoxMouseLeave;
...
end;

ce qui donne:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
 
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, CheckLst, jpeg, ExtCtrls;
 
type
  TCheckListBox = class(CheckLst.TCheckListBox)
  private
    FOnMouseLeave: TNotifyEvent;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
  end;
 
type
  TForm1 = class(TForm)
    CheckListBox1: TCheckListBox;
    procedure CheckListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
  private
    procedure CheckListBoxMouseLeave(Sender: TObject);
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
  itemindexprec:Integer;
implementation
 
uses Unit2;
 
{$R *.dfm}
 
procedure TCheckListBox.CMMouseLeave(var Message: TMessage);
begin
  if (Message.LParam = 0) and Assigned(FOnMouseLeave) then
      FOnMouseLeave(Self);
end;
 
procedure TForm1.CheckListBoxMouseLeave(Sender: TObject);
begin
   form2.Hide;
end;
 
procedure TForm1.CheckListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var pt : tPoint;
    APoint: TPoint;
    Fichier:String;
begin
    APoint.X := X;
    APoint.Y := Y;
    CheckListBox1.ItemIndex := CheckListBox1.ItemAtPos(APoint, True);
    if (CheckListBox1.itemindex>=0) and (CheckListBox1.Checked[CheckListBox1.itemindex]) then
    begin
        Fichier:=CheckListBox1.Items[CheckListBox1.itemindex];
        if (fileexists(fichier)) then
        begin
              pt := Mouse.CursorPos;
              form2.Left:=pt.x+10;
              form2.top:=pt.y+10;
              form2.Show;
              if (itemindexprec<>CheckListBox1.itemindex) THEN Form2.image1.Picture.LoadFromFile(Fichier) // pour ne par relire le fichier quand on bouge en latérale
              else itemindexprec:=CheckListBox1.itemindex;
        end
        else
        form2.Hide;
    end
    else
    form2.Hide;
    if not form2.Active then itemindexprec:=-1;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
var i:integer;
begin
    CheckListBox1.OnMouseLeave:=CheckListBoxMouseLeave;
    itemindexprec:=-1;
    for i:=0 to pred(CheckListBox1.count) do CheckListBox1.Checked[i]:=true;
end;
 
end.

resouds le probleme "souris est hors de la fenetre"

dans la version 2
pour le Hint ne s'affiche pas

il faut mettre dans le form.creat

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
 
procedure TForm1.FormCreate(Sender: TObject);
begin
...
    Application.OnShowHint := AppShowHint;
...
end;
...
PROCEDURE Tform1.Appshowhint(VAR Hintstr: STRING; VAR Canshow: BOOLEAN; VAR Hintinfo: Thintinfo);
BEGIN
    MyHintinfo:=Hintinfo;
    hintstr:=' '; // mettre un espace sinon rien ne s'affiche
END;

et ne pas oublier de mettre le showhint a true dans TCheckListBox.

hintstr:=' '; // mettre un espace sinon rien ne s'affiche
MyHintinfo:=Hintinfo; "le probleme avec Application.HintControl car dérivé de Hintinfo.HintControl"

pour l'erreur function 'TCustomData'
function CalcHintRect(aMaxWidth: Integer; const aHint: string; aData: TCustomData): TRect; override;

dans D7
il s'ecrit :
function CalcHintRect(aMaxWidth: Integer; const aHint: string; aData: Pointer): TRect; override; <-- "aData: Pointer" et non "aData: TCustomData"
en ce qui concerne ShouldHideHint je n'ai pas trouvé.

sinon vas ici : https://nono40.developpez.com/sources/
section SECTION TUTORIELS : 0028 : Création de bulles d'aide ( Hint ) personnalisées
juste un derniere question dans l'exemple: Hint avec Image 2.zip il faut le décompressé dans un répertoire car si l'image n'est pas présent rien ne s'affiche ( if fileexists(Image) )

ps: pour le fun j'ai voulu savoir si l'on pouvais cummuler les hints avec "afficher l'aide contextuelle fin de ligne dans Tlistbox et Tcombobox"
Nom : Hints.jpg
Affichages : 67
Taille : 70,3 Ko

Nom : Hints.jpg
Affichages : 67
Taille : 70,3 Ko

source : hints.zip

**Informt2025** · 29/05/2026, 21h43

CM_MOUSELEAVE n'est pas pérenne il est généré par l'application avant d'entrer en Idle ce qui pose problème si le focus est déplacé dans le code

**Informt2025** · 30/05/2026, 08h01

Je voulais dire "pérenne", ce message est généré par l'application avant le repos si l'application reste active ou un dialogue surgit le message ne sera pas envoyé, contrairement à WM_MOUSELEAVE

[D7] Hint avec Image

Langage Delphi

Discussions similaires

Partager

Partager