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

Pascal/Delphi Source File | 2004-10-16 | 22KB | 725 lines

unit UnitFrmDummyUnicodePopup;
{
    Purpose:
        Wrap all the logic needed to to create a low level API popup
        menu that has Unicode text and gather the data needed
        to show a Unicode Tooltip hint (see FrmDummyUnicodeTooltip

    Updates:

        Code completely re-written and simplified - FrmMainPopup's popup
        menu it traversed and duplicated instead of creating is from scratch

        -------------

        Show tooltip for "All Items..." hover
        ------------------------
        "All Items..." support
        ------------------------

        "Number of characters to show for each item" required a restart to
        work with the unicode popup

        ----------------------
        Let Permanent Items grow as large as they want
        "Beep" on accelerator key

}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StrUtils, INIFIles, Math, Menus,

  UnitClipQueue, UnitFrmMainPopup, UnitTWideChar, UnitMisc,
  UnitOtherQueue, UnitKeyboardQuery, UnitFrmDummyUnicodeTooltip, Contnrs,
  StdCtrls;

type
  TFrmDummyUnicodePopup = class(TForm)
    tim: TTimer;
    Label1: TLabel;
    procedure timTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    LastCursorPos : TPoint;
    LastHint : string;
    LastClipItem : TClipItem;
    CurrentClipboard : TClipItem;
    KeyToItemID : THashedStringList;
    VisibleCharCount : integer;
    Tooltip : TTooltipWindow;
    TimeFiring : boolean;

    SubMenuItemList : THashedStringList;
    SubObjectList : TObjectList;
    mi : TMenuITem;

    function ItemIDToMenuItem(itemID : integer) : TMenuItem;
  public
    { Public declarations }

    procedure PopulatePopupUnicode(var M : TMenuItem; parent : HMENU);
    procedure ShowPopup(x,y : integer; inpopup : TPopupMenu);

    procedure WMDrawItem(var Msg: TWMDrawItem); message WM_DRAWITEM;
    procedure WMMeasureItem(var Msg: TWMMeasureItem); message WM_MEASUREITEM;
    procedure WMCommand(var Msg : TWMCommand); message WM_COMMAND;
    procedure WMMenuChar(var Msg : TWMMenuChar); message WM_MENUCHAR;
    procedure WMMenuSelect(var Msg : TWMMenuSelect); message WM_MENUSELECT;
    procedure WMEnterIdle(var Msg : TWMEnterIdle); message WM_ENTERIDLE;
  end;

var
  FrmDummyUnicodePopup: TFrmDummyUnicodePopup;
{////////////////////}
{//}implementation{//}
{////////////////////}
{$R *.dfm}


uses UnitFrmPermanentNew, UnitFrmConfig, UnitFrmSysTrayMenu, UnitPaste;
const PU_LAST_TEXT = 'Las&t: ';
      PU_CURRENT_TEXT = 'Cu&rrent: ';


procedure TFrmDummyUnicodePopup.FormCreate(Sender: TObject);
begin
    KeyToItemID := THashedStringList.Create;
    CurrentClipboard := TClipItem.Create;
    LastClipItem := TClipItem.Create;
    //Popup := TPopupMenu.Create(self);
    Tooltip := TTooltipWindow.Create;


    self.SubMenuItemList := THashedStringList.Create;
    SubObjectList := TObjectList.Create;
    SubObjectList.OwnsObjects := false;

    mi := TMenuItem.Create(self);
end;

procedure TFrmDummyUnicodePopup.FormDestroy(Sender: TObject);
begin

    SubMenuItemList.Free;
    SubObjectList.Free;

    mi.Free;
end;


procedure TFrmDummyUnicodePopup.ShowPopup(x, y: integer;  inpopup: TPopupMenu);
var p : HMENU;
    m : TMenuItem;
begin
    Windows.SetLastError(ERROR_SUCCESS);
    self.VisibleCharCount := FrmConfig.udCharacters.Position;


    // add new items
    p := Windows.CreatePopupMenu;
    m := inpopup.items;
    self.PopulatePopupUnicode(m, p);
    self.CurrentClipboard.GetClipboardItem(0);

    // show it
    Windows.TrackPopupMenu(p,
        TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_LEFTALIGN,
        x, y, 0,
        self.Handle, nil);

    Windows.DrawMenuBar(p);
    // clean up
    while Windows.GetMenuItemCount(p) > 0 do begin
        Windows.DeleteMenu(p,0, MF_BYPOSITION);
    end;

end;

// Call Order
//--------------
// Populate -> Measure Item -> Draw Item
// Some user event trigers
// (MenuSelect, EnterIdle, Command)

procedure TFrmDummyUnicodePopup.PopulatePopupUnicode(var M : TMenuItem; parent : HMENU);
    procedure TraverseMenuItems(var m : TMenuItem; parent : HMENU; level : integer = 0) ;
    var i : integer;
        menu : HMENU;
        m2 : TMenuItem;
        s : string;
    begin
        if (m.count = 0) then begin
            if (m.IsLine) then begin
                Windows.AppendMenu(parent, MF_SEPARATOR, 0, nil);
            end else begin
                i := SubObjectList.Add(m);
                if (m.Checked) then begin
                    case m.Tag of
                    Integer(PASTE_CTRL_V):    s := '&1 CTRL+V';
                    Integer(PASTE_SHIFT_INS): s := '&2 SHIFT+INS';
                    Integer(PASTE_MIMIC):     s := '&3 Mimic Typing';
                    Integer(PASTE_CLIPBOARD): s := '&4 Clipboard Only';
                    Integer(PASTE_DEFAULT):   s := '&5 Default';
                    end;

                    Windows.AppendMenu(parent,
                        MF_ENABLED or MF_BYCOMMAND or MF_CHECKED,
                        i, PChar(s));
                end else begin
                    Windows.AppendMenu(parent, MF_OWNERDRAW, i, nil);
                end;
            end;
        end else begin
            if (level <> 0) then begin
                menu := Windows.CreatePopupMenu;
            end;
            for i := 0 to (m.Count - 1) do begin
                m2 := m.Items[i];
                if (level <> 0) then begin
                    TraverseMenuItems(m2, menu, level + 1);
                end else begin
                    TraverseMenuItems(m2, parent, level + 1);
                end;
            end;
            if (level <> 0) then begin
                i := SubObjectList.Add(m);
                SubMenuItemList.Values[IntToStr(menu)] := IntToStr(i);
                Windows.AppendMenu(parent, MF_OWNERDRAW or MF_POPUP, menu, nil);
            end;
        end;
    end;
begin
    SubObjectList.Clear;
    SubMenuItemList.clear;
    TraverseMenuItems(m, parent, 0);
end;


{
//
// These 2 messages are just do draw the damn popu
//
}

procedure TFrmDummyUnicodePopup.WMMeasureItem(var Msg: TWMMeasureItem);
var id : Cardinal;
    s : string;
    sz : TSize;
    procedure GetTextSizeOf( s : string );
    begin
        Windows.GetTextExtentPoint32(self.Canvas.Handle, PChar(s),
        min(length(s), VisibleCharCount),
        sz);
        msg.MeasureItemStruct^.itemWidth := max(sz.cx + loword(GetMenuCheckMarkDimensions),20);
        msg.MeasureItemStruct^.itemHeight := max(sz.cy+2, 6);
    end;
    procedure GetTextSizeOfNoLimit( s : string );
    begin
        Windows.GetTextExtentPoint32(self.Canvas.Handle, PChar(s),
        length(s),
        sz);
        msg.MeasureItemStruct^.itemWidth := max(sz.cx + loword(GetMenuCheckMarkDimensions),20);
        msg.MeasureItemStruct^.itemHeight := max(sz.cy+2, 6);
    end;

var
    mi2 : TMenuItem;
begin
    Windows.SetLastError(ERROR_SUCCESS);
    id := msg.MeasureItemStruct^.itemID;

    //
    // Basically, use the longest text item to gauge the width of the popup
    // At a minimum the height is the 2 pixels above the size of an icon
    //
    mi2 := self.ItemIDToMenuItem(id);
    if mi2 <> nil then begin
        s := mi2.Caption;
    end;

    if (s <> '') then begin
        GetTextSizeOf(s);
    end else begin
        s := self.CurrentClipboard.GetAsText;
        if length(s) < length(FrmMainPopup.GetLastStringSelected) then begin
            GetTextSizeOf(PU_LAST_TEXT + FrmMainPopup.GetTrimmedItem(FrmMainPopup.GetLastStringSelected));
        end else begin
            GetTextSizeOf(PU_LAST_TEXT + FrmMainPopup.GetTrimmedItem(s));
        end;
    end;

    //TODO: Unsure how to handle this, swapping Perm Items back and
    // forth will be way to costly

    msg.MeasureItemStruct^.itemWidth := max(msg.MeasureItemStruct^.itemWidth + 8, 100);
end;

procedure TFrmDummyUnicodePopup.WMDrawItem(var Msg: TWMDrawItem);
var
    i  : cardinal;
    ci : TClipItem;
    tc, bc : cardinal;
    dc : integer;
CONST ICON_SPACER = 20;
    //
    // Since it's owner drawns, I have to know what &x character related
    // to what ItemID
    //
    procedure UpdateAccessKeys(s : string);
    var amp : integer;
    begin
        amp := pos('&', s);
        if (amp <> 0) then begin
            inc(amp);
            KeyToItemID.Values[lowercase(s[amp])] := IntToStr(msg.DrawItemStruct^.itemID);
        end;
    end;
    procedure DrawTextAndBitmap(bm : TBitmap; s : string);
    var ico : TIcon;
        il : TImageList;
        r : TRect;
    begin
        with msg.DrawItemStruct^ do begin
        UpdateAccessKeys(s);

        r.Top := rcItem.Top;
        r.Bottom := rcItem.Bottom;
        r.Left := rcItem.Left + ICON_SPACER;
        r.Right := rcItem.Right;

        DrawText(hdc, PChar(s), length(s),
            r, DT_VCENTER);

        if (bm <> nil) and ((bm.Width and bm.Height) <> 0) then begin
            ico := TIcon.Create;
            il := TImageList.CreateSize(bm.Width, bm.Height);
            il.AddMasked(bm, bm.TransparentColor);
            il.GetIcon(0, ico);
            il.Free;
            if (ico.Handle <> 0) then begin
                DrawIconEx(hdc,
                        rcItem.left,
                        rcItem.top,
                        ico.Handle,
                        16,16, 0, 0, DI_NORMAL);
            end;
            ico.Free;
        end;
        end;
    end;
    procedure DrawTextAndImage(ti : TImage; s : string);
    begin
        if ti = nil then begin
            DrawTextAndBitmap(nil, s);
        end else begin
            DrawTextAndBitmap(ti.Picture.Bitmap, s);
        end;
    end;

    procedure DrawUnicodeAndIcon(h : HICON; ci : TClipItem; prefix : string);
    var wc : TWideChar;
        r : TRect;
        sz : TSize;
    begin
        UpdateAccessKeys(prefix);

        wc := TWideChar.Create;
        wc.Append(prefix);
        wc.Append(ci.GetHandle, ci.GetDataSize);
        wc.Replace(WideChar($9), WideChar($3)); // replace these whitespace
        wc.Replace(WideChar(#13),WideChar($3)); // characters with "squares"
        wc.Replace(WideChar(#10),WideChar($3)); //

        if (ci.GetDataSize / 2) > VisibleCharCount then begin
            wc.LeftStr(self.VisibleCharCount);
            wc.Append('...');
        end;

        Windows.GetTextExtentPoint32W(self.Canvas.Handle, wc.Memory,
            wc.StrLength,sz);


        with msg.DrawItemStruct^ do begin
        r.Top := rcItem.Top;
        r.Bottom := r.top + sz.cy;
        r.Left := rcItem.Left + ICON_SPACER;
        r.Right := rcItem.Right;
        // trim the rectangle so the next line of text won't be
        // partially visible

        DrawTextW(hdc, PWideChar(wc.Memory), wc.strlength - 1,
            r, DT_VCENTER );
        MyFree(wc);

        if (h <> 0) then begin
            DrawIconEx(hdc,
                rcItem.left, rcItem.top,
                h,
                16,16, 0, 0, DI_NORMAL);
        end;
        end;
    end;

    procedure DrawTextAndIcon(h : HICON; s : string); overload;
    var r : TRect;
    begin
        UpdateAccessKeys(s);

        with msg.DrawItemStruct^ do begin
        r.Top := rcItem.Top;
        r.Bottom := rcItem.Bottom;
        r.Left := rcItem.Left + ICON_SPACER;
        r.Right := rcItem.Right;

        DrawText(hdc, PChar(s), length(s),
            r, DT_VCENTER);

        if (h <> 0) then begin
            DrawIconEx(hdc,
                    rcItem.left, rcItem.top,
                    h, 16,16,
                    0, 0, DI_NORMAL);
        end;
        end;
    end;

    procedure DrawTextAndIcon(ci : TClipItem); overload;
    begin
        if (ci.GetFormat = CF_UNICODETEXT) then begin
            DrawUnicodeAndIcon(ci.CData.GetHICON, ci, '');
        end else begin
            DrawTextAndIcon(ci.CData.GetHICON, FrmMainPopup.GetTrimmedItem(ci.getastext));
        end;
    end;


var HB : HBRUSH;
    prefix : string;
    mi : TMenuItem;
    ni, ni2 : TNotifyEvent;
    h : HGDIOBJ;
    oldf, f : HFONT;
    name : string;
begin
    Windows.SetLastError(ERROR_SUCCESS);
    with msg.DrawItemStruct^ do begin
    dc := Windows.SaveDC(hDC);
    if (dc = 0) then begin
        UnitMisc.AppendLog('WMDrawItem: SaveDC failed - ', true);
        EXIT;
    end;
    //
    // Fill the entire background with a hilight or no higlight
    //



    name := self.Font.Name;


     f :=Createfont(
        self.Font.Height,0,0,0,0,0,0,0,Ansi_Charset,Out_Default_Precis,
        clip_Default_Precis,Draft_Quality,variable_Pitch OR ff_swiss,
        pchar(name)
     );

    oldf := Windows.SelectObject(hdc, f);


    if (itemState and ODS_SELECTED) = 0 then begin
        tc := Windows.SetTextColor(hDC, ColorToRGB(clMenuText));
        bc := Windows.SetBkColor(hDC, ColorToRGB(clMenu));
        hb := Windows.CreateSolidBrush(ColorToRGB(clMenu));
    end else begin
        tc := Windows.SetTextColor(hdc, ColorToRGB(clHighLightText));
        bc := Windows.SetBkColor(hdc, ColorToRGB(clHighLight));
        hb := Windows.CreateSolidBrush(ColorToRGB(clHighLight));
    end;
    if (hb <> 0) then begin
        Windows.FillRect(hdc, rcItem, hb);
        Windows.DeleteObject(hb);
    end;

    try
        mi := self.ItemIDToMenuItem(itemID);
        if (mi <> nil) then begin
            ni := mi.OnClick;
            ni2 := FrmMainPopup.MenuItemClickEvent;;
            if (@ni = @ni2) then begin
                i := ClipQueue.IndexOf(mi.hint);
                ci := ClipQueue.GetClipItem(i);

                if (FrmConfig.cbUseKeyboard.Checked) then begin
                    prefix := '&' + FrmMainPopup.GetAccelerator(i) + ': ';
                end;
                if (FrmConfig.cbShowTypes.Checked) then begin
                    prefix := prefix + UnitMisc.GetCliptypeSymbol(ci.GetFormat) + ' ';
                end;
                if (ci.GetFormat = Windows.CF_UNICODETEXT) then begin
                    DrawUnicodeAndIcon(ci.CData.GetHICON, ci, Prefix)
                end else begin
                    DrawTextAndIcon(ci.CData.GetHICON,prefix +
                        FrmMainPopup.GetTrimmedItem(ci.GetAsText));
                end;
            end else begin
                ni2 := FrmMainPopup.CurrentMenuItemClickEvent;
                if (@ni = @ni2) then begin
                    if (self.CurrentClipboard.GetFormat = CF_UNICODETEXT) then begin
                        DrawUnicodeAndIcon(0, self.CurrentClipboard, PU_CURRENT_TEXT);
                    end else begin
                        DrawTextAndImage(nil, PU_CURRENT_TEXT + LeftStr(self.CurrentClipboard.GetAsText, VisibleCharCount));
                    end;
                end else begin
                    DrawTextAndBitmap(mi.Bitmap, mi.caption);
                end;

            end;

        end;
    finally
        h := SelectObject(hdc, oldf);
        DeleteObject(h);

        Windows.SetTextColor(hdc, tc);
        Windows.SetBkColor(hdc, bc);
        Windows.RestoreDC(hdc, dc);


    end;
    end;
end;



//
// And Item was selected by keystroke, or by click
//
procedure TFrmDummyUnicodePopup.WMMenuChar(var Msg: TWMMenuChar);
var m : TWMCommand;
    s : string;

begin
    if (msg.MenuFlag and MF_POPUP) <> 0 then begin
        //
        // Wait until user releases keystrok
        // Translate key to ItemID
        // pass information WMCommand - as if it was clicked by a mouse
        //
        while KeyboardQuery.IsPressed(VkKeyScan(msg.user)) do begin
            Application.ProcessMessages;
        end;
        msg.Result := MakeLong(0, MNC_CLOSE);

        s := KeyToItemID.Values[lowercase(msg.User)];

        if (s <> '') then begin
            //
            // trigger the correct WMCommand event
            //
            Application.ProcessMessages;
            m.NotifyCode := 0;
            m.ItemID := StrToInt(s);
            m.Ctl := 0;
            self.WMCommand(m);
        end;
    end else begin
        inherited;
    end;
end;

procedure TFrmDummyUnicodePopup.WMCommand(var Msg: TWMCommand);
var
    itemID : integer;
    mi2 : TMenuItem;
    ni, ni2, ni3, ni4, ni5, ni6, ni7 : TNotifyEvent;
begin
    // Given an ItemID - carry out the selected action

    if (msg.NotifyCode = 0) then begin
        itemID := msg.ItemID;
        mi2 := self.ItemIDToMenuItem(itemID);
        if (mi2 <> nil) then begin

            // Some items expect the menu item passed back
            // Other items need this form's handle to set focus correctly

            ni := mi2.OnClick;
            ni2 := FrmMainPopup.MenuItemClickEvent;
            ni3 := FrmMainPopup.OtherItemClickEvent;
            ni4 := FrmMainPopup.PermanentMenuItemClickEvent;
            ni5 := FrmMainPopup.PermanentGroupItemClickEvent;
            ni6 := frmSysTrayMenu.SwitchPermFolder;
            ni7 := frmSysTrayMenu.MethodMenuItemClickEvent;
            if (@ni = @ni2) or (@ni = @ni3) or
               (@ni = @ni4) or (@ni = @ni5) or
               (@ni = @ni6) or (@ni = @ni7) then begin
                Mi2.OnClick(mi2);
            end else begin
                Mi2.OnClick(self);
            end;
        end;
    end else begin
        {dunno if this is needed}
        inherited;
    end;
end;




{
//
// These 3 messages control the menu popup
// Item is selected, Idle state occurs, then the time will fire the
// showtooltip event
}

procedure TFrmDummyUnicodePopup.WMEnterIdle(var Msg: TWMEnterIdle);
begin
    // use this position to show the tooltip
    tim.Interval := Application.HintPause;
    tim.Enabled := true;
    Windows.GetCursorPos(LastCursorPos);
end;

procedure TFrmDummyUnicodePopup.timTimer(Sender: TObject);
var ci : TClipItem;
begin
    self.TimeFiring  := true;

    tim.Enabled := false;

    if (self.LastClipItem = nil) and (self.LastHint = '') then begin
        EXIT;
    end;

    inc(self.LastCursorPos.X, 20);
    inc(self.LastCursorPos.Y, 10);

    UnitMisc.AppendLog('Showing Tooltip hint');
    if (self.LastClipItem <> nil) then begin
        Tooltip.ShowTooltip(self.LastClipITem, self.LastCursorPos);
        //FrmDummyUnicodeTooltip.ShowTooltip(self.LastClipITem, self.LastCursorPos);
    end else begin
        if (FrmPermanent.IsComplexItem(self.LastHint)) then begin
            ci := FrmPermanent.GetComplexItem(self.LastHint);
            if (ci.GetFormat = Windows.CF_UNICODETEXT) then begin
                Tooltip.ShowTooltip(ci, self.LastCursorPos);
            end else begin
                Tooltip.ShowTooltip('[Clip format: ' + ci.GetFormatName + ']',
                    self.LastCursorPos);
            end;
            MyFree(ci);
        end else begin
            Tooltip.ShowTooltip(self.LastHint, self.LastCursorPos);
        end;

    end;

    self.LastHint := '';
    self.TimeFiring := false;
end;


procedure TFrmDummyUnicodePopup.WMMenuSelect(var Msg: TWMMenuSelect);
var id : word;
    i  : integer;
    ni, ni2 : TNotifyEvent;
    mi : TMenuItem;
begin
    tim.Enabled := false;
    ToolTip.CloseTooltip;


    //
    // Here, we assign either set "Hint" to display as a tooltip as plain
    // text, or we use the complex item (unicode) if available
    //

    self.LastHint := '';
    self.LastClipITem := nil;
    id := TWMMENUSELECT(msg).IDItem;


    //
    // ignore Menu items with submenus - they don't have popups
    //
    if ((TWMMENUSELECT(msg).MenuFlag and MF_POPUP) <> 0) then begin
        EXIT;
    end;

    mi := self.ItemIDToMenuItem(id);
    if (mi <> nil) then begin

        // use the click event address to determin the type of menu item
        // that's hilighted

        ni := mi.OnClick;
        ni2 := FrmMainPopup.MenuItemClickEvent;
        if (@ni = @ni2) then begin
            i := ClipQueue.IndexOf(mi.hint);
            self.LastClipItem := ClipQueue.GetClipItem(i)
        end;

        ni2 := FrmMainPopup.LastMenuItemClickEvent;
        if (@ni = @ni2) then begin
            self.LastHint := FrmMainPopup.GetLastStringSelected;
        end;

        ni2 := FrmMainPopup.CurrentMenuItemClickEvent;
        if (@ni = @ni2) then begin
            self.LastHint := self.CurrentClipboard.GetAsText;
        end;

        ni2 := FrmMainPopup.PermanentMenuItemClickEvent;
        if (@ni = @ni2) then begin
            // Caption contains name
            // hint contains plain text value
            // tag containg the group ID or -1 for current group

            self.LastHint := mi.Hint;
            if (mi.Tag <> - 1) then begin
                FrmPermanent.PermFolderPush;
                FrmPermanent.SetPermanentPath(FrmPermanent.PermFoldersGetItem(mi.tag));
                self.LastHint := FrmPermanent.GetTextFrom(mi.caption);

                FrmPermanent.PermFolderPop;
            end;
        end;
    end;
end;


function TFrmDummyUnicodePopup.ItemIDToMenuItem(
  itemID: integer): TMenuItem;
var s : string;
    i : integer;
begin
    result := nil;

    // either ItemID is a WM_COMMAND (an index to an object)
    // or it's an address of a menu item
    // - find the correct one and return it or NIL

    if itemID < SubObjectList.Count then begin
        result := TMenuItem(SubObjectList.Items[itemID]);
    end;

    if result = nil then begin
        s := SubMenuItemList.values[IntToStr(itemID)];
        if (s <> '') then begin
            i := StrToInt(s);
            if i < SubObjectList.Count then begin
                result := TMenuItem( SubObjectList.items[i] );
            end;
        end;
    end;
end;

end.