// Getestet mit D4 unter WinME

// Hints anders anzeigen:
//  1. Hints in einem Label anzeigen
//  2. Hint-Zeiten ändern
//  3. Hint-Hintergrund einfärben
//  4. Zeilenumbruch im Hint
//  5. Hint-Positon verschieben
//  6. Hint ständig anzeigen
//  7. Hint als flaches Rechteck anzeigen
//  8.
Schriftart und -größe ändern
//  9. Volle Kontrolle über Schrift und Farbe
// 10. Dem Hintfenster andere Umrisse zuweisen
// 11. Hint mit Schatten unterlegen

 

// -------------------------------------------------------------

//
1. Hint in einem Label anzeigen                              
Anfang
//    Sowie die Maus ein Control berührt (im Beispiel Button1
//    oder Panel1) wird nicht mehr das Hintfenster aufgepoppt,
//    sondern der Hint in Label1 angezeigt.

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Label1: TLabel; 
    Panel1: TPanel; 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private-Deklarationen} 
  public 
    procedure DisplayHint(Sender: TObject); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.DisplayHint(Sender: TObject); 
begin 
  Label1.caption := Application.Hint; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Label1.caption := ''; 
  Application.OnHint := DisplayHint; 
  Button1.Hint := 'Button1 Hint-Test'; 
  Button1.ShowHint := false; 
  Panel1.Hint := 'Panel1 Hint-Test'; 
  Panel1.Showhint := false; 
end;


// -------------------------------------------------------------

// 2.  Hint-Zeiten ändern                                       Anfang
// 2.1 Zeit, bevor das Hintfenster angezeigt wird:

       Application.HintPause := 100; {0,1 Sek.}

// 2.2 Zeit, nach der das Hintfenster wieder ausgeblendet wird:

       Application.HintHidePause := 1000; {1 Sek.}


// -------------------------------------------------------------

//
3.  Hint-Hintergrund einfärben                               Anfang
// 3.1 Alle Hints färben:
//     Dafür reicht z.B. die folgende Zeile:

       Application.HintColor := clAqua;


// 3.2 Bestimmten Controls eine Farbe zuweisen:

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Panel1: TPanel; 
    Memo1: TMemo; 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private-Deklarationen} 
  public 
    procedure DisplayHint(var HintStr: string; var CanShow: Boolean; 
      var HintInfo: THintInfo); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.DisplayHint(var HintStr: string; var CanShow: Boolean; 
  var HintInfo: THintInfo); 
begin 
  if HintInfo.HintControl = Button1 then 
    HintInfo.HintColor := cllime 
else 
  if HintInfo.HintControl = Panel1 then 
    HintInfo.HintColor := $6699FF 
  else 
    if HintInfo.HintControl = Memo1 then 
      HintInfo.HintColor := $FF80FF; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Application.OnShowHint := DisplayHint; 
  Button1.Hint := 'Button1 Hint Test'; 
  Button1.ShowHint := true; 
  Panel1.Hint := 'Panel1 Hint Test'; 
  Panel1.ShowHint := true; 
  Memo1.Hint := 'Memo1 Hint Test'; 
  Memo1.ShowHint := true; 
end;


// -------------------------------------------------------------

//
4.  Zeilenumbruch im Hint                                    Anfang
// 4.1 Im Hint-Text:

       Button1.Hint := 'Dieser'#13'Text'#13'wird'#13'umgebrochen';

// 4.2 Durch Breiten-Begrenzung:

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private-Deklarationen} 
  public 
    procedure DisplayHint(var HintStr: string; var CanShow: Boolean; 
      var HintInfo: THintInfo); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.DisplayHint(var HintStr: string; var CanShow: Boolean; 
  var HintInfo: THintInfo); 
begin 
    HintInfo.HintMaxWidth := 1; {das längste Wort bestimmt die Breite} 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Application.OnShowHint := DisplayHint; 
  Button1.Hint := 'Dieser Text wird auch umgebrochen'; 
  Button1.ShowHint := true; 
end; 


// -------------------------------------------------------------

//
5.  Hint-Positon verschieben                                 Anfang

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private-Deklarationen} 
  public 
    procedure DisplayHint(var HintStr: string; var CanShow: Boolean; 
      var HintInfo: THintInfo); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.DisplayHint(var HintStr: string; var CanShow: Boolean; 
  var HintInfo: THintInfo); 
begin 
    dec(HintInfo.HintPos.y, 30); // Hint nach oben verschieben 
    inc(HintInfo.HintPos.x, 30); // Hint nach rechts verschieben 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Application.OnShowHint := DisplayHint; 
  Button1.Hint := 'Button1-Hint'; 
  Button1.ShowHint := true; 
end; 


// -------------------------------------------------------------

