Hint в ComboBox

Вот вчера столкнулся с проблемой вывода подсказок для ComboBox если в него строка не влазит.
Почитав советы по Delphi понял что ничего непонял Попробовал написать как описано ничего не получилось плюнул на все и забил.
Но всеже... вот пример с этих советов:

В своем компоненте объявите FTipHint:

type
TVSComboBox = class(TCustomComboBox)
…
private
FHint: THintWindow;
…
protected
procedure WMCTLCOLORLISTBOX(var Message: TMessage); message WM_CTLCOLORLISTBOX;

и не забудьте выполнить инициализацию в конструкторе вашего компонента:

begin
inherited Create(AOwner);
FHint := THintWindow.Create(Self);

Чтобы получить информацию об активной строке в выпадающем списке ComboBox перехватите сообщение WM_CTLCOLORLISTBOX. В процедуре сообщения анализируйте - если длина строки больше ширины выпадающего списка – передайте "длинную" строку в ваш Hint и активируйте его:

FHint.ActivateHint(TextRC, Items[ItemIndex]);

где
TextRC – прямоугольник для строки подсказки
Items[ItemIndex] – "длинная" строка из выпадающего списка

Если активная строка в выпадающем списке "короткая" – спрячьте Hint:

FHint.ReleaseHandle;

Если знаете то приведите пожалуйста небольшой пример как это все воплотить и как его правильно написать, а то я немогу въехать в слова автора "В своем компоненте объявите FTipHint:" а про компонент FTipHint: ни слова и вообще накидано по кусках а разобраться и сложить все в кучу не получается

Заранее спасибо.

Сообщение отредактировано: Megatron - 26.02.08, 17:32

Посмотри в DW5000, там есть готовый проект

Добавлено 27.02.08, 11:56
Собственно вот он:

{
  Наследник TComboBox, показывающий Hint для строки в ListBox'овой части,
  не видимой целиком.
 
  Автор: Игорь Шевченко
  Дата создания: 13.04.2002
 
  Ограничения:
  Компонент проверялся при работе с значением Style: csDropDown, csDropDownList.
  при остальных значениях работа не гарантируется :-)
  Компонент не тестировался в режиме design-time.
 
  История изменений:
  16.04.2002 Исправлено поведение при закрытии, когда показан hint и ComboBox
             закрывается по клавише Enter, Escape или F4. Теперь hint убирается.
             Добавлено свойство HorizontalExtent, позволяющее устанавливать
             горизонтальный Scrollbar в списке ComboBox'a. По умолчанию свойство
             имеет значение -1, что запрещает установку горизонтального
             ScrollBar'а.
}
unit HSHintComboBox;
 
interface
uses
  Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls;
 
