RnQ/for.RnQ/RQMenuItem.pas

{
  This file is part of R&Q.
  Under same license
}
unit RQMenuItem;
{$I ForRnQConfig.inc}

interface

uses
  Messages, Windows, Graphics, Classes, Types, Menus,
  RDGlobal,
  RQThemes;

{$I NoRTTI.inc}
{
  const
  CM_MENU_CLOSED = CM_BASE + 1001;
  CM_ENTER_MENU_LOOP = CM_BASE + 1002;
  CM_EXIT_MENU_LOOP = CM_BASE + 1003;
}

type
  TPopupListEx = class(TPopupList)
  protected
    procedure WndProc(var Message: TMessage); override;
  private
    // procedure PerformMessage(cm_msg : integer; msg : TMessage) ;
  end;

  TMenuCloseEvent = procedure(Sender: TObject) of object;

  TRnQPopupMenu = class(TPopupMenu)
  private
    FOnClose: TMenuCloseEvent;
    // procedure WMMENUSELECT(var msg: TWMMENUSELECT); message WM_MENUSELECT;
    procedure ExecuteOnClose;

  protected
    // procedure WndProc(var Message: TMessage) ; override;
    procedure DoPopup(Sender: TObject); override;

  public
    FIsOpenen: boolean;
    constructor Create(AOwner: TComponent); override;
  published
    property Alignment;
    property AutoHotkeys;
    property AutoLineReduction;
    property AutoPopup;
    property BiDiMode;
    property HelpContext;
    property Images;
    property MenuAnimation;
    property OwnerDraw;
    property ParentBiDiMode;
    property TrackButton;
    property OnChange;
    property OnClose: TMenuCloseEvent read FOnClose write FOnClose;
    property OnPopup;
  end;

  TRQMenuItem = class(TMenuItem)
  protected
    fImgElm: TRnQThemedElementDtls;
    FImageName: TPicName;
    // ThemeToken : Integer;
    // ImageLoc   : TPicLocation;
    // ImageIdx   : Integer;
    procedure AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState; TopLevel: boolean); override;
    // function drawMenuItemR(cnv:Tcanvas; Amenu:Tmenu; item:Tmenuitem;
    // r:Trect; onlysize:boolean=FALSE):Tpoint;
    procedure MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); override;
    procedure SetImageName(const Value: TPicName);
  public
    // FCaptionW: WideString;
    CanTranslate: boolean;
    PluginProc: Pointer;
    // ProtoLink  : Pointer;
    ProtoLink: TObject;
    // ProcIdx : Integer;
    // procedure OnPluginMenuClick(Sender: TObject);
{$IFDEF RNQ_SERVICES}
    ServiceName: String;
    procedure OnMenuClick(Sender: TObject);
{$ENDIF}
    constructor Create(AOwner: TComponent); override;
    procedure onExitMenu(var Msg: TMessage); message WM_EXITMENULOOP;
    property ImageName: TPicName read FImageName write SetImageName;
  end;
  // function drawMenuItemR(ACanvas : TCanvas; Amenu:Tmenu; item:Tmenuitem;
  // r:Trect; onlysize:boolean=FALSE;
  // drawbar : Boolean = True; Selected : Boolean = false):Tpoint;

  function GPdrawmenuitemR7(ACanvas: TCanvas; item: TMenuItem; r: TRect; onlysize: boolean = False; Selected: boolean = FALSE): TPoint;

  procedure Register;

implementation

uses
  RnQGlobal, RQUtil, RnQStrings, SysUtils, Forms,
{$IFDEF RNQ_SERVICES}
  m_globaldefs,
  m_api,
{$ENDIF}
  RnQGraphics32,
{$IFDEF UNICODE}
  AnsiStrings,
{$ENDIF UNICODE}
  StrUtils, math, ActnList;

{
  procedure TPopupMenuX.PerformMessage(cm_msg: integer; msg : TMessage) ;
  begin
  if Screen.Activeform <> nil then
  Screen.ActiveForm.Perform(cm_msg, msg.WParam, msg.LParam) ;
  end;
}

procedure TRnQPopupMenu.DoPopup(Sender: TObject);
begin
  FIsOpenen := True;
  inherited DoPopup(Sender);
end;