//
6.  Hint ständig anzeigen                                    Anfang
// 6.1 Hint für jedes Control ständig anzeigen.
//     Nachteil: Wird die Maus innerhalb eines Controls bewegt,
//     rutscht nach Ablauf von
"ReshowTimeout" das Hintfenster
//     der Maus hinterher.

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Panel1: TPanel; 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private-Deklarationen} 
  public 
    procedure DisplayHint(var HintStr: string; var CanShow: Boolean; 
      var HintInfo: THintInfo); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.DisplayHint(var HintStr: string; var CanShow: Boolean; 
  var HintInfo: THintInfo); 
begin 
  HintInfo.ReshowTimeout := Application.HintHidePause; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Application.HintPause := 0; 
  Application.OnShowHint := DisplayHint; 
  Button1.Hint := 'Button1-Hint'; 
  Button1.ShowHint := true; 
  Panel1.Hint := 'Panel1-Hint'; 
  Panel1.ShowHint := true; 
end; 


// 6.2 Hint für ein einzelnes Control ständig anzeigen.
//     Während bei anderen Controls die Hintanzeige ganz normal abläuft,
//     erfolgt bei Listbox1 eine ständige Anzeige, solange der Mauspfeil
//     auf einem Eintrag steht
(zusätzlich ändert sich der Hint, wenn die
//    
Maus auf einen anderen Eintrag gestellt wird).
//     Um das "Nachrutschen" zu verhindern, wird ein eigenes Hintfenster
//     benutzt.

type 
  TForm1 = class(TForm) 
    Panel1: TPanel; 
    ListBox1: TListBox; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure ListBox1MouseMove(Sender: TObject; Shift: TShiftState; 
      X, Y: Integer); 
  private 
    { Private-Deklarationen} 
  public 
    procedure DisplayHint(Sender: TObject); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
var MyHint: THintWindow; 
 
procedure TForm1.DisplayHint(Sender: TObject); 
var 
  p: TPoint; 
  r: TRect; 
begin 
  if Application.Hint = '' then MyHint.ReleaseHandle 
  else begin 
    getcursorpos(p); 
    if WindowfromPoint(p) = Listbox1.handle then begin 
      r := MyHint.CalcHintRect(screen.width, Application.Hint, nil); 
      offsetrect(r, p.x, p.y + 30); 
      MyHint.ActivateHint(r, Application.Hint); 
    end; 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  MyHint := THintWindow.create(nil); 
  MyHint.Color := Application.HintColor; 
  Application.OnHint := DisplayHint; 
  Listbox1.Items.add('Zeile 1'); 
  Listbox1.Items.add('Zeile 2'); 
  Listbox1.Items.add('Zeile 3'); 
  ListBox1.ShowHint := false; 
  Panel1.Hint := 'Das ist Panel 1'; 
  Panel1.ShowHint := true; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  MyHint.free; 
end; 
 
procedure TForm1.ListBox1MouseMove(Sender: TObject; 
  Shift: TShiftState; X, Y: Integer); 
var i: integer; 
begin 
  i := Listbox1.ItemAtPos(point(x, y), true); 
  if i >= 0 then 
    Listbox1.Hint := Listbox1.Items[i] 
  else Listbox1.Hint := ''; 
end;


// -------------------------------------------------------------

