home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Softwarová Záchrana 3
/
Softwarova-zachrana-3.bin
/
ArsClip
/
source.zip
/
UnitMyPopup.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2004-02-02
|
6KB
|
233 lines
unit UnitMyPopup;
{
Purpose:
Show a tooltip when the mouse hovers a menu item
NOTES:
Horrible, nasty, complicated, and no frikin fun to make
Updates:
Detect complex items
-----------
Separated Tooltip into a generic class for use elsewhere
Updated TTooltipWindow for displaying Unicode
}
interface
uses Windows, CommCtrl, Messages, Controls, Classes, Menus, Forms,
UnitClipQueue, ExtCtrls {TTimer}, UnitTWideChar, UnitFrmDummyUnicodeTooltip;
type TSubClasser = class(TObject)
private
FNewProc, FDefProc: Pointer;
h : HWND;
public
procedure SubclassHook(WinHandle : THandle; WndProc : TWndMethod);
procedure SubclassUnhook;
function GetOldWndProc : Pointer;
end;
type TMyPopupMenu = class(TPopupMenu)
private
LastHint : string;
tim : TTimer;
LastCursorPos : TPoint;
PopupX, PopupY : integer;
r : TRect;
TooltipWindow : TTooltipWindow;
Sub : TSubClasser;
function GetPopupHint(h: HMENU; Menuflag : integer): string;
procedure MyOnTimer(Sender: TObject);
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure Popup(X, Y: Integer); override;
procedure WndProc(var Msg: TMessage);
end;
{////////////////////}
{//}implementation{//}
{////////////////////}
uses Dialogs, SysUtils, StrUtils, UnitFrmMainPopup, Graphics{for color}, UnitMisc,
Types, UnitFrmPermanentNew, UnitFrmClipboardManager;
{ TSubClasser }
function TSubClasser.GetOldWndProc: Pointer;
begin
result := FDefProc;
end;
procedure TSubClasser.SubclassHook(WinHandle : THandle; WndProc : TWndMethod);
begin
Windows.SetLastError(ERROR_SUCCESS);
self.h := WinHandle;
FNewProc := Classes.MakeObjectInstance(WndProc);
FDefProc := Pointer(Windows.SetWindowLong(h, GWL_WNDPROC, LongInt(FNewProc)));
end;
procedure TSubClasser.SubclassUnhook;
begin
Windows.SetLastError(ERROR_SUCCESS);
if (h <> 0) then begin
Windows.SetWindowLong(h, GWL_WNDPROC, LongInt(FDefProc));
Classes.FreeObjectInstance(FNewProc);
FNewProc := nil
end;
end;
{ TMyPopupMenu }
constructor TMyPopupMenu.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
sub := TSubClasser.Create;
sub.SubclassHook(Menus.PopupList.Window, WndProc);
TooltipWindow := TTooltipWindow.Create;
tim := TTimer.Create(self);
tim.OnTimer := MyOnTimer;
tim.Enabled := false;
tim.Interval := Application.HintPause;
end;
destructor TMyPopupMenu.Destroy;
begin
sub.SubclassUnhook;
MyFree(sub);
MyFree(TooltipWindow);
MyFree(tim);
inherited Destroy;
end;
procedure TMyPopupMenu.MyOnTimer(Sender: TObject);
var CursorPos : TPoint;
ci : TClipItem;
begin
Windows.GetCursorPos(CursorPos);
if (Abs(CursorPos.X - self.LastCursorPos.X) > 10) or
(Abs(CursorPos.Y - self.LastCursorPos.Y) > 10) then begin
LastHint := '';
EXIT;
end;
inc(CursorPos.x, 10);
inc(cursorPos.y, 20);
if (FrmPermanent.IsComplexItem(LastHint)) then begin
ci := FrmPermanent.GetComplexItem(LastHint);
if (ci.GetFormat = Windows.CF_UNICODETEXT) then begin
TooltipWindow.ShowTooltip(ci, CursorPos);
end else begin
TooltipWindow.ShowTooltip('[Clip format: ' + ci.GetFormatName + ']',
CursorPos);
end;
MyFree(ci);
end else begin
TooltipWindow.ShowTooltip(LastHint, CursorPos);
end;
LastHint := '';
end;
procedure TMyPopupMenu.Popup(X, Y: Integer);
begin
PopupX := x;
PopupY := y;
inherited Popup(x,y);
LastHint := '';
end;
procedure TMyPopupMenu.WndProc(var Msg: TMessage);
var s : string;
h : word;
begin
Windows.SetLastError(ERROR_SUCCESS);
//
// Save info about the newly selected item,
// Start the timer when the mouse idles on an item
// Don't break the message chain.
//
try
case Msg.msg of
WM_MENUSELECT: begin
TooltipWindow.CloseTooltip;
tim.Enabled := false;
LastHint := '';
h := TWMMENUSELECT(msg).IDItem;
// this stops the "all items" sub from displaying a tooltip
if (TWMMENUSELECT(msg).MenuFlag and MF_POPUP) = 0 then begin
s := self.GetPopupHint(h, TWMMENUSELECT(msg).MenuFlag);
end;
if s <> '' then LastHint := s;
end;
WM_ENTERIDLE: begin
tim.Enabled := true;
Windows.GetCursorPos(LastCursorPos);
end;
WM_NCPAINT: begin
Windows.GetRgnBox(TWMNCPAINT(msg).RGN, self.r);
end;
end;
msg.Result := Windows.CallWindowProc(sub.GetOldWndProc, self.Handle, Msg.Msg, Msg.WParam, Msg.LParam);
except
Application.HandleException(Self);
end;
end;
function TMyPopupMenu.GetPopupHint(h: HMENU; Menuflag : integer): string;
var m : TMenuItem;
begin
result := '';
// A menu with a subitem would find the wrong item if this
// wasn't done
if ((MenuFlag and MF_POPUP) <> 0) then begin
m := self.FindItem(h, fkHandle);
end else begin
m := self.FindItem(h, fkCommand);
end;
if (m <> nil) then begin
result := m.Hint;
end;
end;
end.