constructor TRnQPopupMenu.Create(AOwner: TComponent);
begin
  FIsOpenen := FALSE;
  inherited Create(AOwner);
end;

procedure TRnQPopupMenu.ExecuteOnClose;
begin
  FIsOpenen := FALSE;
  if Assigned(FOnClose) then
    FOnClose(Self);
end;

procedure Register;
begin
  RegisterComponents('RnQ', [TRnQPopupMenu]);
end;

procedure TPopupListEx.WndProc(var Message: TMessage);
var
  nTi: Integer;
  // tt : HMENU;
begin
  case message.Msg of
    // WM_ENTERMENULOOP: PerformMessage(CM_ENTER_MENU_LOOP, Message) ;
    // WM_EXITMENULOOP : PerformMessage(CM_EXIT_MENU_LOOP, Message) ;
    WM_MENUSELECT:
      with TWMMenuSelect(Message) do
      begin
        if (Menu = 0) and (Menuflag = $FFFF) then
        begin
          for nTi := 0 to Count - 1 do
          begin
            if TObject(Items[nTi]) is TRnQPopupMenu then
            begin
              if TRnQPopupMenu(Items[nTi]).FIsOpenen then
                TRnQPopupMenu(Items[nTi]).ExecuteOnClose;
            end;
          end;
          // PerformMessage(CM_MENU_CLOSED, Message) ;
        end;
      end;
  end;
  inherited;
end;

constructor TRQMenuItem.Create(AOwner: TComponent);
begin
  inherited;
  fImgElm.Element := RQteMenu;
  fImgElm.picName := '';
  fImgElm.ThemeToken := -1;
  CanTranslate := True;
end;

procedure TRQMenuItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState; TopLevel: boolean);
begin
  GPdrawmenuitemR7(ACanvas, Self, ARect, False, odSelected in State);
end;

procedure TRQMenuItem.MeasureItem(ACanvas: TCanvas; var Width, Height: Integer);
var
  p: TPoint;
begin
  p := GPdrawmenuitemR7(ACanvas, TMenuItem(Self), rect(0, 0, Width, Height), True);
  Width := p.x;
  Height := p.y;
end;

function GPdrawmenuitemR7(ACanvas: TCanvas; item: TMenuItem; r: TRect; onlysize: boolean = False; Selected: boolean = FALSE): TPoint;
var
  vpad, hpad, k: Integer;
  picSize: TSize;
  s: string;
  r2: TRect;
  dc: HDC;

  procedure embossedCenteredLine(x1, x2: Integer);
  var
    y: Integer;
    oldP, hp: HPEN;
  begin
    y := (r.Top + r.Bottom) div 2;
    hp := CreatePen(PS_SOLID, 1, ColorToRGB(clBtnShadow));
    oldP := SelectObject(dc, hp);
    MoveToEx(dc, x1, y, NIL);
    lineTo(dc, x2, y);
    inc(y);
    hp := CreatePen(PS_SOLID, 1, ColorToRGB(clBtnHighlight));
    hp := SelectObject(dc, hp);
    DeleteObject(hp);
    MoveToEx(dc, x1, y, NIL);
    lineTo(dc, x2, y);
    hp := SelectObject(dc, oldP);
    DeleteObject(hp);
  end; // embossedCenteredLine

var
  res: TSize;
  vImgElm: TRnQThemedElementDtls;
  oldFont: HFONT;
  ABitmap, HOldBmp: HBITMAP;
  BI: TBitmapInfo;
  MenuColor1, MenuColor2: Cardinal;
  oldColor: Cardinal;
  brF: HBRUSH;
  oldMode: Integer;