//
7.  Hint als flaches Rechteck anzeigen                       Anfang
//     Das Hintfenster wird nicht mehr erhaben, sondern als
//     normales Rechteck gezeichnet.

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Panel1: TPanel; 
    procedure FormCreate(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
  private 
    { Private-Deklarationen} 
  public 
    { Public declarations } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
type 
  TMyHintWindow = class(THintWindow) 
  protected 
    r: TRect; 
    dc: HDC; 
    procedure WMPaint(var m: TMessage); message WM_NCPaint; 
  end; 
 
procedure TMyHintWindow.WMPaint(var m: TMessage); 
begin 
  dc := getwindowdc(handle); 
  r := boundsrect; 
  drawedge(dc, r, EDGE_BUMP, BF_RECT or BF_MONO); 
  releasedc(handle, dc); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  HintWindowClass := TMyHintWindow; 
  Panel1.Hint := 'Panel'; 
  Panel1.Showhint := true; 
  Button1.Hint := 'Button'; 
  Button1.Showhint := true; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
 // und wieder zurückstellen 
 HintWindowClass := THintWindow; 
end;


// -------------------------------------------------------------

// 8.  Schriftart und -größe ändern                             Anfang

procedure TForm1.FormCreate(Sender: TObject); 
var x: integer; 
begin 
  for x := 0 to Application.Componentcount - 1 do 
    if Application.Components[x] is THintWindow then begin 
      with THintWindow(Application.Components[x]).Canvas.Font 
        do begin 
        Name := 'Courier New'; 
        Size := 16; 
      end; 
      break; 
    end; 
end;


// -------------------------------------------------------------


//
9.  Volle Kontrolle über Schrift und Farbe                   Anfang

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Panel1: TPanel; 
    procedure FormCreate(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
  private 
    { Private-Deklarationen} 
  public 
    { Public declarations } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
type 
  TMyHintWindow = class(THintWindow) 
  protected 
    r: TRect; 
    constructor Create(AOwner: TComponent); override; 
    procedure paint; override; 
  end; 
 
constructor TMyHintWindow.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  Canvas.Brush.Color := clBlack; 
  Canvas.Font.Name := 'Courier New'; 
  Canvas.Font.Size := 18; 
  Canvas.Font.Color := clYellow; 
  Canvas.Font.Style := [fsItalic, fsBold]; 
end; 
 
procedure TMyHintWindow.Paint; 
begin 
  r := Clientrect; 
  canvas.FillRect(r); 
  offsetrect(r, 2, 2); 
  DrawText(Canvas.handle, pchar(Caption), -1, r, dt_left or dt_noprefix or 
    dt_wordbreak); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  HintWindowClass := TMyHintWindow; 
  Panel1.Hint := 'Panel-Hint'; 
  Panel1.Showhint := true; 
  Button1.Hint := 'Button-Hint'; 
  Button1.Showhint := true; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
 // und wieder zurückstellen  
 HintWindowClass := THintWindow;  
end; 


// -------------------------------------------------------------


//
10. Dem Hintfenster andere Umrisse zuweisen                  Anfang
//     Im Beispiel wird das Hintfenster als flache Ellipse
//     dargestellt. Der Hint-Text darf nicht breiter als
//     250 Pixel sein und
HintPause darf nicht gleich
//    
HintHidePause sein.

type 
  TForm1 = class(TForm) 
    Panel1: TPanel; 
    Button1: TButton; 
    Timer1: TTimer; 
    procedure FormCreate(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  private 
    { Private-Deklarationen} 
  public 
    procedure DisplayHint(Sender: TObject); 
    procedure aus; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
type 
  TMyHintWindow = class(THintWindow) 
  protected 
    procedure paint; override; 
  end; 
 
var 
  MyHint: THintWindow; 
  r: TRect; 
  rgn: HRgn; 
  WErweitern, SErweitern: integer; 
 
procedure TMyHintWindow.Paint; 
begin 
  rgn := CreateEllipticRgn(3, 3, width - 2, height - 2); 
  setwindowRgn(MyHint.handle, rgn, true); 
  canvas.ellipse(2, 2, width - 4, height - 4); 
  canvas.textout(WErweitern + 2, SErweitern + 2, Application.Hint); 
end; 
 
procedure TForm1.DisplayHint(Sender: TObject); 
begin 
  if Application.Hint = '' then aus 
  else begin 
    r := MyHint.CalcHintRect(250, Application.Hint, nil); 
    WErweitern := MyHint.Canvas.Font.Size * 2; 
    SErweitern := r.right div r.bottom; 
    inflaterect(r, WErweitern, SErweitern); 
    Timer1.interval := Application.Hintpause; 
  end; 
end; 
 
procedure TForm1.aus; 
begin 
  Timer1.interval := 0; 
  MyHint.ReleaseHandle; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Timer1.interval := 0; 
  MyHint := TMyHintWindow.create(nil); 
  MyHint.Color := Application.HintColor; 
  Application.OnHint := DisplayHint; 
  Panel1.Hint := 'Das ist ein Test für den Hint von Panel 1'; 
  Panel1.ShowHint := false; 
  Button1.Hint := 'Das ist Button 1'; 
  Button1.ShowHint := false; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
var 
  p: TPoint; 
begin 
  if Integer(Timer1.interval) = Application.HintHidePause then aus 
  else begin 
    getcursorpos(p); 
    offsetrect(r, p.x, p.y + 32 + SErweitern div 2); 
    Timer1.interval := Application.HintHidePause; 
    MyHint.ActivateHint(r, Application.Hint); 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
MyHint.free; 
end;

// -------------------------------------------------------------

//
11Hints mit Schatten unterlegen                            Anfang
//     Falls Ihr Programm unter XP läuft, wird jeder Hint mit
//     einem Schatten unterlegt.

type 
  TShadowedHintWindow = class(THintWindow) 
  protected 
    procedure CreateParams(var Params: TCreateParams); override; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
procedure TShadowedHintWindow.CreateParams(var Params: TCreateParams); 
begin 
  inherited; 
  if (Win32Platform = VER_PLATFORM_WIN32_NT) and 
     ((Win32MajorVersion > 5) or 
      ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1))) then 
    Params.WindowClass.Style := Params.WindowClass.Style or $20000; 
end; 
 
initialization 
  HintWindowClass := TShadowedHintWindow; 
end.



Zugriffe seit 6.9.2001 auf Delphi-Ecke