unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Windows,
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, Menus, Types, LCLType;
type
{ TForm1 }
TForm1 = class(TForm)
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
FPopupMenu: TPopupMenu;
procedure BuildPopup(const AOwner: TComponent);
procedure DrawPopup(Sender: TObject; ACanvas: TCanvas;
ARect: TRect; AState: TOwnerDrawState);
procedure MenuItemClick(Sender: TObject);
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
var
PrevWndProc: WNDPROC;
function WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam): LRESULT; stdcall;
var
ClassNameBuffer: array[0..255] of Char;
lStyle: LongInt;
begin
if uMsg = WM_CREATE then
begin
Result := Windows.DefWindowProc(Ahwnd, uMsg, wParam, lParam);
if GetClassName(Ahwnd, @ClassNameBuffer[0], Length(ClassNameBuffer)) > 0 then
begin
if AnsiCompareStr(ClassNameBuffer, 'TPopupMenu') = 0 then
begin
lStyle := GetWindowLongPtr(Ahwnd, GWL_STYLE);
lStyle := lStyle and not WS_BORDER;
SetWindowLongPtr(Ahwnd, GWL_STYLE, lStyle);
end;
end;
end;
Result := CallWindowProc(PrevWndProc,Ahwnd, uMsg, WParam, LParam);
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
PrevWndProc := Windows.WNDPROC(SetWindowLongPtr(Self.Handle, GWL_WNDPROC, PtrInt(@WndCallback)));
FPopupMenu := nil;
end;
procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbRight then
begin
BuildPopup(Self);
FPopupMenu.PopUp(Mouse.CursorPos.X, Mouse.CursorPos.Y);
end;
end;
procedure TForm1.BuildPopup(const AOwner: TComponent);
var
MenuItem: TMenuItem;
begin
if (FPopupMenu = nil) then
begin
FPopupMenu := TPopupMenu.Create(AOwner);
try
FPopupMenu.OwnerDraw := True;
FPopupMenu.OnDrawItem := @DrawPopup;
MenuItem := TMenuItem.Create(Self);
MenuItem.Caption := 'Item 1';
MenuItem.OnClick := @MenuItemClick;
FPopupMenu.Items.Add(MenuItem);
MenuItem := TMenuItem.Create(Self);
MenuItem.Caption := '-';
MenuItem.OnClick := @MenuItemClick;
FPopupMenu.Items.Add(MenuItem);
MenuItem := TMenuItem.Create(Self);
MenuItem.Caption := 'Item 2';
MenuItem.OnClick := @MenuItemClick;
FPopupMenu.Items.Add(MenuItem);
finally
end;
end;
end;
procedure TForm1.DrawPopup(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
AState: TOwnerDrawState);
begin
ACanvas.Brush.Style:= bsSolid;
// background color
if odSelected in AState then
ACanvas.Brush.Color := clHighlight
else
ACanvas.Brush.Color := clSkyBlue;
// line color
ACanvas.Pen.Color:= clAqua;
// font color
ACanvas.Font.Color := clNavy;
// draw the rectangle
ACanvas.FillRect(ARect);
// draw the text
if (TMenuItem(Sender).Caption <> '-') then
Acanvas.TextOut(ARect.Left + 5, ARect.Top + 5, TMenuItem(Sender).Caption)
else
Acanvas.Line(ARect.Left + 5, ARect.Top + 3, ARect.Right - 5, ARect.Top + 3);
end;
procedure TForm1.MenuItemClick(Sender: TObject);
begin
//
end;
end.
Recent