begin
  r2 := r;
  try
    dc := CreateCompatibleDC(ACanvas.Handle);
    HOldBmp := 0;
    with r do
      if (Width > 0) and (Height > 0) then
      begin
        BI.bmiHeader.biSize := SizeOf(TBitmapInfoHeader);
        BI.bmiHeader.biWidth := Right - Left;
        BI.bmiHeader.biHeight := Bottom - Top;
        BI.bmiHeader.biPlanes := 1;
        BI.bmiHeader.biBitCount := 32;
        BI.bmiHeader.biCompression := BI_RGB;
        ABitmap := CreateDIBitmap(ACanvas.Handle, BI.bmiHeader, 0, NIL, BI, DIB_RGB_COLORS);
        if (ABitmap = 0) and (Right > Left) and (Bottom > Top) then
        begin
          DeleteDC(dc);
          dc := 0;
          raise EOutOfResources.Create('Out of Resources');
        end;
        HOldBmp := SelectObject(dc, ABitmap);
        SetWindowOrgEx(dc, Left, Top, Nil);
      end else
        ABitmap := 0;
  except end;

  vImgElm.pEnabled := item.Enabled;
  vImgElm.Element := RQteMenu;
  vImgElm.ThemeToken := -1;
  s := item.Caption;

  if not TryStrToInt(theme.GetString('menu.vpadding'), vpad) then
    vpad := 5;
  if not TryStrToInt(theme.GetString('menu.hpadding'), hpad) then
    hpad := 7;

  try
    // Clear
    if (not onlysize) then
{$IFDEF USE_SMILE_MENU}
      if ((item.Tag > 4000) and (item.Tag < 4999)) then
        FillRect(dc, r, GetSysColorBrush(COLOR_MENU))
      else
{$ENDIF USE_SMILE_MENU}
        FillGradient(dc, r, theme.GetAColor('menu.fade1', clMenu), theme.GetAColor('menu.fade2', clMenu), gdHorizontal);

    Result.x := hpad;
    Result.y := vpad;
    ACanvas.Font.Assign(Screen.menuFont);

    if Selected then
    begin
      ACanvas.Font.Color := clMenuText;
      theme.ApplyFont('menu.selected', ACanvas.Font);
    end else
      theme.ApplyFont('menu', ACanvas.Font);

    if s = '-' then
    begin
      res.cy := 3;
      Inc(Result.y, res.cy);
      s := item.hint;
      if s = '' then
      begin
        if not onlysize then
          embossedCenteredLine(r.Left, r.Right);
      end
        else
      begin
        oldFont := SelectObject(dc, ACanvas.Font.Handle);
        oldColor := SetTextColor(dc, ColorToRGB(ACanvas.Font.Color));
        GetTextExtentPoint32(dc, PChar(s), Length(s), res);
        Result.y := Max(Result.y, res.cy + vpad * 2);
        if not onlysize then
        begin
          embossedCenteredLine(r.Left, (r.Right - res.cx - 10) div 2);
          embossedCenteredLine((r.Right + res.cx + 10) div 2, r.Right);
          oldMode := SetBKMode(dc, TRANSPARENT);
          DrawText(dc, PChar(s), -1, r, DT_SINGLELINE or DT_VCENTER or DT_CENTER);
          SetBKMode(dc, oldMode);
        end;
        SelectObject(dc, oldFont);
      end;
      Exit;
    end;

    if Selected and not onlysize then
    begin
      MenuColor1 := theme.GetColor('menu.selected', $CFCFCF);
      if (MenuColor1 = 16750950) then
        MenuColor1 := ColorToRGB($CFCFCF);

      brF := CreateSolidBrush(MenuColor1);
      FillRect(dc, r, brF);
      DeleteObject(brF);
    end;

    if (Win32MajorVersion >= 6) and item.Checked and not onlysize and not Selected then
    begin
      MenuColor2 := ColorToRGB(theme.GetColor('menu.selected', $CFCFCF));
      FillRect(dc, r, MenuColor2);
    end;

    vImgElm.picName := '';
    picSize.cy := 0;
    if not item.Bitmap.Empty then
    begin
      picSize.cx := item.Bitmap.Width;
      picSize.cy := item.Bitmap.Height;
      if not onlysize then
      begin
        k := (r.Top + r.Bottom - picSize.cy) div 2;
        TransparentBlt(dc, Result.x, k, picSize.cx, picSize.cy, item.Bitmap.Canvas.Handle, 0, 0, picSize.cx, picSize.cy,
          ColorToRGB(item.Bitmap.TransparentColor) and not AlphaMask);
      end;
      Inc(Result.x, picSize.cx + hpad + 1);
      Inc(Result.y, picSize.cy);
    end
      else
    begin
      if Assigned(item.Action) then
      begin
        vImgElm.picName := TAction(item.Action).HelpKeyword;
        if (item is TRQMenuItem) then
        begin
          if TRQMenuItem(item).fImgElm.picName <> vImgElm.picName then
          begin
            TRQMenuItem(item).fImgElm.picName := vImgElm.picName;
            TRQMenuItem(item).fImgElm.ThemeToken := -1;
          end;
        end;
      end else if (item is TRQMenuItem) then
        vImgElm.picName := TRQMenuItem(item).fImgElm.picName;

      if vImgElm.picName <> '' then
      begin
        vImgElm.ThemeToken := -1;
        vImgElm.pEnabled := item.Enabled;
        if (item is TRQMenuItem) then
          TRQMenuItem(item).fImgElm.pEnabled := item.Enabled;
        if (item is TRQMenuItem) then
          picSize := theme.GetPicSize(TRQMenuItem(item).fImgElm)
        else
          picSize := theme.GetPicSize(vImgElm);
        if not onlysize then
        begin
          k := (r.Top + r.Bottom + - picSize.cy) div 2;
          if (item is TRQMenuItem) then
            theme.drawPic(dc, Point(Result.x, k), TRQMenuItem(item).fImgElm)
          else
            theme.drawPic(dc, Point(Result.x, k), vImgElm);
        end;
        Inc(Result.x, picSize.cx + hpad + 1);
        Inc(Result.y, picSize.cy);
      end else
        Inc(Result.x, 16 + hpad + 1);
    end;

    res.cx := 0;
    res.cy := 0;

