Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум программистов > Delphi: WinAPI и системное программирование > Не работает Tooltips_Class32..


Автор: navodri 19.6.2010, 19:44
Столкнулся с проблемой отображения баллун посдказок Tooltips_Class32 в органах управления BS_GROUPBOX и STATIC. Не отображаются. Самое интересное, что в EDIT и BUTTON все проходит на ура! В чем тут проблема?

Коди диалогового окна:
Код

MAIN_WINDOW DIALOG 0, 0, 297, 143
STYLE DS_CENTER | WS_MAXIMIZEBOX | WS_MINIMIZEBOX | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU | WS_THICKFRAME
CAPTION ""
LANGUAGE LANG_RUSSIAN, 0x1
FONT 8, "MS SANS SERIF"
{
   CONTROL "Настройка:", 99, BUTTON, BS_GROUPBOX | BS_LEFTTEXT | BS_TOP | BS_NOTIFY | BS_FLAT | WS_CHILD | WS_VISIBLE | WS_CLIPSIBLINGS | WS_GROUP | WS_TABSTOP, 7, 7, 278, 47 
   CONTROL "Баллун должне быть, а его нет?", 97, STATIC, SS_LEFT | WS_CHILD | WS_VISIBLE | WS_GROUP, 7, 60, 192, 11 
   CONTROL "", 98, EDIT, ES_LEFT | WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP, 17, 20, 132, 14 
}


Код программы:
Код

program primer;

uses
 Windows, Messages, commctrl;

{$R dialog.res}

var
 hTooltip: Cardinal;
 ti: TToolInfo;
 buffer : array[0..255] of char;

const
  TTS_BALLOON = $40;
  TTM_SETTITLE = (WM_USER + 32);

procedure CreateToolTips(hWnd: Cardinal);
begin
 hToolTip := CreateWindowEx(WS_EX_TOPMOST or WS_EX_TOOLWINDOW, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON or  TTS_NOPREFIX,
  Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
   if hToolTip <> 0 then begin
    SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
    ti.cbSize := SizeOf(TToolInfo);
    ti.uFlags := TTF_SUBCLASS;
    ti.hInst := hInstance;
   end;
end;

procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer; Text, Title: PChar);
var
 Item: THandle;
 Rect: TRect;
begin
 Item := hWnd;
  if (Item <> 0) and (GetClientRect(Item, Rect)) then begin
   lpti.hwnd := Item;
   lpti.Rect := Rect;
   lpti.lpszText := Text;
   SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
   FillChar(buffer, SizeOf(buffer), #0);
   lstrcpy(buffer, Title);
    if (IconType > 3) or (IconType < 0) then IconType := 0;
   SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
  end;
end;

function DlgProc(hWin: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): bool; stdcall;
begin
 Result := False;
  case uMsg of
   WM_INITDIALOG:
    begin
     CreateToolTips(hWin);
     AddToolTip(Getdlgitem(hWin, 98), @ti, 1, 'Tooltip text', 'Title');
     AddToolTip(Getdlgitem(hWin, 99), @ti, 1, 'Tooltip text', 'Title');
     AddToolTip(Getdlgitem(hWin, 97), @ti, 1, 'Tooltip text', 'Title');
    end;
   WM_DESTROY, WM_CLOSE: PostQuitMessage(0);
 end;
end;

begin
 DialogBox(hInstance, 'MAIN_WINDOW', 0, @DlgProc);

end.

Автор: Maks1509 20.6.2010, 10:12
По поводу групбоксов http://www.rsdn.ru/forum/mfc/154650.flat.aspx
Ну и пример со статиком.
Код

{******************************************************************************}
{                                                                              }
{                               Tooltipp Demo                                  }
{                                                                              }
{                      Copyright (c) 2002 Michael Puff                         }
{                   Erweiterungen (c) 2002 Mathias Simmack                     }
{                                                                              }
{******************************************************************************}
program Tooltipps;

{$DEFINE ENABLETITLE}
{$DEFINE BALLOONSTYLE}
{$DEFINE CHANGECOLOR}

uses
  Windows,
  Messages,
  CommCtrl;

const
  // Basiseinstellungen
  szClassname  = 'TTipp_WndClass';
  szAppname    = 'Tooltipp-Demo';
  wWidth       = 255;
  wHeight      = 150;

  // Tooltipp-Texte
  TIPP_EDIT    = 'Geben Sie hier einen Tooltipp an';
  TIPP_CHANGE  = 'Дndert den Tooltipp des "SchlieЯen"-Buttons';
  TIPP_CLOSE   = 'Programm beenden mit ALT+S';

  // Control IDs
  IDC_EDIT     = 1;
  IDC_CHANGE   = 2;
  IDC_CLOSE    = 3;
  IDC_CHECKB   = 4;

  // Accelerator IDs
  ACCEL_CHANGE = 1000;
  ACCEL_CLOSE  = 1001;

  TTS_BALLOON             = $40;
  TTM_SETTITLEA           = WM_USER + 32;
  TTM_SETTITLE             = TTM_SETTITLEA;
  TTI_INFO                = 1;

var
  hToolTip     : HWND;

//
// Tooltipp-Prozeduren
//
procedure AddToolTip(wnd: HWND; hInst: longword; lpText: pchar);
var
  ti : TToolInfo;
  r  : TRect;
begin
  if(wnd <> 0) and (GetClientRect(wnd,r)) then
    begin
      fillchar(ti,sizeof(TToolInfo),0);

      ti.cbSize   := sizeof(TToolInfo);
      ti.uFlags   := TTF_SUBCLASS or TTF_IDISHWND;
      ti.hwnd     := wnd;
      ti.uId      := wnd;
      ti.Rect     := r;
      ti.hInst    := hInst;
      ti.lpszText := lpText;

      SendMessage(hToolTip,TTM_ADDTOOL,0,LPARAM(@ti));
    end;
end;

procedure UpdateToolTip(wnd: HWND; hInst: longword; lpText: pchar);
var
  ti : TToolInfo;
begin
  if(wnd <> 0) then
    begin
      fillchar(ti,sizeof(TToolInfo),0);

      ti.cbSize   := sizeof(TToolInfo);
      ti.hwnd     := wnd;
      ti.uId      := wnd;
      ti.hInst    := hInst;
      ti.lpszText := lpText;

      SendMessage(hToolTip,TTM_UPDATETIPTEXT,0,LPARAM(@ti));
    end;
end;

//
// WndProc
//
var
  hCloseBtn,
  hChangeBtn,
  hEdit,
  hCheckBox : HWND;
  hWndFont  : HGDIOBJ;
  buffer    : array[0..255]of char;
  bFlag     : boolean = false;


function WndProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LRESULT; stdcall;
var
  x, y  : integer;
{$IFDEF CHANGECOLOR}
  z     : cardinal;
{$ENDIF}
begin
  Result := 0;

  case uMsg of
    WM_CREATE:
      begin
        // Fenster zentrieren
        x := GetSystemMetrics(SM_CXSCREEN);
        y := GetSystemMetrics(SM_CYSCREEN);
        MoveWindow(wnd, (x div 2) - (wWidth div 2),
          (y div 2) - (wHeight div 2),
          wWidth, wHeight, true);

        // Controls erstellen
        hEdit := CreateWindowEx(WS_EX_CLIENTEDGE, 'EDIT', {TIPP_CLOSE}nil, WS_VISIBLE or
          WS_CHILD, 20, 25, 210, 21, wnd, IDC_EDIT, hInstance, nil);

        hChangeBtn := CreateWindowEx(0, 'BUTTON', 'GroupBox',
          WS_VISIBLE or WS_CHILD or BS_LEFT or BS_NOTIFY or BS_GROUPBOX or BS_PUSHLIKE, 20, 60, 100, 23, wnd, IDC_CHANGE,
          hInstance, nil);

        hCloseBtn := CreateWindowEx(0, 'STATIC', 'Static',
          WS_VISIBLE or WS_CHILD or SS_LEFT or SS_NOTIFY, 130, 60, 100, 23, wnd, IDC_CLOSE,
          hInstance, nil);

        hCheckBox := CreateWindowEx(0, 'BUTTON', 'Tooltip on / off',
          WS_VISIBLE or WS_CHILD or BS_AUTOCHECKBOX, 20, 90, 210, 21, wnd, IDC_CHECKB,
          hInstance, nil);
        SendMessage(hCheckBox,BM_SETCHECK,BST_CHECKED,0);

        // Font erstellen, & zuordnen
        hWndFont := GetStockObject(DEFAULT_GUI_FONT);
        if(hWndFont <> 0) then
          begin
            SendMessage(hEdit,WM_SETFONT,hWndFont,1);
            SendMessage(hChangeBtn,WM_SETFONT,hWndFont,1);
            SendMessage(hCloseBtn,WM_SETFONT,hWndFont,1);
            SendMessage(hCheckBox,WM_SETFONT,hWndFont,1);
          end;

        // Tooltipp-Fenster erstellen
        hToolTip := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil,
          TTS_ALWAYSTIP or TTS_NOPREFIX or WS_POPUP
          {$IFDEF BALLOONSTYLE} or TTS_BALLOON {$ENDIF},
          integer(CW_USEDEFAULT), integer(CW_USEDEFAULT), integer(CW_USEDEFAULT),
          integer(CW_USEDEFAULT), wnd, 0, hInstance, nil);

        if(hToolTip <> 0) then
          begin
            // Tooltipp als oberstes Fenster festlegen
            SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
              SWP_NOSIZE or SWP_NOACTIVATE);

