Softwarová Záchrana 3/Softwarova-zachrana-3.bin/ArsClip/source.zip/UnitMyPopup.pas

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.