DBR Delphi-Ecke

// 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
// 12. Hints unter Windows 10

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

// 1. Hint in einem Label anzeigen
//    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
// 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
// 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
// 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

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
// 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
//     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

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

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
//     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;

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

// 11. Hints mit Schatten unterlegen
//     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.

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

// 12. Hints unter Windows 10
// Getestet mit RS 10.4.

type 
  TMyHintWindow = class(THintWindow) 
  public 
    r: TRect; 
    constructor Create(AOwner: TComponent); override; 
    procedure Paint; override; 
  end; 
 
constructor TMyHintWindow.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  Canvas.Brush.Color := clyellow; 
end; 
 
procedure TMyHintWindow.Paint; 
begin 
  r := Clientrect; 
  Canvas.FillRect(r); 
  Canvas.Font.Color := clblue; 
  offsetrect(r, 2, 2); 
  DrawText(Canvas.handle, pchar(Caption), -1, r, dt_left or dt_noprefix or 
    dt_wordbreak); 
end; 
 
var 
  lgf: TLogFont; 
  NewFont: THandle; 
 
procedure TForm2.FormCreate(Sender: TObject); 
begin 
  HintWindowClass := TMyHintWindow; 
  lgf.lfFaceName := 'Times New Roman'; 
  lgf.lfWeight := FW_Bold; 
  lgf.lfHeight := 18; 
  lgf.lfItalic := 1; 
  NewFont := CreateFontIndirect(lgf); 
  Screen.HintFont.handle := NewFont; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject);  
begin  
  if NewFont > 0 then  
    DeleteObject(NewFont)  
end;