type
  TListBoxTip = class(THintWindow)
  end;
 
  TShowComboToolTipEvent = procedure (Sender : TObject;
                                     const ToolTipText : String;
                                     var HideToolTip : Boolean) of object;
 
  THSHintComboBox = class(TComboBox)
  private
    FListBoxTip : TListBoxTip;
    FListHandle : HWND;
    FListWndProcInstance : TFarProc;
    FOldListWndProc : TFarProc;
    FOnListMouseMove: TMouseMoveEvent;
    FOnShowComboToolTip: TShowComboToolTipEvent;
    FShowToolTips: Boolean;
    FHorizontalExtent: Integer;
    procedure ListWndProc (var Message : TMessage);
    function ListBoxItemAtPos (I : Integer) : String;
    function ListBoxItemRectAtPos (I : Integer; AText : String) : TRect;
    procedure SetShowToolTips(const Value: Boolean);
    procedure SetHorizontalExtent(const Value: Integer);
  protected
    procedure DoListMouseMove (Shift: TShiftState; X, Y: Integer); dynamic;
    procedure DoShowComboToolTip (const ToolTipText : String;
                                 var HideToolTip : Boolean); dynamic;
    procedure WndProc (var Message: TMessage); override;
{16.04.2002}
    procedure CreateParams (var Params : TCreateParams); override;
    procedure CreateWnd; override;
{/16.04.2002}
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    { Handle окна ListBox'а, являющегося частью ComboBox'a }
    property HSListHandle : HWND read FListHandle;
    { Показывать ли Hint для строк, не видимых целиком в ListBox'е }
    property ShowToolTips : Boolean read FShowToolTips
                         write SetShowToolTips default true;
    { Событие при движении мыши по ListBox'у. Так как ListBox захватывает
      (Captured) мышь, то координаты курсора в этом событии могут быть за
      пределами клентской части ListBox'а }
    property OnListMouseMove : TMouseMoveEvent read FOnListMouseMove
        write FOnListMouseMove;
    { Событие при показе Hint'а для ListBox'а. Установив HideHint в True,
      можно запретить показ конкретного Hint'а }
    property OnShowComboToolTip : TShowComboToolTipEvent
        read FOnShowComboToolTip write FOnShowComboToolTip;
{16.04.2002}
    property HorizontalExtent : Integer read FHorizontalExtent
       write SetHorizontalExtent default -1;
{/16.04.2002}
  end;
 
implementation
uses SysUtils;
 
function RectWidth(R : TRect) : Integer;
begin
  Result := R.Right - R.Left;
end;
 
function RectHeight(R : TRect) : Integer;
begin
  Result := R.Bottom - R.Top;
end;
 
{ THSHintComboBox }
 
constructor THSHintComboBox.Create(AOwner: TComponent);
begin
  inherited;
  FListBoxTip := TListBoxTip.Create(Self);
  FListBoxTip.Color := clInfoBk;
  FListWndProcInstance := MakeObjectInstance(ListWndProc);
  FShowToolTips := true;
  FHorizontalExtent := -1;
end;
 
destructor THSHintComboBox.Destroy;
begin
  if (FListHandle <> 0) AND IsWindow(FListHandle) then
    SetWindowLong(FListHandle, GWL_WNDPROC, LongInt(FOldListWndProc));
  FreeObjectInstance(FListWndProcInstance);
  inherited;
end;
 
procedure THSHintComboBox.DoShowComboToolTip(const ToolTipText: String;
                                             var HideToolTip : Boolean);
begin
  if Assigned(FOnShowComboToolTip) then
    FOnShowComboToolTip (Self, ToolTipText, HideToolTip);
end;
 
procedure THSHintComboBox.DoListMouseMove(Shift: TShiftState; X,
  Y: Integer);
 
  procedure AdjustHintRect (var R : TRect; const AHintStr : String);
  var
    DC : HDC;
    OldFont : HFONT;
    TextSize : SIZE;
  begin
    DC := GetDC (HWND_DESKTOP);
    try
      OldFont := SelectObject(DC, Screen.HintFont.Handle);
      try
        if (NOT GetTextExtentPoint32(DC, PChar(AHintStr), StrLen(PChar(AHintStr)), TextSize)) then
          RaiseLastWin32Error;
        Inc(TextSize.cx, 6);
        Inc(TextSize.cy, 2);
        if RectWidth(R) < TextSize.cx then
          R.Right := R.Left + TextSize.cx;
        if RectHeight(R) < TextSize.cy then
          R.Bottom := R.Top + TextSize.cy;
      finally
        SelectObject(DC, OldFont);
      end;
    finally
      ReleaseDC (HWND_DESKTOP, DC);
    end;
  end;
 
var R, ItemRect : TRect;
    I : Integer;
    ItemText : String;
    HideToolTip : Boolean;
begin
  HideToolTip := True; { По умолчанию выключать Hint }
  if FShowToolTips then begin
    Windows.GetClientRect(FListHandle, R);
    { X и Y являются координатами клиента (в данном случае, ListBox }
    if PtInRect(R, Point(X,Y)) AND (Shift = []) then begin
      { Определим, помещается ли текущая строка целиком в область ListBox }
      I := SendMessage(FListHandle, LB_ITEMFROMPOINT, 0, MakeLParam(X,Y));
      if HiWord(I) <> 0 then
        I := -1;
      if I <> -1 then begin
        ItemText := ListBoxItemAtPos(I);
        ItemRect := ListBoxItemRectAtPos(I, ItemText);
        if RectWidth(ItemRect) > RectWidth(R) then begin
          { Надо показывать Hint, так как строка не помещается целиком
            в клиентскую область ListBox }
          Windows.ClientToScreen(FListHandle, ItemRect.TopLeft);
          Windows.ClientToScreen(FListHandle, ItemRect.BottomRight);
          Dec(ItemRect.Left, 3);
          Inc(ItemRect.Right, 6);
          HideToolTip := false; { Не надо гасить hint }
          DoShowComboToolTip (ItemText, HideToolTip); { Для возможности
                                         отображения строки Hint дополнительно
                                         в другом месте или запрета
                                         конкретного Hint'а}
{16.04.2002}
          if NOT HideToolTip then
{ Если двигаться мышью в горизонтальном направлении на элементе, для которого
  должен показываться Hint, то ActivateHint не стоит вызывать, если Hint уже
  уже на экране }
            if NOT (IsWindow(FListBoxTip.Handle) and
                    IsWindowVisible(FListBoxTip.Handle) and
                   (StrComp(PChar(FListBoxTip.Caption),PChar(ItemText)) = 0)) then begin
              AdjustHintRect (ItemRect, ItemText);
              FListBoxTip.ActivateHint(ItemRect, ItemText);
            end;
{/16.04.2002}
        end;
      end;
    end;
  end;
  if HideToolTip then
    FListBoxTip.ReleaseHandle; { Не надо показывать Hint, если мышь за пределами
                                 ListBox или строка видна целиком }
  { Если кому-то вздумается следить за перемещениями мыши в области ListBox.
    Я при отладке использовал это событие для отображения координат мыши }
  if Assigned(FOnListMouseMove) then
    FOnListMouseMove(Self, Shift, X, Y);
end;
 
function THSHintComboBox.ListBoxItemAtPos(I: Integer): String;
var
  L : Integer;
begin
  if I <> -1 then begin
    L := SendMessage(FListHandle, LB_GETTEXTLEN, I, 0);
    SetLength(Result, L+1); { +1 на нулевой символ в конце строки }
    SendMessage(FListHandle, LB_GETTEXT, I, Integer(PChar(Result)));
  end else
    Result := '';
end;
 
function THSHintComboBox.ListBoxItemRectAtPos(I: Integer;
  AText: String): TRect;
var
  DC : HDC;
  OldFont : HFONT;
begin
  Result := Rect(0, 0, 0, 0);
  if (I <> -1) AND (SendMessage(FListHandle, LB_GETITEMRECT, I,
                    Integer(@Result)) <> LB_ERR) then begin
    DC := GetDC(FListHandle);
    try
      OldFont := SelectObject(DC, Font.Handle);
      try
        DrawText(DC, PChar(AText), -1, Result, DT_CALCRECT);
      finally
        SelectObject(DC, OldFont);
      end;
    finally
      ReleaseDC(FListHandle, DC);
    end;
  end;
end;
 
procedure THSHintComboBox.ListWndProc(var Message: TMessage);
begin
  case Message.Msg of
  WM_MOUSEMOVE:
    with TWMMouseMove(Message) do
      DoListMouseMove(KeysToShiftState(Keys), XPos, YPos);
{16.04.2002}
{ Как выяснилось, при нажатии Esc или Enter на выбранном элементе, который
  показывает Hint, ComboBox закрывается, а Hint остается. :-(
  Сообщение SHOWWINDOW с WPARAM=0 гарантировано выдается, когда закрывается
  окно, так что это место можно использовать для гашения Hint'a }
  WM_SHOWWINDOW:
    if Message.WParam = 0 then
      FListBoxTip.ReleaseHandle();
{/16.04.2002}
  end;
  with Message do
    Result := CallWindowProc(FOldListWndProc, FListHandle, Msg, WParam, LParam);
end;
 
procedure THSHintComboBox.SetShowToolTips(const Value: Boolean);
begin
  FShowToolTips := Value;
end;
 
procedure THSHintComboBox.WndProc(var Message: TMessage);
begin
  if (Message.Msg = WM_CTLCOLORLISTBOX) AND (FListHandle = 0) then begin
    FListHandle := HWND(Message.LParam);
    FOldListWndProc := Pointer(GetWindowLong(FListHandle, GWL_WNDPROC));
    SetWindowLong(FListHandle,
                  GWL_WNDPROC, LongInt(FListWndProcInstance));
  end;
  inherited;
end;
 
{16.04.2002}
procedure THSHintComboBox.CreateParams(var Params: TCreateParams);
begin
  inherited;
  if FHorizontalExtent <> -1 then
    with Params do
      Style := Style OR WS_HSCROLL;
end;
 
procedure THSHintComboBox.SetHorizontalExtent(const Value: Integer);
begin
  if (FHorizontalExtent <> Value) then begin
    FHorizontalExtent := Value;
    if NOT (csLoading in ComponentState) then
      RecreateWnd();
  end;
end;
 
procedure THSHintComboBox.CreateWnd;
begin
  inherited;
  if FHorizontalExtent <> -1 then
    Perform(CB_SETHORIZONTALEXTENT, FHorizontalExtent, 0);
end;
{/16.04.2002}
 
end.

Savek, мне кажется правильнее было бы указать на сайт Delphikingdom, потому что впервые этот класс появился, кажется, там.

Savek У меня тоже есть этот пример вот только, он почему то глючит когда наводишь курсор на первую длинную строку, то Hint выскакивает за выпадающимся меню ComboBox, а потом все нормально работает и этот пример работает только с Style: csDropDown, csDropDownList.

Сообщение отредактировано: Megatron - 27.02.08, 14:25

Для кучи, выложу свое решение, написанное некогда давно, также под влиянием кода Игоря Шевченко. Идея только несколько отличается - вместо потомка TComboBox - неоконный компонент, который нужно просто бросить на любую форму, и все ComboBox-ы начнут показывать Hint

unit ComboBoxPatch;
 
interface
 
uses Windows, Messages, SysUtils, Classes, Controls, Graphics, AppEvnts;
 
type
  EComboBoxPatchException = class(Exception);
 
  TComboBoxPatch = class(TComponent)
  private
    FHintWnd: THintWindow;
    FCanvas: TCanvas;
    FAppEvnts: TApplicationEvents;
    FHintIndex: Integer;
    FActive: Boolean;
    FAlwaysShowHint: Boolean;
    procedure AdjustHint(Wnd: HWND; Point: TPoint);
    procedure DoIdle(Sender: TObject; var Done: Boolean);
    procedure ShowHint(Origin: TPoint; Text: String);
    procedure HideHint;
    procedure SetActive(const Value: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Active: Boolean read FActive write SetActive default true;
    property AlwaysShowHint: Boolean read FAlwaysShowHint write FAlwaysShowHint default false;
  end;
 
const
  RSOnlyOneComboBoxPatch = 'Only one TComboBoxPatch can exist per application.';
 
var
  GlobalPatch: TComboBoxPatch = nil;
 
procedure Register;
 
implementation
 
uses Forms;
 
procedure Register;
begin
  RegisterComponents('Samples',[TComboBoxPatch]);
end;
 
{ TComboBoxPatch }
 
procedure TComboBoxPatch.AdjustHint(Wnd: HWND; Point: TPoint);
var
  HintPt: TPoint;
  ItemRect: TRect;
  Item, TextWidth: Integer;
  buf: array[0..127] of Char;
begin
  Windows.ScreenToClient(Wnd,Point);
  Item:=SendMessage(Wnd,LB_ITEMFROMPOINT,0,lParam(PointToSmallPoint(Point)));
  if (Item and $00010000 <> $00010000) and (Item <> FHintIndex) then begin
    FHintIndex:=Item;
    SendMessage(Wnd,LB_GETTEXT,Item,Integer(@buf));
    SendMessage(Wnd,LB_GETITEMRECT,Item,Integer(@ItemRect));
    FCanvas.Handle:=GetDC(Wnd);
    TextWidth:=FCanvas.TextWidth(buf);
    ReleaseDC(Wnd,FCanvas.Handle);
    FCanvas.Handle:=0;
    if FAlwaysShowHint or ((not FAlwaysShowHint) and (ItemRect.Right < TextWidth)) then begin
      HintPt:=ItemRect.TopLeft;
      Windows.ClientToScreen(Wnd,HintPt);
      ShowHint(HintPt,buf);
    end
    else begin
      HideHint;
    end;
  end
  else begin
    if Item < 0 then HideHint;
  end;
end;
 
constructor TComboBoxPatch.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if Assigned(GlobalPatch) then begin
    raise EComboBoxPatchException.Create(RSOnlyOneComboBoxPatch);
  end
  else begin
    GlobalPatch:=Self;
  end;
  FHintIndex:=-1;
  FHintWnd:=THintWindow.Create(Self);
  FHintWnd.Color:=Application.HintColor;
  FCanvas:=TCanvas.Create;
  FAppEvnts:=TApplicationEvents.Create(Self);
  FAlwaysShowHint:=false;
  Active:=true;
end;
 
destructor TComboBoxPatch.Destroy;
begin
  GlobalPatch:=nil;
  FCanvas.Free;
  FAppEvnts.Free;
  FHintWnd.Free;
  inherited Destroy;
end;
 
procedure TComboBoxPatch.DoIdle(Sender: TObject; var Done: Boolean);
var
  Pt: TPoint;
  buf: array[0..127] of Char;
  Wnd: HWND;
begin
  GetCursorPos(Pt);
  Wnd:=WindowFromPoint(Pt);
  if Wnd <> 0 then begin
    GetClassName(Wnd,buf,SizeOf(buf));
    if buf = 'ComboLBox' then begin
      AdjustHint(Wnd,Pt);
    end
    else begin
      HideHint;
    end;
  end;
end;
 
procedure TComboBoxPatch.HideHint;
begin
  FHintWnd.ReleaseHandle;
  FHintIndex:=-1;
end;
 
procedure TComboBoxPatch.SetActive(const Value: Boolean);
begin
  if Value <> FActive then begin
    FActive:=Value;
    if Value then FAppEvnts.OnIdle:=DoIdle else FAppEvnts.OnIdle:=nil;
  end;
end;
 
procedure TComboBoxPatch.ShowHint(Origin: TPoint; Text: String);
var
  R: TRect;
begin
  Application.CancelHint;
  R:=FHintWnd.CalcHintRect(1000,Text,nil);
  OffsetRect(R,Origin.X,Origin.Y);
  FHintWnd.ActivateHint(R,Text);
  SetWindowPos(FHintWnd.Handle,HWND_TOPMOST,R.Left,R.Top,FHintWnd.Width,
    FHintWnd.Height,SWP_NOACTIVATE);
end;
 
end.

Компонент очень хороший! Спасибо за него Игорю Шевченко.

Глюк, когда при первом наведении мышью на элемент list'а hint уходит на задний план, можно исправить, добавив (выделено жирным)

if NOT HideToolTip then
{ Если двигаться мышью в горизонтальном направлении на элементе, для которого
должен показываться Hint, то ActivateHint не стоит вызывать, если Hint уже
уже на экране }
if NOT (IsWindow(FListBoxTip.Handle) and
IsWindowVisible(FListBoxTip.Handle) and
(StrComp(PChar(FListBoxTip.Caption),PChar(ItemText)) = 0)) then begin
AdjustHintRect (ItemRect, ItemText);
FListBoxTip.ActivateHint(ItemRect, ItemText);
SetWindowPos(FListBoxTip.Handle,HWND_TOPMOST,ItemRect.Left,ItemRect.Top,FListBoxTip.Width,
FListBoxTip.Height,SWP_NOACTIVATE);
end;

Более того, данный компонент можно сделать визуальным, добавив (выделено жирным)

write SetHorizontalExtent default -1;
{/16.04.2002}
end;

procedure Register;

implementation
uses SysUtils;

procedure Register;
begin
RegisterComponents('Samples',[THSHintComboBox]);
end;

function RectWidth(R : TRect) : Integer;
begin
Result := R.Right - R.Left;
end;


Текст компонента полностью будет выглядеть так:

{ Наследник TComboBox, показывающий Hint для строки в ListBox'овой части, не видимой целиком. Автор: Игорь Шевченко Дата создания: 13.04.2002 Ограничения: Компонент проверялся при работе с значением Style: csDropDown, csDropDownList. при остальных значениях работа не гарантируется :-) Компонент не тестировался в режиме design-time. История изменений: 16.04.2002 Исправлено поведение при закрытии, когда показан hint и ComboBox закрывается по клавише Enter, Escape или F4. Теперь hint убирается. Добавлено свойство HorizontalExtent, позволяющее устанавливать горизонтальный Scrollbar в списке ComboBox'a. По умолчанию свойство имеет значение -1, что запрещает установку горизонтального ScrollBar'а. } unit HSHintComboBox; interface uses Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls, AppEvnts; type TListBoxTip = class(THintWindow) end; TShowComboToolTipEvent = procedure (Sender : TObject; const ToolTipText : String; var HideToolTip : Boolean) of object; THSHintComboBox = class(TComboBox) // THSHintComboBox = class(TComponent) private FListBoxTip : TListBoxTip; FListHandle : HWND; FListWndProcInstance : TFarProc; FOldListWndProc : TFarProc; FOnListMouseMove: TMouseMoveEvent; FOnShowComboToolTip: TShowComboToolTipEvent; FShowToolTips: Boolean; FHorizontalExtent: Integer; procedure ListWndProc (var Message : TMessage); function ListBoxItemAtPos (I : Integer) : String; function ListBoxItemRectAtPos (I : Integer; AText : String) : TRect; procedure SetShowToolTips(const Value: Boolean); procedure SetHorizontalExtent(const Value: Integer); protected procedure DoListMouseMove (Shift: TShiftState; X, Y: Integer); dynamic; procedure DoShowComboToolTip (const ToolTipText : String; var HideToolTip : Boolean); dynamic; procedure WndProc (var Message: TMessage); override; {16.04.2002} procedure CreateParams (var Params : TCreateParams); override; procedure CreateWnd; override; {/16.04.2002} public constructor Create (AOwner : TComponent); override; destructor Destroy; override; { Handle окна ListBox'а, являющегося частью ComboBox'a } property HSListHandle : HWND read FListHandle; { Показывать ли Hint для строк, не видимых целиком в ListBox'е } property ShowToolTips : Boolean read FShowToolTips write SetShowToolTips default true; { Событие при движении мыши по ListBox'у. Так как ListBox захватывает (Captured) мышь, то координаты курсора в этом событии могут быть за пределами клентской части ListBox'а } property OnListMouseMove : TMouseMoveEvent read FOnListMouseMove write FOnListMouseMove; { Событие при показе Hint'а для ListBox'а. Установив HideHint в True, можно запретить показ конкретного Hint'а } property OnShowComboToolTip : TShowComboToolTipEvent read FOnShowComboToolTip write FOnShowComboToolTip; {16.04.2002} property HorizontalExtent : Integer read FHorizontalExtent write SetHorizontalExtent default -1; {/16.04.2002} end; procedure Register; implementation uses SysUtils; procedure Register; begin RegisterComponents('Samples',[THSHintComboBox]); end; function RectWidth(R : TRect) : Integer; begin Result := R.Right - R.Left; end; function RectHeight(R : TRect) : Integer; begin Result := R.Bottom - R.Top; end; { THSHintComboBox } constructor THSHintComboBox.Create(AOwner: TComponent); begin inherited; FListBoxTip := TListBoxTip.Create(Self); FListBoxTip.Color := clInfoBk; FListWndProcInstance := MakeObjectInstance(ListWndProc); FShowToolTips := true; FHorizontalExtent := -1; end; destructor THSHintComboBox.Destroy; begin if (FListHandle <> 0) AND IsWindow(FListHandle) then SetWindowLong(FListHandle, GWL_WNDPROC, LongInt(FOldListWndProc)); FreeObjectInstance(FListWndProcInstance); inherited; end; procedure THSHintComboBox.DoShowComboToolTip(const ToolTipText: String; var HideToolTip : Boolean); begin if Assigned(FOnShowComboToolTip) then FOnShowComboToolTip (Self, ToolTipText, HideToolTip); end; procedure THSHintComboBox.DoListMouseMove(Shift: TShiftState; X, Y: Integer); procedure AdjustHintRect (var R : TRect; const AHintStr : String); var DC : HDC; OldFont : HFONT; TextSize : SIZE; begin DC := GetDC (HWND_DESKTOP); try OldFont := SelectObject(DC, Screen.HintFont.Handle); try if (NOT GetTextExtentPoint32(DC, PChar(AHintStr), StrLen(PChar(AHintStr)), TextSize)) then RaiseLastWin32Error; Inc(TextSize.cx, 6); Inc(TextSize.cy, 2); R.Left := R.Left + 20; R.Top := R.Top + 15; if RectWidth® < TextSize.cx then R.Right := R.Left + TextSize.cx; if RectHeight® < TextSize.cy then R.Bottom := R.Top + TextSize.cy; finally SelectObject(DC, OldFont); end; finally ReleaseDC (HWND_DESKTOP, DC); end; end; var R, ItemRect : TRect; I : Integer; ItemText : String; HideToolTip : Boolean; begin HideToolTip := True; { По умолчанию выключать Hint } if FShowToolTips then begin Windows.GetClientRect(FListHandle, R); { X и Y являются координатами клиента (в данном случае, ListBox } if PtInRect(R, Point(X,Y)) AND (Shift = []) then begin { Определим, помещается ли текущая строка целиком в область ListBox } I := SendMessage(FListHandle, LB_ITEMFROMPOINT, 0, MakeLParam(X,Y)); if HiWord(I) <> 0 then I := -1; if I <> -1 then begin ItemText := ListBoxItemAtPos(I); ItemRect := ListBoxItemRectAtPos(I, ItemText); if RectWidth(ItemRect) > RectWidth® then begin { Надо показывать Hint, так как строка не помещается целиком в клиентскую область ListBox } Windows.ClientToScreen(FListHandle, ItemRect.TopLeft); Windows.ClientToScreen(FListHandle, ItemRect.BottomRight); Dec(ItemRect.Left, 3); Inc(ItemRect.Right, 6); HideToolTip := false; { Не надо гасить hint } DoShowComboToolTip (ItemText, HideToolTip); { Для возможности отображения строки Hint дополнительно в другом месте или запрета конкретного Hint'а} {16.04.2002} if NOT HideToolTip then { Если двигаться мышью в горизонтальном направлении на элементе, для которого должен показываться Hint, то ActivateHint не стоит вызывать, если Hint уже уже на экране } if NOT (IsWindow(FListBoxTip.Handle) and IsWindowVisible(FListBoxTip.Handle) and (StrComp(PChar(FListBoxTip.Caption),PChar(ItemText)) = 0)) then begin AdjustHintRect (ItemRect, ItemText); FListBoxTip.ActivateHint(ItemRect, ItemText); SetWindowPos(FListBoxTip.Handle,HWND_TOPMOST,ItemRect.Left,ItemRect.Top,FListBoxTip.Width, FListBoxTip.Height,SWP_NOACTIVATE); end; {/16.04.2002} end; end; end; end; if HideToolTip then FListBoxTip.ReleaseHandle; { Не надо показывать Hint, если мышь за пределами ListBox или строка видна целиком } { Если кому-то вздумается следить за перемещениями мыши в области ListBox. Я при отладке использовал это событие для отображения координат мыши } if Assigned(FOnListMouseMove) then FOnListMouseMove(Self, Shift, X, Y); end; function THSHintComboBox.ListBoxItemAtPos(I: Integer): String; var L : Integer; begin if I <> -1 then begin L := SendMessage(FListHandle, LB_GETTEXTLEN, I, 0); SetLength(Result, L+1); { +1 на нулевой символ в конце строки } SendMessage(FListHandle, LB_GETTEXT, I, Integer(PChar(Result))); end else Result := ''; end; function THSHintComboBox.ListBoxItemRectAtPos(I: Integer; AText: String): TRect; var DC : HDC; OldFont : HFONT; begin Result := Rect(0, 0, 0, 0); if (I <> -1) AND (SendMessage(FListHandle, LB_GETITEMRECT, I, Integer(@Result)) <> LB_ERR) then begin DC := GetDC(FListHandle); try OldFont := SelectObject(DC, Font.Handle); try DrawText(DC, PChar(AText), -1, Result, DT_CALCRECT); finally SelectObject(DC, OldFont); end; finally ReleaseDC(FListHandle, DC); end; end; end; procedure THSHintComboBox.ListWndProc(var Message: TMessage); begin case Message.Msg of WM_MOUSEMOVE: with TWMMouseMove(Message) do DoListMouseMove(KeysToShiftState(Keys), XPos, YPos); {16.04.2002} { Как выяснилось, при нажатии Esc или Enter на выбранном элементе, который показывает Hint, ComboBox закрывается, а Hint остается. :-( Сообщение SHOWWINDOW с WPARAM=0 гарантировано выдается, когда закрывается окно, так что это место можно использовать для гашения Hint'a } WM_SHOWWINDOW: if Message.WParam = 0 then FListBoxTip.ReleaseHandle(); {/16.04.2002} end; with Message do Result := CallWindowProc(FOldListWndProc, FListHandle, Msg, WParam, LParam); end; procedure THSHintComboBox.SetShowToolTips(const Value: Boolean); begin FShowToolTips := Value; end; procedure THSHintComboBox.WndProc(var Message: TMessage); begin if (Message.Msg = WM_CTLCOLORLISTBOX) AND (FListHandle = 0) then begin FListHandle := HWND(Message.LParam); FOldListWndProc := Pointer(GetWindowLong(FListHandle, GWL_WNDPROC)); SetWindowLong(FListHandle, GWL_WNDPROC, LongInt(FListWndProcInstance)); end; inherited; end; {16.04.2002} procedure THSHintComboBox.CreateParams(var Params: TCreateParams); begin inherited; if FHorizontalExtent <> -1 then with Params do Style := Style OR WS_HSCROLL; end; procedure THSHintComboBox.SetHorizontalExtent(const Value: Integer); begin if (FHorizontalExtent <> Value) then begin FHorizontalExtent := Value; if NOT (csLoading in ComponentState) then RecreateWnd(); end; end; procedure THSHintComboBox.CreateWnd; begin inherited; if FHorizontalExtent <> -1 then Perform(CB_SETHORIZONTALEXTENT, FHorizontalExtent, 0); end; {/16.04.2002} end.

Цитата --Ins-- @ 27.02.08, 14:29

Для кучи, выложу свое решение, написанное некогда давно, также под влиянием кода Игоря Шевченко. Идея только несколько отличается - вместо потомка TComboBox - неоконный компонент, который нужно просто бросить на любую форму, и все ComboBox-ы начнут показывать Hint

Хотелось бы доработать этот компонент, исправить баги и разобраться в одной фишке. Хороший ведь компонент, полезный:

Во-первых, чтобы он реально не позволял себя многократно использовать и сек все попытки наложить больше одного компонента на форму, нужно удалить из Деструктора строку "GlobalPatch:=nil;"

Во-вторых он поддерживает только Хинты не более чем в 128 символов, а иначе валится нафиг в AccessViolation. Но это поправимо.

Самое главное, что в функции ShowHint вызовом SetWindowPos мочиться наглухо способность ActivateHint выравнивать влево длинные Хинты, если они вылазят за пределы экрана (правую часть). Если SetWindowPos не использовать, тогда первый всплывающий Хинт оказывается под списком (что собственно SetWindowPos и фиксит). Короче замкнтуый круг. В компоненте Шевченко, все тоже самое.

Предложения по фиксу принимаются. Хочется всего сразу.


PS.
И попутно вопрос: в той же функции ShowHint есть вызов CalcHintRect(1000,Text,nil), где "1000" это количество пикселей, и якобы если текст хинта в эти пиксели не влезает, он будет перенесен на вторую строку. Но на практике этого не происходит, почему?

Сообщение отредактировано: POP - 11.04.11, 19:23

Ну и я до кучи выложу вариант, что делал когдато. Очень компактный.

type
  TComboBox = class(StdCtrls.TComboBox)
  private
    FListIndex: Integer;
    FHint: THintWindow;
  public
    procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); override;
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  end;
 
  TForm1 = class(TForm)
    ComboBox1: TComboBox;
    XPManifest1: TXPManifest;
  private
    { Private declarations }
  public
 
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
{ TComboBox }
 
procedure TComboBox.CNCommand(var Message: TWMCommand);
var Info: TComboBoxInfo;
begin
  inherited;
  case Message.NotifyCode of
    CBN_DROPDOWN:
      begin
        if (Style <> csSimple) then begin // хукаем список, предок хукает его только при стиле csSimple
          Info.cbSize := SizeOf(Info);
          if GetComboBoxInfo(Self.Handle,  Info) and (Info.hwndList <> 0) then begin
            FListHandle := Info.hwndList;
            FDefListProc := Pointer(GetWindowLong(FListHandle, GWL_WNDPROC));
            SetWindowLong(FListHandle, GWL_WNDPROC, Longint(FListInstance));
            FListIndex := -1;
            FHint := nil;
          end;
        end;
      end;
    CBN_CLOSEUP:  // убираем хук
      if (Style <> csSimple) and (FListHandle <> 0) then begin
        SetWindowLong(FListHandle, GWL_WNDPROC, Longint(FDefListProc));
        FreeAndNil(FHint);
      end;
  end;
end;
 
procedure TComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer);
var J, NewIndex: Integer;
    ItemRect, R: TRect;
    Pt: TPoint;
    DC: HDC;
    Size: TSize;
    OldFont: HFont;
begin
  inherited;
  if ComboWnd = FListHandle then
  with Message do
    case Msg of
      WM_MOUSEMOVE:
        begin
          NewIndex := -1;
            // получаем текущий индекс под мышкой
          for J := 0 to SendMessage(FListHandle, LB_GETCOUNT , 0, 0)-1 do begin
            SendMessage(FListHandle, LB_GETITEMRECT, J, Cardinal(@ItemRect));
            Pt := Mouse.CursorPos;
            MapWindowPoints(0, FListHandle, Pt, 1);
            if PtInRect(ItemRect, Pt) then begin
              NewIndex := J;
              Break;
            end;
          end;
             if NewIndex < 0 then begin
               FreeAndNil(FHint);
               FListIndex := -1;
             end
             else   // если индекс поменялся
             if J <> FListIndex then begin
               FreeAndNil(FHint);
               FListIndex := NewIndex;
                  // проверяем вмещается ли текст
               DC := GetDC(FListHandle);
               OldFont := SelectObject(DC, Screen.HintFont.Handle);
               GetTextExtentPoint32(DC, PChar(Items[J]), Length(Items[J]), Size);
               SelectObject(DC, OldFont);
               ReleaseDC(FListHandle, DC);
                   // показываем подсказку
               if Size.cx > (ItemRect.Right-ItemRect.Left) then begin
                 FreeAndNil(FHint);
                 FHint := THintWindow.Create(Self);
                 R := FHint.CalcHintRect(Screen.Width, Items[J], nil);
                     MapWindowPoints(FListHandle, 0, ItemRect, 2);
                     ItemRect.Right := ItemRect.Left + (R.Right-R.Left);
                     ItemRect.Bottom := ItemRect.Top + (R.Bottom-R.Top);
                 FHint.ActivateHint(ItemRect, Items[J]);
                     SetWindowPos(FHint.Handle,HWND_TOPMOST,0,0,0,0,SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
               end;
             end;
        end; // WM_MOUSEMOVE
    end;
end;

SourceUser

Вот эта строка SetWindowPos(FHint.Handle,HWND_TOPMOST,0,0,0,0,SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE); , и есть решение проблемы с вырваниванием Хинта, если он вылез за пределы экрана.

POP - Неа.
Глянь в исходниках метод

procedure THintWindow.ActivateHint(Rect: TRect; const AHint: string);

всё выравнивание делается там.

А эта строчка просто ложит нашу подсказку над системным ComboLBox, ибо он иногда побеждает и вылазин наверх.

Цитата SourceUser @ 12.04.11, 19:47

А эта строчка просто ложит нашу подсказку над системным ComboLBox, ибо он иногда побеждает и вылазин наверх.

Я знаю.. значит она просто не портит то что делается в ActivateHint, как это происходит в компоненте Шевченко и --Ins--

Не могу справиться с одной проблемой:

Если указать статический буфер для Хинта, то будет AccessViolation если Хинт вылезет за пределы статического массива, если указать много, то зря память расходоваться будет. Хочу массив заменить обычной строкой (она же типа динамический массив). Почему не работает вот так:

procedure TComboBoxPatch.AdjustHint(Wnd: HWND; Point: TPoint);
var
HintPt: TPoint;
ItemRect: TRect;
Item, TextWidth: Integer;
// buf: array[0..127] of Char;  - Было.
buf: string;   // Стало
 
begin
 Windows.ScreenToClient(Wnd,Point);
 Item:=SendMessage(Wnd,LB_ITEMFROMPOINT,0,lParam(PointToSmallPoint(Point)));
 if (Item and $00010000 <> $00010000) and (Item <> FHintIndex) then
 begin
  FHintIndex:=Item;
//  SendMessage(Wnd,LB_GETTEXT,Item,Integer(@buf));   - Было
  SendMessage(Wnd,LB_GETTEXT,Item,Integer(PChar(buf)));  // Стало
  SendMessage(Wnd,LB_GETITEMRECT,Item,Integer(@ItemRect));
  FCanvas.Handle:=GetDC(Wnd);
  TextWidth:=FCanvas.TextWidth(buf);
  ReleaseDC(Wnd,FCanvas.Handle);
  FCanvas.Handle:=0;
  if FAlwaysShowHint or ((not FAlwaysShowHint) and (ItemRect.Right < TextWidth)) then
  begin
   HintPt:=ItemRect.TopLeft;
   Windows.ClientToScreen(Wnd,HintPt);
   ShowHint(HintPt,buf);
  end
  else
  begin
   HideHint;
  end;
 end
 else
 begin
  if Item < 0 then HideHint;
 end;
end;

Пометил как Было и как Стало, две строчки заменил.

Виснет при показе Хинта.

В первом случае видать буфер маленький, юзай LB_GETTEXTLEN, а во втором случае у тебя же строка пустая.
Делай как то так.

var
  Buf: PChar;
begin
  GetMem(Buf, SendMessage(Wnd, LB_GETTEXTLEN, 0,0));
 
var
  Buf: String;
begin
  SetLength(Buf, SendMessage(Wnd, LB_GETTEXTLEN, 0,0))

Цитата SourceUser @ 13.04.11, 13:09

В первом случае видать буфер маленький, юзай LB_GETTEXTLEN, а во втором случае у тебя же строка пустая.

Да я в итоге просто сам динамический массив Array of Char сделал и выделал под него память с использованием LB_GETTEXTLEN.

По-идее под строки Delphi сама память автоматом все выделяет, самому не надо ничего делать.. ан не работает в этом случае.


PS.
Дак почему CalcHintRect(1000,Text,nil) не работает?

В описании написано, что по достижении 1000 пикселов, Хинт должен переноситься на новую строку, но ничего не переноситься.

Сообщение отредактировано: POP - 13.04.11, 14:28