[PhoeniX]

Сабж: Как реализовать всплывающие подсказки на WinAPI?
Вариант "загляни в исодники Delphi и посмотри, как оно реализовано" не подходит - сейчас шКодю на C++, Delphi под рукой нет. Гугл предлагает создавать новое окно вручную...

[NumLock]

Сообщение от DJ PhoeniX

Гугл предлагает создавать новое окно вручную...

Delphi так и делает: THintWindow

Код:

procedure THintWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := WS_POPUP or WS_BORDER;
    WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
    if NewStyleControls then
      ExStyle := WS_EX_TOOLWINDOW;
    // CS_DROPSHADOW requires Windows XP or above
    if CheckWin32Version(5, 1) then
      WindowClass.Style := WindowClass.style or CS_DROPSHADOW;
    if NewStyleControls then ExStyle := WS_EX_TOOLWINDOW;
    AddBiDiModeExStyle(ExStyle);
  end;
end;

кста if NewStyleControls then ExStyle := WS_EX_TOOLWINDOW; у всех 2 раза в коде?) это я просто скопировал кусок из Controls.pas.

[PhoeniX]

Да ну, неужели в WinAPI нет стандартных функций для подсказок? В жизни не поверю...

[NumLock]

Сообщение от DJ PhoeniX

Да ну, неужели в WinAPI нет стандартных функций для подсказок? В жизни не поверю...

да есть конечно: tooltips_class32

Код:

unit Unit1;

interface

uses
  CommCtrl,
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  FToolTip: HWND;

const
  TTI_NONE = 0;
  TTI_INFO = 1;
  TTI_WARNING = 2;
  TTI_ERROR = 3;

  TTS_ALWAYSTIP = $01;
  TTS_NOPREFIX = $02;
  TTS_NOANIMATE = $10;
  TTS_NOFADE = $20;
  TTS_BALLOON = $40;
  TTS_CLOSE = $80;

  TTM_SETTITLE = WM_USER+32;

implementation

{$R *.dfm}

procedure AddTool(Control: TWinControl; Text: String; Center: Boolean);
var
  ti: TOOLINFO;
begin
  ZeroMemory(@ti, SizeOf(TOOLINFO));
  ti.cbSize:=SizeOf(TOOLINFO);
  if Center then ti.uFlags:=TTF_SUBCLASS or TTF_CENTERTIP
  else ti.uFlags:=TTF_SUBCLASS;
  ti.hwnd:=Control.Handle;
  ti.lpszText:=PChar(Text);
  GetClientRect(Control.Handle, ti.Rect);
  SendMessage(FToolTip, TTM_ADDTOOL, 0, LPARAM(@ti));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FToolTip:=CreateWindowEx(WS_EX_TOPMOST,
    TOOLTIPS_CLASS,
    nil,
    TTS_BALLOON or
    WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP,
    0, 0, 0, 0,
    0, 0, HInstance, nil);
  AddTool(Button1, 'Button1', True);
  AddTool(Edit1, 'Edit1', True);
  AddTool(Memo1, 'Memo1', False);
  AddTool(ListBox1, 'ListBox1', False);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  DestroyWindow(FToolTip);
end;

end.

http://data.cod.ru/128082
стиль баллон можно убрать TTS_BALLOON, чтобы выглядела как обычно.

[PhoeniX]

Спасибо, так гораздо лучше

[angvelem]

Вот вариант:

Код:

unit DSHintWnd;

interface

uses
  Windows, Messages;

type
  tagNMTTDISPINFOA = packed record
    hdr		: TNMHdr;
    lpszText	: PAnsiChar;
    szText	: array[0..79] of AnsiChar;
    hinst	: HINST;
    uFlags	: UINT;
    lParam	: LPARAM;
  end;
  tagNMTTDISPINFO = tagNMTTDISPINFOA;
  PNMTTDispInfoA  = ^TNMTTDispInfoA;
  PNMTTDispInfo   = PNMTTDispInfoA;
  TNMTTDispInfoA  = tagNMTTDISPINFOA;
  TNMTTDispInfo = TNMTTDispInfoA;

  PToolInfoA = ^TToolInfoA;
  PToolInfo = PToolInfoA;
  TToolInfoA = packed record
    cbSize	: UINT;
    uFlags	: UINT;
    hwnd	: HWND;
    uId		: UINT;
    Rect	: TRect;
    hInst	: THandle;
    lpszText	: PAnsiChar;
  end;
  TToolInfo = TToolInfoA;

const
  TTS_ALWAYSTIP		= $01;
  TTS_NOPREFIX		= $02;

  TTF_IDISHWND		= $0001;
  TTF_SUBCLASS		= $0010;

  TTM_ACTIVATE		= WM_USER + 1;
  TTM_SETDELAYTIME	= WM_USER + 3;
  TTM_ADDTOOL		= WM_USER + 4;
  TTM_DELTOOL		= WM_USER + 5;
  TTM_RELAYEVENT	= WM_USER + 7;
  TTM_UPDATETIPTEXT	= WM_USER + 12;
  TTM_GETTOOLCOUNT	= WM_USER + 13;
  TTM_SETTIPBKCOLOR	= WM_USER + 19;
  TTM_SETTIPTEXTCOLOR	= WM_USER + 20;
  TTM_GETTIPBKCOLOR	= WM_USER + 22;
  TTM_SETMAXTIPWIDTH	= WM_USER + 24;
  TTM_SETMARGIN		= WM_USER + 26;
  TTM_GETMARGIN		= WM_USER + 27;
  
  TTN_FIRST		= 0-520;
  TTN_GETDISPINFO	= TTN_FIRST;
  TTN_NEEDTEXTA		= TTN_FIRST - 0;
  TTN_NEEDTEXT		= TTN_NEEDTEXTA;
  