{$IFDEF ENABLETITLE}
            // Neuer Tooltipp-Stil, inkl. Titel
            fillchar(buffer,sizeof(buffer),#0); lstrcpy(buffer,szAppname);
            SendMessage(hToolTip,TTM_SETTITLE,TTI_INFO,LPARAM(@buffer));
{$ENDIF}

            // Tooltipps zuordnen
            AddToolTip(hEdit,hInstance,TIPP_EDIT);
            AddToolTip(hChangeBtn,hInstance,TIPP_CHANGE);
            AddToolTip(hCloseBtn,hInstance,TIPP_CLOSE);

{$IFDEF CHANGECOLOR}
            // Tippfarben дndern
            z := $00ffffff; SendMessage(hToolTip,TTM_SETTIPBKCOLOR,z,0);
            z := $00800000; SendMessage(hToolTip,TTM_SETTIPTEXTCOLOR,z,0);
{$ENDIF}
          end;
      end;
    WM_DESTROY:
      begin
        DeleteObject(hWndFont);
        PostQuitMessage(0);
      end;
    WM_COMMAND:
      case HIWORD(wp) of
        1:
          case LOWORD(wp) of
            ACCEL_CHANGE:
              SendMessage(wnd,WM_COMMAND,MAKELONG(IDC_CHANGE,BN_CLICKED),0);
            ACCEL_CLOSE:
              SendMessage(wnd,WM_CLOSE,0,0);
          end;
        BN_CLICKED:
          case LOWORD(wp) of
            IDC_CLOSE:
              SendMessage(wnd,WM_CLOSE,0,0);
            IDC_CHANGE:
              begin
                // Text aus dem Editfeld holen
                fillchar(buffer,sizeof(buffer),#0);
                SendMessage(hEdit,WM_GETTEXT,256,LPARAM(@buffer));

                // Tooltipp des "SchlieЯen"-Buttons дndern :o)
                if(buffer[0] <> #0) then
                  UpdateToolTip(hCloseBtn,hInstance,buffer);
              end;
            IDC_CHECKB:
              begin
                // Status abfragen
                bFlag := SendMessage(hCheckBox,BM_GETCHECK,0,0) = BST_CHECKED;

                // Tooltipps aktivieren oder deaktivieren
                SendMessage(hToolTip,TTM_ACTIVATE,WPARAM(bFlag),0);
              end;
          end;
        EN_CHANGE:
          case LOWORD(wp) of
            IDC_EDIT:
              begin
                // Text aus dem Editfeld holen
                fillchar(buffer,sizeof(buffer),#0);
                SendMessage(hEdit,WM_GETTEXT,256,LPARAM(@buffer));

                // Button deaktivieren, wenn im Editfeld nichts steht
                EnableWindow(hChangeBtn,buffer[0] <> #0);
              end;
          end;
      end;
    else
      Result := DefWindowProc(wnd,uMsg,wp,lp);
  end;
end;

//
// Main
//
var
  wc : TWndClassEx = (
    cbSize        : SizeOf(TWndClassEx);
    Style         : CS_HREDRAW or CS_VREDRAW;
    lpfnWndProc   : @WndProc;
    cbClsExtra    : 0;
    cbWndExtra    : 0;
    hbrBackground : COLOR_APPWORKSPACE;
    lpszMenuName  : nil;
    lpszClassName : szClassname;
    hIconSm       : 0;
  );
  msg : TMsg;
  AccelTbl : array[0..1]of TAccel;
  wndMain, hAccelTbl : dword;

begin
  // fьr Tooltipps "InitCommonControls" aufrufen
  InitCommonControls;

  // Fensterklasse ergдnzen
  wc.hInstance := hInstance;
  wc.hIcon     := LoadIcon(0,IDI_APPLICATION);
  wc.hCursor   := LoadCursor(0, IDC_ARROW);

  // Fensterklasse registrieren, & Fenster erzeugen
  if(RegisterClassEx(wc) = 0) then exit;
  wndmain := CreateWindowEx(0, szClassname, szAppname, WS_CAPTION or WS_VISIBLE or
    WS_SYSMENU, integer(CW_USEDEFAULT), integer(CW_USEDEFAULT), wWidth,
    wHeight, 0, 0, hInstance, nil);
  if(wndmain = 0) then exit;
  ShowWindow(wndmain,SW_SHOW);
  UpdateWindow(wndmain);

  // Acceleratortabelle erzeugen
  AccelTbl[0].fVirt := FALT or FVIRTKEY;
  AccelTbl[0].key   := WORD('T');
  AccelTbl[0].cmd   := ACCEL_CHANGE;
  AccelTbl[1].fVirt := FALT or FVIRTKEY;
  AccelTbl[1].key   := WORD('S');
  AccelTbl[1].cmd   := ACCEL_CLOSE;
  hAccelTbl         := CreateAcceleratorTable(AccelTbl,2);

  while(GetMessage(msg,0,0,0)) do
    begin
      if(TranslateAccelerator(wndmain, hAccelTbl, msg) = 0) then
        begin
          TranslateMessage(msg);
          DispatchMessage(msg);
        end;
    end;

  // Acceleratortabelle freigeben
  DestroyAcceleratorTable(hAccelTbl);

  ExitCode := msg.wParam;
end.

Автор: navodri 20.6.2010, 10:38
2 Maks1509
Контрол BS_GROUPBOX по-прежнему не отображает подсказку. Радует, что STATIC заработал. Хотя первый орган управления меня интересует больше.
Материал по поводу BS_GROUPBOXов не понял. Можно объяснить мне по-проще?

Автор: Maks1509 20.6.2010, 11:21
navodri, походу групбокс и себе не дает выводить подсказки и другим мешает. Как вариант засабклассить контрол и у же там управлять тултипом (Подобое делал для статика. Требовался контрол гиперссылки с тултипом).

Автор: navodri 21.6.2010, 21:17
Получилось применить Tooltips_Class32 к BS_GROUPBOX. Но, к сожалению, баллун отображается не только в этом органе управления, он отображается на всём окне. Спасайте!

Код

program Subclassing;

uses
  Windows, Messages, CommCtrl;

const
  ClassName = 'SubclassWinClass';
  AppName   = 'Subclassing Demo';
  IDC_CHACKBOCX1 = 700;
  TTS_BALLOON             = $40;
  TTM_SETTITLEA           = WM_USER + 32;
  TTM_SETTITLE             = TTM_SETTITLEA;
  TTI_INFO                = 1;
  TTM_SETTIPBKCOLOR        = WM_USER + 19;
  TTM_SETTIPTEXTCOLOR      = WM_USER + 20;

var
  hGroupBox : DWORD;
  OldWndProc: Pointer;
  hToolTip     : HWND;

procedure AddToolTip(wnd: HWND; hInst: Integer; lpText: pchar);
var
  ti : TToolInfo;
  r  : TRect;
begin
  if(wnd <> 0) and (GetClientRect(wnd,r)) then
    begin
      fillchar(ti,sizeof(TToolInfo),0);

      ti.cbSize   := sizeof(TToolInfo);
      ti.uFlags   := TTF_SUBCLASS or TTF_IDISHWND;
      ti.hwnd     := wnd;
      ti.uId      := wnd;
      ti.Rect     := r;
      ti.hInst    := hInst;
      ti.lpszText := lpText;

      SendMessage(hToolTip,TTM_ADDTOOL,0,LPARAM(@ti));
    end;
end;

procedure UpdateToolTip(wnd: HWND; hInst: Integer; lpText: pchar);
var
  ti : TToolInfo;
begin
  if(wnd <> 0) then
    begin
      fillchar(ti,sizeof(TToolInfo),0);

      ti.cbSize   := sizeof(TToolInfo);
      ti.hwnd     := wnd;
      ti.uId      := wnd;
      ti.hInst    := hInst;
      ti.lpszText := lpText;

      SendMessage(hToolTip,TTM_UPDATETIPTEXT,0,LPARAM(@ti));
    end;
end;

var
  buffer    : array[0..255]of char;

function GroupBoxWndProc(hGroup, uMsg, wParam, lParam:DWORD): DWORD; stdcall;
begin
  Result := 0;
  case uMsg of
    WM_CREATE:
     begin
     messagebox(0,'','',0);

     end;
  else
    Result := CallWindowProc(OldWndProc, hGroup, uMsg, wParam, lParam);
  end;
end;

function WndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
  Result := 0;
  case uMsg of
    WM_CREATE:
      begin
        hGroupBox := CreateWindowEx(0, 'BUTTON', 'GroupBox',
          WS_VISIBLE or WS_CHILD or BS_LEFT or BS_NOTIFY or BS_GROUPBOX or BS_PUSHLIKE, 20, 20, 300, 33, hWnd, IDC_CHACKBOCX1, hInstance, nil);
        OldWndProc := Pointer(SetWindowLong(hGroupBox, GWL_WNDPROC, Integer(@GroupBoxWndProc)));

        // Tooltipp-Fenster erstellen
        hToolTip := CreateWindowEx(WS_EX_TOPMOST, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_NOPREFIX or WS_POPUP or TTS_BALLOON,
         integer(CW_USEDEFAULT), integer(CW_USEDEFAULT), integer(CW_USEDEFAULT), integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
        if(hToolTip <> 0) then
          begin
            // Tooltipp als oberstes Fenster festlegen
            SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
            // Neuer Tooltipp-Stil, inkl. Titel
            fillchar(buffer,sizeof(buffer),#0); lstrcpy(buffer, 'Appname');
            SendMessage(hToolTip,TTM_SETTITLE,TTI_INFO, integer(@buffer));
            // Tooltipps zuordnen
            AddToolTip(hWnd, hInstance, 'Текст подсказки');
          end;

      end;
    WM_DESTROY:
      PostQuitMessage(0);
  else
    Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
  end;
end;

var
  wc: TWndClassEx = (
    cbSize       : SizeOf(TWndClassEx);
    style        : CS_HREDRAW or CS_VREDRAW;
    lpfnWndProc  : @WndProc;
    cbClsExtra   : 0;
    cbWndExtra   : 0;
    hbrBackground: COLOR_APPWORKSPACE;
    lpszMenuName : nil;
    lpszClassName: ClassName;
    hIconSm      : 0;
  );
  msg: TMsg;

begin
  wc.hInstance := HInstance;
  wc.hIcon     := LoadIcon(0, IDI_APPLICATION);
  wc.hCursor   := LoadCursor(0, IDC_ARROW);
  RegisterClassEx(wc);
  CreateWindowEx(WS_EX_CLIENTEDGE, ClassName, AppName, WS_OVERLAPPED or
    WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_VISIBLE,
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), 350, 200, 0, 0, HInstance,
    nil);
  while True do
  begin
    if not GetMessage(msg, 0, 0, 0) then
      Break;
    TranslateMessage(msg);
    DispatchMessage(msg);
  end;
  ExitCode := msg.wParam;
end.

Автор: Maks1509 21.6.2010, 22:24
Посмотрел код, значит так:
В AddToolTip ты указываешь дескриптор главного окна заместо окна групбокса, вот поэтому у тебя подсказка и отображается во всем окне.
Да и смысла сабклассинга групбокса у тебя нет, ведь контрол уже создан и в процедуре ловить WM_CREATE бесполезно теперь, там по другому можно - мой пример со статиком ниже, посмотри что нужно, может быть пригодится. smile 

Код

unit F_LinkPaint;

{******************************************************************************}
{                                                                              }
{ Проект             : EasyStream (HyperLink Control)                          }
{ Последнее изменение: 01.06.2010                                              }
{ Авторские права    : © Мельников Максим Викторович, 2010                     }
{ Электронная почта  : [email protected]                                       }
{                                                                              }
{******************************************************************************}
{                                                                              }
{ Эта программа является свободным программным обеспечением. Вы можете         }
{ распространять и/или модифицировать её согласно условиям Стандартной         }
{ Общественной Лицензии GNU, опубликованной Фондом Свободного Программного     }
{ Обеспечения, версии 3 или, по Вашему желанию, любой более поздней версии.    }
{                                                                              }
{ Эта программа распространяется в надежде, что она будет полезной, но БЕЗ     }
{ ВСЯКИХ ГАРАНТИЙ, в том числе подразумеваемых гарантий ТОВАРНОГО СОСТОЯНИЯ    }
{ ПРИ ПРОДАЖЕ и ГОДНОСТИ ДЛЯ ОПРЕДЕЛЁННОГО ПРИМЕНЕНИЯ. Смотрите Стандартную    }
{ Общественную Лицензию GNU для получения дополнительной информации.           }
{                                                                              }
{ Вы должны были получить копию Стандартной Общественной Лицензии GNU          }
{ вместе с программой. В случае её отсутствия, посмотрите                      }
{ http://www.gnu.org/copyleft/gpl.html                                         }
{                                                                              }
{******************************************************************************}

interface

uses
  Windows, Messages, CommCtrl;

const
  //
  STM_EX_SETHOVERCLR  = WM_USER + 101; // установить цвет для наведенного состояния.
  STM_EX_SETNORMALCLR = WM_USER + 102; // установить цвет для обычного состояния.
  STM_EX_SETPRESSCLR  = WM_USER + 103; // установить цвет для нажатого состояния.
  STM_EX_SETBCKGNDCLR = WM_USER + 104; // установить цвет для фона текста.
  STM_EX_SETTIPTEXT   = WM_USER + 105; // установить текст всплывающей подсказки.
  //
  STM_EX_GETHOVERCLR  = WM_USER + 111; // получить цвет для наведенного состояния.
  STM_EX_GETNORMALCLR = WM_USER + 112; // получить цвет для обычного состояния.
  STM_EX_GETPRESSCLR  = WM_USER + 113; // получить цвет для нажатого состояния.
  STM_EX_GETBCKGNDCLR = WM_USER + 114; // получить цвет для фона текста.
  STM_EX_GETTIPTEXT   = WM_USER + 115; // получить текст всплывающей подсказки.

// создание элемента управления Hyperlink.

procedure CreateStaticHyperlinkW(hWnd: HWND);

// удаление элемента управления Hyperlink.

procedure RemoveStaticHyperlinkW(hWnd: HWND);

implementation

type
  TCtrlWndProc = function(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;

  P_CTRL_PRO = ^T_CTRL_PRO;
  T_CTRL_PRO = packed record
    CtrlProc  : TCtrlWndProc;
    hCursor   : HCURSOR;
    hFont     : HFONT;
    rcClient  : TRect;
    //
    clrHover  : TColorRef;
    clrNormal : TColorRef;
    clrPress  : TColorRef;
    clrBckgnd : TColorRef; // CLR_NONE
    pszText   : Array [0..MAX_PATH-1] of WideChar;
    //
    bIsHover  : Boolean;
    bIsPress  : Boolean;
    bIsEnabled: Boolean;
    //
    hToolTip  : HWND;
    ti        : TToolInfoW;
    pszToolTip: Array [0..MAX_PATH-1] of WideChar;
    //
    dtStyle   : DWORD;
    //
    hdcMem    : HDC;
    hbmMem    : HBITMAP;
    hbmOld    : HBITMAP;
  end;

var
  pcp: P_CTRL_PRO;

//

function CtrlWndProc_StmExSetHoverClr(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  pcp.clrHover := TColorRef(wParam);
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_StmExGetHoverClr(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  //
  Result := LRESULT(pcp.clrHover);
end;

//

function CtrlWndProc_StmExSetNormalClr(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  pcp.clrNormal := TColorRef(wParam);
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_StmExGetNormalClr(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  //
  Result := LRESULT(pcp.clrNormal);
end;

//

function CtrlWndProc_StmExSetPressClr(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  pcp.clrPress := TColorRef(wParam);
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_StmExGetPressClr(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  //
  Result := LRESULT(pcp.clrPress);
end;

//

function CtrlWndProc_StmExSetBckgdClr(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  pcp.clrBckgnd := TColorRef(wParam);
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_StmExGetBckgdClr(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  //
  Result := LRESULT(pcp.clrBckgnd);
end;

//

function CtrlWndProc_StmExSetTipText(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  lstrcpynW(pcp.pszToolTip, LPWSTR(lParam), lParam);
  //
  Result := 0;
end;

//

function CtrlWndProc_StmExGetTipText(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  //
  lstrcpynW(LPWSTR(lParam), pcp.pszToolTip, lstrlenW(pcp.pszToolTip) + 1);
  //
  Result := 0;
end;

//

function CtrlWndProc_WmSetFont(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  pcp.hFont := HFONT(wParam);
  //
  Result := CallWindowProcW(@pcp.CtrlProc, hWnd, uMsg, wParam, lParam);
  //
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end;

//

function CtrlWndProc_WmSetText(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  ZeroMemory(@pcp.pszText, SizeOf(pcp.pszText));
  lstrcpynW(pcp.pszText, LPWSTR(lParam), lParam);
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  Result := DefWindowProcW(hWnd, uMsg, wParam, lParam);
end;

//

function CtrlWndProc_WmEnable(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  pcp.bIsEnabled := BOOL(wParam);
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_WmMouseLeave(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
var
  pt: TPoint;
begin
  if IsWindow(pcp.hToolTip) then
    SendMessageW(pcp.hToolTip, TTM_TRACKACTIVATE, Integer(FALSE), 0);
  //
  GetCursorPos(pt);
  ScreenToClient(hWnd, pt);
  //
  pcp.bIsHover := FALSE;
  pcp.bIsPress := FALSE;
  //
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_WmMouseMove(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
var
  tme: Windows.TTrackMouseEvent;
  pt : TPoint;
begin
  //
  GetCursorPos(pt);
  ScreenToClient(hWnd, pt);
  //
  tme.cbSize      := SizeOf(Windows.TTrackMouseEvent);
  tme.dwFlags     := TME_LEAVE;
  tme.hwndTrack   := hWnd;
  tme.dwHoverTime := HOVER_DEFAULT;
  //
  pcp.bIsHover := Windows.TrackMouseEvent(tme) and PtInRect(pcp.rcClient, pt);
  pcp.bIsPress := {(wParam = MK_LBUTTON) and} (GetCapture = hWnd) and PtInRect(pcp.rcClient, pt);
  //
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_WmCaptureChanged(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  pcp.bIsPress := FALSE;
  //
  Result := 0;
end;

//

function CtrlWndProc_WmNcHitTest(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  //
  Result := HTCLIENT;
end;

//

function CtrlWndProc_WmlButtonDown(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  //
  if IsWindow(pcp.hToolTip) then
    SendMessageW(pcp.hToolTip, TTM_TRACKACTIVATE, Integer(FALSE), 0);
  pcp.bIsPress := TRUE;
  SetFocus(hWnd);
  SetCapture(hWnd);
  //
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_WmlButtonUp(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
var
  pt: TPoint;
begin
  //
  GetCursorPos(pt);
  ScreenToClient(hWnd, pt);
  if (PtInRect(pcp.rcClient, pt) and (GetCapture = hWnd)) then
    SendMessageW(GetParent(hWnd), WM_COMMAND, MakeLong(GetDlgCtrlID(hWnd), STN_CLICKED), 0);
  // pcp.bIsPress := FALSE;
  ReleaseCapture;
  //
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_WmSetCursor(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  //
  if IsWindow(pcp.hToolTip) then
    SendMessageW(pcp.hToolTip, TTM_TRACKACTIVATE, Integer(TRUE), Integer(@pcp.ti));
  //
  if (pcp.hCursor <> 0) then
    SetCursor(pcp.hCursor);
  //
  Result := 0;
end;

//

function CtrlWndProc_WmSize(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
var
  hdcIn: HDC;
begin
  GetClientRect(hWnd, pcp.rcClient);
  //
  if (pcp.hdcMem <> 0) then
  begin
    SelectObject(pcp.hdcMem, pcp.hbmOld);
    DeleteObject(pcp.hbmMem);
    DeleteDC(pcp.hdcMem);
  end;
  hdcIn := GetDC(hWnd);
  pcp.hdcMem := CreateCompatibleDC(hdcIn);
  pcp.hbmMem := CreateCompatibleBitmap(
    hdcIn,
    pcp.rcClient.Right - pcp.rcClient.Left,
    pcp.rcClient.Bottom - pcp.rcClient.Top
  );
  pcp.hbmOld := SelectObject(pcp.hdcMem, pcp.hbmMem);
  ReleaseDC(hWnd, hdcIn);
  //
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := CallWindowProcW(@pcp.CtrlProc, hWnd, uMsg, wParam, lParam);
end;

//

function CtrlWndProc_WmPaint(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  hdcIn : HDC;
  ps    : TPaintStruct;
  hbrNew: HBRUSH;
begin
  if (wParam = 0) then
    hdcIn := BeginPaint(hWnd, ps)
  else
    hdcIn := wParam;

  if (pcp.clrBckgnd = CLR_DEFAULT) then
    FillRect(pcp.hdcMem, pcp.rcClient, HBRUSH(COLOR_BTNFACE + 1))
  else
  begin
    hbrNew := CreateSolidBrush(pcp.clrBckgnd);
    FillRect(pcp.hdcMem, pcp.rcClient, hbrNew);
    DeleteObject(hbrNew);
  end;

  if pcp.bIsEnabled then
  begin
    if (pcp.bIsHover and pcp.bIsPress) then
      SetTextColor(pcp.hdcMem, pcp.clrPress)
    else
    if (pcp.bIsHover and not pcp.bIsPress) then
      SetTextColor(pcp.hdcMem, pcp.clrHover)
    else
      SetTextColor(pcp.hdcMem, pcp.clrNormal);
  end
  else
    SetTextColor(pcp.hdcMem, GetSysColor(COLOR_GRAYTEXT));

  SetBkMode(pcp.hdcMem, TRANSPARENT);
  SetBkColor(pcp.hdcMem, TRANSPARENT);

  SelectObject(pcp.hdcMem, pcp.hFont);

  DrawTextW(pcp.hdcMem, pcp.pszText, {lstrlenW(pcp.pszText)}-1, pcp.rcClient, pcp.dtStyle);

  BitBlt(hdcIn, 0, 0, pcp.rcClient.Right - pcp.rcClient.Left, pcp.rcClient.Bottom - pcp.rcClient.Top, pcp.hdcMem, 0, 0, SRCCOPY);

  if (wParam = 0) then
    EndPaint(hWnd, ps);

  Result := 0;
end;

//

function CtrlWndProc_WmEraseBkgnd(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  if (pcp.clrBckgnd <> CLR_DEFAULT) then
  begin
    FillRect(HDC(wParam), pcp.rcClient, HBRUSH(COLOR_BTNFACE + 1));
    //
    Result := 1;
  end
  else
    Result := DefWindowProcW(hWnd, uMsg, wParam, lParam);
end;

//

function CtrlWndProc_WmSysColorChange(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
  //
  Result := 0;
end;

//

function CtrlWndProc_WmNotify(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
var
  pnmh: PNMHdr;
  ptit: PToolTipTextW;
begin
  //
  pnmh := PNMHdr(lParam);
  case pnmh.code of
    TTN_NEEDTEXTW:
    begin
      ptit := PToolTipTextW(lParam);
      ptit.lpszText := pcp.pszToolTip;
    end;
  end;
  //
  Result := 0;
end;

//

function CtrlWndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin

  pcp := P_CTRL_PRO(GetWindowLongW(hWnd, GWL_USERDATA));

  if (pcp = nil) then
  begin
    Result := DefWindowProcW(hWnd, uMsg, wParam, lParam);
    Exit;
  end;

  case uMsg of

    //

    STM_EX_SETHOVERCLR:
    begin
      Result := CtrlWndProc_StmExSetHoverClr(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    STM_EX_GETHOVERCLR:
    begin
      Result := CtrlWndProc_StmExGetHoverClr(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    STM_EX_SETNORMALCLR:
    begin
      Result := CtrlWndProc_StmExSetNormalClr(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    STM_EX_GETNORMALCLR:
    begin
      Result := CtrlWndProc_StmExGetNormalClr(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    STM_EX_SETPRESSCLR:
    begin
      Result := CtrlWndProc_StmExSetPressClr(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    STM_EX_GETPRESSCLR:
    begin
      Result := CtrlWndProc_StmExGetPressClr(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    STM_EX_SETBCKGNDCLR:
    begin
      Result := CtrlWndProc_StmExSetBckgdClr(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    STM_EX_GETBCKGNDCLR:
    begin
      Result := CtrlWndProc_StmExGetBckgdClr(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    STM_EX_SETTIPTEXT:
    begin
      Result := CtrlWndProc_StmExSetTipText(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    STM_EX_GETTIPTEXT:
    begin
      Result := CtrlWndProc_StmExGetTipText(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_DESTROY:
    begin
      RemoveStaticHyperlinkW(hWnd);
    end;

    //

    WM_SETFONT:
    begin
      Result := CtrlWndProc_WmSetFont(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_SETTEXT:
    begin
      Result := CtrlWndProc_WmSetText(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_ENABLE:
    begin
      Result := CtrlWndProc_WmEnable(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_MOUSELEAVE:
    begin
      Result := CtrlWndProc_WmMouseLeave(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_MOUSEMOVE:
    begin
      Result := CtrlWndProc_WmMouseMove(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_CAPTURECHANGED:
    begin
      Result := CtrlWndProc_WmCaptureChanged(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_NCHITTEST:
    begin
      Result := CtrlWndProc_WmNcHitTest(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_LBUTTONDOWN:
    begin
      Result := CtrlWndProc_WmlButtonDown(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_LBUTTONUP:
    begin
      Result := CtrlWndProc_WmlButtonUp(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_SETCURSOR:
    begin
      Result := CtrlWndProc_WmSetCursor(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_SIZE:
    begin
      Result := CtrlWndProc_WmSize(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_PRINTCLIENT,
    WM_PAINT,
    WM_UPDATEUISTATE:
    begin
      Result := CtrlWndProc_WmPaint(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_ERASEBKGND:
    begin
      Result := CtrlWndProc_WmEraseBkgnd(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_SYSCOLORCHANGE:
    begin
      Result := CtrlWndProc_WmSysColorChange(pcp, hWnd, uMsg, wParam, lParam);
    end;

    //

    WM_NOTIFY:
    begin
      Result := CtrlWndProc_WmNotify(pcp, hWnd, uMsg, wParam, lParam);
    end;

  else
    Result := CallWindowProcW(@pcp.CtrlProc, hWnd, uMsg, wParam, lParam);
  end;

end;

//

procedure CreateStaticHyperlinkW(hWnd: HWND);
var
  iccex  : TInitCommonControlsEx;
  dtStyle: DWORD;
  dwLen  : Integer;
begin

  iccex.dwSize := SizeOf(TInitCommonControlsEx);
  iccex.dwICC  := ICC_BAR_CLASSES;
  InitCommonControlsEx(iccex);

  RemoveStaticHyperlinkW(hWnd);

  pcp := P_CTRL_PRO(HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, SizeOf(T_CTRL_PRO)));

  ZeroMemory(pcp, SizeOf(pcp));
  pcp.CtrlProc   := TCtrlWndProc(Pointer(GetWindowLongW(hWnd, GWL_WNDPROC)));
  pcp.hCursor    := LoadImageW(0, MAKEINTRESOURCEW(IDC_HAND), IMAGE_CURSOR, 0, 0, LR_SHARED or LR_DEFAULTSIZE);

  pcp.hFont      := SendMessageW(hWnd, WM_GETFONT, 0, 0);

  GetClientRect(hWnd, pcp.rcClient);

  pcp.clrHover   := RGB(255, 0, 0);
  pcp.clrNormal  := RGB(0, 0, 255);
  pcp.clrPress   := RGB(0, 0, 128);
  pcp.clrBckgnd  := CLR_DEFAULT;

  dwLen := SendMessageW(hWnd, WM_GETTEXTLENGTH, 0, 0);
  if (dwLen > 0) then
  begin
    ZeroMemory(@pcp.pszText, SizeOf(pcp.pszText));
    SendMessageW(hWnd, WM_GETTEXT, SizeOf(pcp.pszText), Integer(@pcp.pszText));
  end;

  pcp.bIsHover   := FALSE;
  pcp.bIsPress   := FALSE;
  pcp.bIsEnabled := IsWindowEnabled(hWnd);

  pcp.hToolTip   := CreateWindowExW(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP, Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), GetParent(hWnd), 0, hInstance, nil);
  if IsWindow(pcp.hToolTip) then
  begin
    pcp.ti.cbSize   := SizeOf(TToolInfoW);
    pcp.ti.uFlags   := TTF_SUBCLASS or TTF_IDISHWND;
    pcp.ti.hwnd     := hWnd;
    pcp.ti.uId      := hWnd;
    pcp.ti.lpszText := LPSTR_TEXTCALLBACKW;
    SetRectEmpty(pcp.ti.Rect);
    ZeroMemory(@pcp.pszToolTip, SizeOf(pcp.pszToolTip));
    SendMessageW(pcp.hToolTip, TTM_ADDTOOLW, 0, Integer(@pcp.ti));
  end;

  dtStyle := GetWindowLongW(hWnd, GWL_STYLE);

  case (dtStyle and SS_TYPEMASK) of
    SS_LEFT          : pcp.dtStyle := DT_LEFT or DT_EXPANDTABS {or DT_WORDBREAK};
    SS_CENTER        : pcp.dtStyle := DT_CENTER or DT_EXPANDTABS {or DT_WORDBREAK};
    SS_RIGHT         : pcp.dtStyle := DT_RIGHT or DT_EXPANDTABS {or DT_WORDBREAK};
    SS_SIMPLE        : pcp.dtStyle := DT_LEFT or DT_SINGLELINE;
    SS_LEFTNOWORDWRAP: pcp.dtStyle := DT_LEFT or DT_EXPANDTABS;
  end;
  if ((dtStyle and SS_CENTERIMAGE) = 0) then
    pcp.dtStyle := pcp.dtStyle or DT_VCENTER;
  if ((dtStyle and SS_NOTIFY) = 0) then
    SetWindowLongW(hWnd, GWL_STYLE, dtStyle or SS_NOTIFY);

  SetWindowLongW(hWnd, GWL_USERDATA, Longint(pcp));

  SetWindowLongW(hWnd, GWL_WNDPROC, Longint(@CtrlWndProc));

  // так как мы создаем hdcMem заного при изменении размеров окна элемента
  // управления, то не будем здесь создавать изначально контексты, а просто
  // уведомим элемент управления сообщением об изменении размеров.

  SendMessageW(hWnd, WM_SIZE, 0, 0); // RedrawWindow(hWnd, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);

end;

//

procedure RemoveStaticHyperlinkW(hWnd: HWND);
begin

  pcp := P_CTRL_PRO(GetWindowLongW(hWnd, GWL_USERDATA));
  if (pcp <> nil) then
  begin

    if (pcp.hCursor <> 0) then
      DestroyCursor(pcp.hCursor);

    pcp.ti.hwnd := hWnd;
    pcp.ti.uId  := hWnd;
    if IsWindow(pcp.hToolTip) then
    begin
      SendMessageW(pcp.hToolTip, TTM_DELTOOLW, 0, Integer(@pcp.ti));
      DestroyWindow(pcp.hToolTip);
    end;

    if (pcp.hdcMem <> 0) then
    begin
      SelectObject(pcp.hdcMem, pcp.hbmOld);
      DeleteObject(pcp.hbmMem);
      DeleteDC(pcp.hdcMem);
    end;

    //

    SetWindowLongW(hWnd, GWL_WNDPROC, Longint(@pcp.CtrlProc));
    RedrawWindow(hWnd, @pcp.rcClient, 0, RDW_INVALIDATE or RDW_ERASE);

    SetWindowLongW(hWnd, GWL_USERDATA, 0);
    HeapFree(GetProcessHeap, 0, pcp);

  end;

end;

end.

Автор: navodri 22.6.2010, 17:47
Итак, на основе кода от Maks1509 (за что ему огромное спасибо), который я порезал и взял самое необходимое (ИМХО), получилось показать подсказку для органа управления GROUPBOX. Но есть и много недочетов. Один из них - если вести курсор мышки вверх от GROUPBOXа, то подсказка постоянно мигает и уходит вверх от курсора. Подскажите, как исправить?. И еще хотелось бы чтобы подсказка показывалась именно там, где находится курсор?

Код

unit F_LinkPaint;

interface

uses
  Windows, Messages, CommCtrl;

const
  TTM_TRACKACTIVATE = WM_USER + 17;
  TTS_BALLOON  = $40;
  HEAP_ZERO_MEMORY = 8;
  TTM_SETTITLEW           = WM_USER + 33;

procedure CreateStaticHyperlinkW(hWnd: HWND; tipText: PWideChar);
procedure RemoveStaticHyperlinkW(hWnd: HWND);

implementation

type
  TCtrlWndProc = function(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
  P_CTRL_PRO = ^T_CTRL_PRO;
  T_CTRL_PRO = packed record
    CtrlProc  : TCtrlWndProc;
    rcClient  : TRect;
    pszText   : Array [0..MAX_PATH-1] of WideChar;
    bIsHover  : Boolean;
    bIsEnabled: Boolean;
    hToolTip  : HWND;
    ti        : TToolInfoW;
    pszToolTip: Array [0..MAX_PATH-1] of WideChar;
  end;

var
  pcp: P_CTRL_PRO;

function CtrlWndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  tme: Windows.TTrackMouseEvent;
  pt : TPoint;
begin
 Result := 0;
 pcp := P_CTRL_PRO(GetWindowLongW(hWnd, GWL_USERDATA));
  if (pcp = nil) then begin
   Result := DefWindowProcW(hWnd, uMsg, wParam, lParam);
   Exit;
  end;
 case uMsg of
  WM_DESTROY: RemoveStaticHyperlinkW(hWnd);
  WM_MOUSELEAVE: if IsWindow(pcp.hToolTip) then SendMessageW(pcp.hToolTip, TTM_TRACKACTIVATE, Integer(FALSE), 0);
  WM_MOUSEMOVE:
    begin
     GetCursorPos(pt);
     ScreenToClient(hWnd, pt);
     tme.cbSize      := SizeOf(Windows.TTrackMouseEvent);
     tme.dwFlags     := TME_LEAVE;
     tme.hwndTrack   := hWnd;
     tme.dwHoverTime := HOVER_DEFAULT;
     pcp.bIsHover := Windows.TrackMouseEvent(tme) and PtInRect(pcp.rcClient, pt);
    end;

   WM_NCHITTEST: Result := HTCLIENT;
   WM_SETCURSOR: if IsWindow(pcp.hToolTip) then SendMessageW(pcp.hToolTip, TTM_TRACKACTIVATE, Integer(TRUE), Integer(@pcp.ti));
  else
   Result := CallWindowProcW(@pcp.CtrlProc, hWnd, uMsg, wParam, lParam);
 end;
end;

procedure CreateStaticHyperlinkW(hWnd: HWND; tipText: PWideChar);
var
 iccex  : TInitCommonControlsEx;
begin
 iccex.dwSize := SizeOf(TInitCommonControlsEx);
 iccex.dwICC  := ICC_BAR_CLASSES;
 InitCommonControlsEx(iccex);

 pcp := P_CTRL_PRO(HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, SizeOf(T_CTRL_PRO)));
 ZeroMemory(pcp, SizeOf(pcp));
 pcp.CtrlProc   := TCtrlWndProc(Pointer(GetWindowLongW(hWnd, GWL_WNDPROC)));

 pcp.bIsHover   := FALSE;
 pcp.bIsEnabled := IsWindowEnabled(hWnd);

 pcp.hToolTip   := CreateWindowExW(WS_EX_TOPMOST, 'tooltips_class32', nil, WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP or TTS_BALLOON,
  Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), GetParent(hWnd), 0, hInstance, nil);
   if IsWindow(pcp.hToolTip) then begin
    pcp.ti.cbSize   := SizeOf(TToolInfoW);
    pcp.ti.uFlags   := TTF_SUBCLASS or TTF_IDISHWND;
    pcp.ti.hwnd     := hWnd;
    pcp.ti.uId      := hWnd;
    pcp.ti.lpszText := tipText;

    SetRectEmpty(pcp.ti.Rect);
    ZeroMemory(@pcp.pszToolTip, SizeOf(pcp.pszToolTip));
    SendMessageW(pcp.hToolTip, TTM_ADDTOOLW, 0, Integer(@pcp.ti));
   end;
 SetWindowLongW(hWnd, GWL_USERDATA, Longint(pcp));
 SetWindowLongW(hWnd, GWL_WNDPROC, Longint(@CtrlWndProc));
end;

procedure RemoveStaticHyperlinkW(hWnd: HWND);
begin
 pcp := P_CTRL_PRO(GetWindowLongW(hWnd, GWL_USERDATA));
  if (pcp <> nil) then begin
   pcp.ti.hwnd := hWnd;
   pcp.ti.uId  := hWnd;
    if IsWindow(pcp.hToolTip) then begin
     SendMessageW(pcp.hToolTip, TTM_DELTOOLW, 0, Integer(@pcp.ti));
     DestroyWindow(pcp.hToolTip);
    end;
   SetWindowLongW(hWnd, GWL_WNDPROC, Longint(@pcp.CtrlProc));
  SetWindowLongW(hWnd, GWL_USERDATA, 0);
  HeapFree(GetProcessHeap, 0, pcp);
 end;
end;

end.

Автор: Maks1509 23.6.2010, 00:38
Если подсказка обычная - вроде бы окно не моргает.

Код

unit F_LinkPaint;

interface

uses
  Windows, Messages, CommCtrl;

const
  TTM_TRACKACTIVATE = WM_USER + 17;
  TTS_BALLOON       = $40;
  HEAP_ZERO_MEMORY  = 8;
  TTM_SETTITLEW     = WM_USER + 33;

procedure CreateStaticHyperlinkW(hWnd: HWND; tipText: PWideChar);
procedure RemoveStaticHyperlinkW(hWnd: HWND);

implementation

type
  TCtrlWndProc = function(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
  P_CTRL_PRO = ^T_CTRL_PRO;
  T_CTRL_PRO = packed record
    CtrlProc  : TCtrlWndProc;
    hToolTip  : HWND;
    ti        : TToolInfoW;
    pszToolTip: Array [0..MAX_PATH-1] of WideChar;
  end;

var
  pcp: P_CTRL_PRO;

function CtrlWndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  tme: Windows.TTrackMouseEvent;
  pt : TPoint;
begin

  pcp := P_CTRL_PRO(GetWindowLongW(hWnd, GWL_USERDATA));
  if (pcp = nil) then
  begin
   Result := DefWindowProcW(hWnd, uMsg, wParam, lParam);
   Exit;
  end;

  case uMsg of

    WM_DESTROY:
    begin
      RemoveStaticHyperlinkW(hWnd);
      Result := 0;
    end;

    WM_MOUSELEAVE:
    begin
      if IsWindow(pcp.hToolTip) then
        SendMessageW(pcp.hToolTip, TTM_TRACKACTIVATE, Integer(FALSE), 0);
      Result := 0;
    end;

    WM_MOUSEMOVE:
    begin
      GetCursorPos(pt);
      ScreenToClient(hWnd, pt);
      tme.cbSize      := SizeOf(Windows.TTrackMouseEvent);
      tme.dwFlags     := TME_LEAVE;
      tme.hwndTrack   := hWnd;
      tme.dwHoverTime := HOVER_DEFAULT;
      Windows.TrackMouseEvent(tme);
      if IsWindow(pcp.hToolTip) then
      begin
        GetCursorPos(pt);
        SendMessageW(pcp.hToolTip, TTM_TRACKPOSITION, 0, MakeLParam(pt.x, pt.y));
        SendMessageW(pcp.hToolTip, TTM_TRACKACTIVATE, Integer(TRUE), Integer(@pcp.ti));
      end;
      Result := 0;
    end;

    WM_NCHITTEST:
    begin
      Result := HTCLIENT;
    end;

  else
    Result := CallWindowProcW(@pcp.CtrlProc, hWnd, uMsg, wParam, lParam);
  end;

end;

procedure CreateStaticHyperlinkW(hWnd: HWND; tipText: PWideChar);
var
  iccex: TInitCommonControlsEx;
begin

  iccex.dwSize := SizeOf(TInitCommonControlsEx);
  iccex.dwICC  := ICC_BAR_CLASSES;
  InitCommonControlsEx(iccex);

  pcp := P_CTRL_PRO(HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, SizeOf(T_CTRL_PRO)));
  ZeroMemory(pcp, SizeOf(pcp));
  pcp.CtrlProc := TCtrlWndProc(Pointer(GetWindowLongW(hWnd, GWL_WNDPROC)));
  pcp.hToolTip := CreateWindowExW(WS_EX_NOACTIVATE or WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP or TTS_BALLOON, Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), GetParent(hWnd), 0, hInstance, nil);

  if IsWindow(pcp.hToolTip) then
  begin
    pcp.ti.cbSize   := SizeOf(TToolInfoW);
    pcp.ti.uFlags   := TTF_SUBCLASS or TTF_IDISHWND or TTF_ABSOLUTE;
    pcp.ti.hwnd     := hWnd;
    pcp.ti.uId      := hWnd;
    pcp.ti.lpszText := tipText;
    SetRectEmpty(pcp.ti.Rect);
    ZeroMemory(@pcp.pszToolTip, SizeOf(pcp.pszToolTip));
    SendMessageW(pcp.hToolTip, TTM_ADDTOOLW, 0, Integer(@pcp.ti));
   end;

  SetWindowLongW(hWnd, GWL_USERDATA, Longint(pcp));
  SetWindowLongW(hWnd, GWL_WNDPROC, Longint(@CtrlWndProc));

end;

procedure RemoveStaticHyperlinkW(hWnd: HWND);
begin

  pcp := P_CTRL_PRO(GetWindowLongW(hWnd, GWL_USERDATA));
  if (pcp <> nil) then
  begin

    if IsWindow(pcp.hToolTip) then
    begin
      pcp.ti.hwnd := hWnd;
      pcp.ti.uId  := hWnd;
      SendMessageW(pcp.hToolTip, TTM_DELTOOLW, 0, Integer(@pcp.ti));
      DestroyWindow(pcp.hToolTip);
    end;

    SetWindowLongW(hWnd, GWL_WNDPROC, Longint(@pcp.CtrlProc));
    SetWindowLongW(hWnd, GWL_USERDATA, 0);
    HeapFree(GetProcessHeap, 0, pcp);
    
  end;

end;

end.

Автор: navodri 23.6.2010, 09:49
Действительно, окно моргает только, когда TTS_BALLOON. Думаю, смогу это пережить... Но, если есть возможные решения, - выслушаю. Спасибо!

Автор: navodri 23.6.2010, 13:44
! Возникла проблема с отображением заголовков подсказки. Текст читается х.з. как: какие-то символы. 
Добавляю следующий код перед  SendMessageW(pcp.hToolTip, TTM_ADDTOOLW, 0, Integer(@pcp.ti));

Код

var
 hintbuffer : array[0..1023] of Char;

...

 fillchar(hintbuffer, sizeof(hintbuffer), #0); lstrcpy(hintbuffer, PChar('Заголовок подсказки'));
 SendMessage(pcp.hToolTip, TTM_SETTITLEW, 1, integer(@hintbuffer));


Что не так?

Автор: Maks1509 23.6.2010, 15:07
Просто в модуле все функции Unicode, а у тебя проект ANSI. Либо приведи их тоже к ANSI, либо портируй сразу проект под Unicode функции (лучше этот вариант).

Автор: navodri 23.6.2010, 16:52
Спасибо! Вот так заработало:

Код

var
 hintbuffer : array[0..1023] of Char;
...
  FillChar(hintbuffer, SizeOf(hintbuffer), #0);
  lstrcpyW(@hintbuffer, 'Заголовок подсказки');
  SendMessage(pcp.hToolTip, TTM_SETTITLEW, 1, integer(@hintbuffer));

Автор: Maks1509 23.6.2010, 18:44
Чтобы вдальнейшем не зависеть от версий Delphi (ведь с версии 2009 года вроде Char считается как юникодный WideChar), лучше так если проект юникодный:

Код

var
 hintbuffer: Array [0..1023] of WideChar;
...
  FillChar(hintbuffer, SizeOf(hintbuffer), #0);
  lstrcpyW(@hintbuffer, LPWSTR(WideString('Заголовок подсказки')));
  SendMessageW(pcp.hToolTip, TTM_SETTITLEW, 1, integer(@hintbuffer));



Код

var
 hintbuffer: Array [0..1023] of AnsiChar;
...
  FillChar(hintbuffer, SizeOf(hintbuffer), #0);
  lstrcpy(@hintbuffer, 'Заголовок подсказки');
  SendMessage(pcp.hToolTip, TTM_SETTITLE, 1, integer(@hintbuffer));


=)

Автор: navodri 23.6.2010, 21:13
Сенкс! Это полезная информация!

Powered by Invision Power Board (http://www.invisionboard.com)
© Invision Power Services (http://www.invisionpower.com)