Recent

Author Topic: TPopup OwnerDraw remove menu border  (Read 441 times)

kinnon_2000

  • New member
  • *
  • Posts: 9
TPopup OwnerDraw remove menu border
« on: February 06, 2021, 01:40:09 am »
Hello,

I've been making a little Windows app with custom popup menu.

thanks to the following topic I've made progress customising the look of the popup menu:
https://forum.lazarus.freepascal.org/index.php/topic,48805.msg351924.html#msg351924

However, no matter what I do, I cant get rid of the popup menu bevelled border. I want my menu to be completely flat and borderless. 

I think the issue is the OnDrawItem only deals with the items, and not the menu they are contained in; so I'm hoping theres a solution I just havent found yet, other than making a custom TPopupMenu  :o .

Example zip has been attached.

My example unit based on the one in the topic above is as follows:

Code: [Select]
{
sources
https://forum.lazarus.freepascal.org/index.php/topic,48805.msg351924.html#msg351924
https://www.tweaking4all.com/forum/delphi-lazarus-free-pascal/delphilazarus-how-to-make-a-tcolor-lighter-or-darker/
https://stackoverflow.com/questions/596216/formula-to-determine-brightness-of-rgb-color
}

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, Menus, LCLType,
  StdCtrls, ActnList, ExtCtrls, Windows, GraphUtil;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Fnt: TFontDialog;
    MenuItem1: TMenuItem;
    MenuItem2: TMenuItem;
    MenuItem3: TMenuItem;
    MenuItem4: TMenuItem;
    MenuItem5: TMenuItem;
    MenuItem6: TMenuItem;
    N1: TMenuItem;
    MenuItem8: TMenuItem;
    MenuItem9: TMenuItem;
    PopupMenu1: TPopupMenu;
    procedure Button2Click(Sender: TObject);
    procedure CheckBox1Change(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure MnuDrawItem(Sender: TObject; ACanvas: TCanvas;
        ARect: TRect; AState: TOwnerDrawState);

    procedure fontUpdate;

  private

  public

  end;

var
  Form1: TForm1;
  bgClr, highlightClr:TColor;

implementation

{$R *.lfm}

uses
  Types, ImgList;

{ TForm1 }


function Darker(MyColor:TColor; Percent:Byte):TColor;
var r,g,b:Byte;
begin
  MyColor:=ColorToRGB(MyColor);
  r:=GetRValue(MyColor);
  g:=GetGValue(MyColor);
  b:=GetBValue(MyColor);
  r:=r-muldiv(r,Percent,100);  //Percent% closer to black
  g:=g-muldiv(g,Percent,100);
  b:=b-muldiv(b,Percent,100);
  result:=RGB(r,g,b);
end;
function Lighter(MyColor:TColor; Percent:Byte):TColor;
var r,g,b:Byte;
begin
  MyColor:=ColorToRGB(MyColor);
  r:=GetRValue(MyColor);
  g:=GetGValue(MyColor);
  b:=GetBValue(MyColor);
  r:=r+muldiv(255-r,Percent,100); //Percent% closer to white
  g:=g+muldiv(255-g,Percent,100);
  b:=b+muldiv(255-b,Percent,100);
  result:=RGB(r,g,b);
end;

function getClrBrightness(clr:TColor):Integer;
var r, g, b:Integer;
    l:real;
begin
     r:=red(clr);
     g:=green(clr);
     b:=blue(clr);
     l:=(0.2126*r + 0.7152*g + 0.0722*b);
     result:=round(l);
end;

procedure TForm1.fontUpdate;
var thisLbl: TLabel;
    i, l:Integer;
begin
  // pick a background colour
  bgClr:=invertColor(fnt.Font.Color);
  l:=getClrBrightness(bgClr);
  if l<50 then begin
    // dark bg colour, so pick light highlight
    highlightClr:=lighter(bgclr,20);
  end else begin
    // light bg, pick dark bg highlight
    highlightClr:=darker(bgclr,20);
  end;

end;

procedure TForm1.CheckBox1Change(Sender: TObject);
begin

end;

procedure TForm1.Button2Click(Sender: TObject);
begin
    if Fnt.Execute then begin
     fontUpdate;
  end;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  fontUpdate;
end;

procedure TForm1.MnuDrawItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; AState: TOwnerDrawState);
var
  s: string;
  gutter:Integer;
begin
  gutter:=48;
  ACanvas.Font:=Fnt.font;
  if  AState * [odSelected, odFocused]=[] then begin
    ACanvas.Brush.Color := bgClr;
    ACanvas.Pen.Color:=bgClr;
  end
  else begin
    ACanvas.Brush.Color := highlightClr;
    ACanvas.Pen.Color:=highlightClr;
    ACanvas.Font.Style := [fsBold];
  end;
    s := (Sender as TMenuItem).Caption;
    ACanvas.Rectangle(ARect);
    ACanvas.TextOut(gutter, ARect.Top + 2 , s);
end;

end.



Thanks in advance for any advice,
Al
« Last Edit: February 06, 2021, 02:19:22 am by kinnon_2000 »

jamie

  • Hero Member
  • *****
  • Posts: 4446
Re: TPopup OwnerDraw remove menu border
« Reply #1 on: February 14, 2021, 01:09:30 am »
if you are in windows its hard to override the system control on things..

However, there is a trick you can do but it only works in windows of course...

this is just a skeleton of what I mean
Code: Pascal  [Select][+][-]
  1. procedure TForm1.PopupMenu1DrawItem(Sender: TObject; ACanvas: TCanvas;
  2.   ARect: TRect; AState: TOwnerDrawState);
  3. var
  4.   TheRect:TRect;
  5.   DC:Thandle;
  6. begin
  7.   GetMenuItemRect(0, PopupMenu1.Handle, TMenuItem(Sender).MenuIndex,TheRect);
  8.   InflateRect(TheREct, 3,3);
  9.   DC := GetDC(GetDeskTopWindow);
  10.   FillRect(DC,TheRect,GetSysColorBrush(10));
  11.   ReleaseDC(GetDeskTopWindow, DC);
  12.   ACanvas.TextOut(ARect.left,ARect.Top, TMenuItem(Sender).Caption);
  13. end;                                                                
  14.  

The GetMenuItemRect will return the SCREEN rectangle of the item and with that you can expand it and use a Screen Context canvas instead to overwrite the border.
The FillRect comes from the Windows Unit..
etc

 This is just an idea …
The only true wisdom is knowing you know nothing

furious programming

  • Hero Member
  • *****
  • Posts: 504
  • I click a little.
    • TreeStructInfo — format for text and binary configuration files
Re: TPopup OwnerDraw remove menu border
« Reply #2 on: February 19, 2021, 01:59:57 pm »
@jamie: why are you using a desktop DC, since you have access to the popup window handle?

BTW: desktop is a single word, so Desktop, not DeskTop.
Lazarus 2.0.12 with FPC 3.2.0 (SVN Revision 64642), Windows 10 — all 64-bit

 

TinyPortal © 2005-2018