{$IFDEF USE_SMILE_MENU}
    if (item.Tag < 4000) or (item.Tag > 4999) or (ShowSmileCaption) then
{$ENDIF USE_SMILE_MENU}
    // <20><> <20><> <20><>, <20><> <20><>
    begin
      if not item.Enabled then
        ACanvas.Font.Color := clGrayText;

      oldFont := SelectObject(dc, ACanvas.Font.Handle);
      oldColor := SetTextColor(dc, ColorToRGB(ACanvas.Font.Color));
      GetTextExtentPoint32(dc, PChar(s), Length(s), res);

      if not onlysize then
      begin
        r.Left := Result.x;
        oldMode := SetBKMode(dc, TRANSPARENT);
        DrawText(dc, PChar(s), -1, r, DT_SINGLELINE or DT_VCENTER);
        SetBKMode(dc, oldMode);
      end;
      SelectObject(dc, oldFont);
      Inc(Result.x, res.cx);
    end;

    if (Win32MajorVersion < 6) and item.Checked then
    begin
      vImgElm.ThemeToken := -1;
      vImgElm.picName := PIC_CURRENT;
      vImgElm.pEnabled := item.Enabled;
      with theme.GetPicSize(vImgElm) do
      begin
        if not onlysize then
          theme.drawPic(dc, Point(r.Right - cx - 5, r.Top + (r.Bottom - r.Top - cy) div 2), vImgElm);
        Inc(Result.x, cx + 2);
      end;
    end;

    Inc(Result.x, hpad);
    Result.y := Max(Result.y, res.cy + vpad);
    Inc(Result.Y, vpad);

    if item.Count > 0 then
      Inc(Result.x, vpad);
  finally
    if not onlysize then
      BitBlt(ACanvas.Handle, r2.Left, r2.Top, r2.Right - r2.Left, r2.Bottom - r2.Top, dc, r2.Left, r2.Top, SrcCopy);

    if not (HOldBmp = 0) then
      SelectObject(dc, HOldBmp);
    if not (ABitmap = 0) then
      DeleteObject(ABitmap);
    DeleteDC(dc);
  end;
end;

{$IFDEF RNQ_SERVICES}
procedure TRQMenuItem.OnMenuClick(Sender: TObject);
begin
  if ServiceName <> '' then
    CallService(PAnsiChar(ServiceName), 0, 0);
end;
{$ENDIF}

procedure TRQMenuItem.onExitMenu(var Msg: TMessage);
begin
end;

procedure TRQMenuItem.SetImageName(const Value: TPicName);
begin
  FImageName := Value;
  fImgElm.picName := LowerCase(Value);
  fImgElm.Element := RQteMenu;
  fImgElm.ThemeToken := -1;
  fImgElm.picIdx := -1;
end;

{
  initialization
  Popuplist.Free; //free the "default", "old" list
  PopupList:= TPopupListEx.Create; //create the new one
  // The new PopupList will be freed by
  // finalization section of Menus unit.
}

end.