type
  TToolTip	= class
  private
    id		: UINT;
    fParent,
    Handle	: HWND;
    fActive	: Boolean;

    fHint	: String;
    fTxtColor,
    fBkColor	: TColorRef;

    procedure	SetActive(Value : Boolean);
    procedure   SetHint(Hint : String);
    procedure   SetTxtColor(Color : TColorRef);
    procedure   SetBkColor(Color : TColorRef);
  public
    constructor Create(hParent : HWND);
    destructor  Destroy; override;

    procedure   AddHintRect(R : TRect; Hint : String);
    procedure   RelayMouseMove(Pos: TSmallPoint);
    procedure   Clear;
    procedure   Activate;
    procedure   Deactivate;
  published
    property Active  : Boolean   read fActive	 write SetActive;
    property Hint    : String    read fHint      write SetHint;
    property HintTxtColor: TColorRef read fTxtColor  write SetTxtColor;
    property HintBkColor:  TColorRef read fBkColor   write SetBkColor;
  end;


implementation

const
  MAX_TOOLTIP_WINDOW_WIDTH = 220;
  TOOLTIPS_CLASS = 'tooltips_class32';

var
  ti	: TToolInfo;

constructor TToolTip.Create(hParent : HWND);
var
  R	: TRect;
begin
  Handle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, TTS_ALWAYSTIP, 
			   0, 0, 0, 0,
			   hParent, 0, hInstance, nil);

  if Handle <> 0 then
  begin
    FillChar(ti, SizeOf(ti), 0);
    ti.cbSize	:= SizeOf(TToolInfo);
    ti.uFlags	:= TTF_SUBCLASS;
    ti.hInst	:= hInstance;
    SendMessage(Handle, TTM_GETMARGIN, 0, Integer(@R));
    SetRect(R, R.Left + 2, R.Top + 2, R.Right + 2, R.Bottom + 2);
    SendMessage(Handle, TTM_SETMARGIN, 0, Integer(@R));
    SendMessage(Handle, TTM_SETMAXTIPWIDTH, 0, MAX_TOOLTIP_WINDOW_WIDTH);
    SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  end;

  fParent := hParent;
  fActive := True;
end;

destructor TToolTip.Destroy;
begin
  inherited;
//  DestroyWindow(Handle);
end;

procedure TToolTip.AddHintRect(R: TRect; Hint: String);
begin
  ti.cbSize	:= sizeof(TToolInfo);
  ti.hwnd	:= fParent;
  ti.Rect	:= R;
  ti.lpszText	:= PChar(Hint);

  inc(id);
  SendMessage(Handle, TTM_ADDTOOL, 0, Integer(@ti));
  fHint := Hint;
  SetActive(False);
end;

procedure TToolTip.SetHint(Hint : String);
var
  Rect	: TRect;
  Bol	: Boolean;
begin
  if (fParent <> 0) and (GetClientRect(fParent, Rect)) then
  begin
    ti.cbSize	:= SizeOf(TToolInfo);
    ti.hwnd	:= fParent;
    ti.Rect	:= Rect;
    Bol		:= Length(ti.lpszText) <> 0;
    ti.lpszText	:= PChar(Hint);

    if Bol then
      SendMessage(Handle, TTM_UPDATETIPTEXT, 0, Integer(@ti))
    else  
      SendMessage(Handle, TTM_ADDTOOL, 0, Integer(@ti));
    fHint := Hint;
  end;
  SetActive(False);
end;

procedure TToolTip.SetTxtColor(Color: TColorRef);
begin
  SendMessage(Handle, TTM_SETTIPTEXTCOLOR, Color, 0);
end;

procedure TToolTip.SetBkColor(Color: TColorRef);
begin
  SendMessage(Handle, TTM_SETTIPBKCOLOR, Color, 0);
end;

procedure TToolTip.RelayMouseMove(Pos: TSmallPoint);
var
  Msg	: TMsg;
begin
  Msg.wParam	:= 0;
  Msg.lParam	:= LongInt(Pos);
  Msg.message	:= wm_MouseMove;
  Msg.hwnd	:= fParent;

  SendMessage(Handle, TTM_RelayEvent, 0, LongInt(@Msg));
end;

procedure TToolTip.Clear;
var
  I	: Integer;
begin
  ti.cbSize	:= SizeOf(ti);
  ti.hwnd	:= fParent;
  for I := 0 to id - 1 do
  begin
    ti.uId	:= I;
    SendMessage(Handle, TTM_DELTOOL, 0, LongInt(@ti));
  end;
  id := 0;
end;

procedure TToolTip.Activate;
begin
  if fActive then
    Exit;
  SendMessage(Handle, TTM_ACTIVATE, 1, 0);
  fActive:= True;
end;

procedure TToolTip.Deactivate;
begin
  if not fActive then
    Exit;
  SendMessage(Handle, TTM_ACTIVATE, 0, 0);
  fActive:= False;
end;

procedure TToolTip.SetActive(Value : Boolean);
begin
  if Value then Activate
  else Deactivate;
end;

end.

но можно, и вообще без класса обойтись.