Changeset 244 for branches/highdpi/Packages/DpiControls/UDpiControls.pas

Timestamp:

May 21, 2020, 6:42:45 PM (4 years ago)

Author:

chronos

Message:

• Added: TDpiPopupMenu and TDpiMenuItem support.

File:

• branches/highdpi/Packages/DpiControls/UDpiControls.pas (modified) (7 diffs)

branches/highdpi/Packages/DpiControls/UDpiControls.pas

@@ -8 +8 @@
   Classes, SysUtils, LCLProc, LResources, Forms, FormEditingIntf, ProjectIntf,
   Controls, StdCtrls, fgl, Graphics, ComCtrls, ExtCtrls, LCLType, GraphType,
-  Types, CustApp, LMessages, LCLIntf;
+  Types, CustApp, LMessages, LCLIntf, Menus;
 
 type
@@ -483 +483 @@
     function GetVclForm: TForm; virtual;
     procedure UpdateVclControl; override;
-    procedure AfterConstruction; override;
   public
     VclForm: TForm;
+    procedure AfterConstruction; override;
     property ModalResult: TModalResult read GetModalResult write SetModalResult;
     function ShowModal: Integer; virtual;
@@ -796 +796 @@
   end;
 
+  { TDpiMenuItem }
+
+  TDpiMenuItem = class(TComponent)
+  private
+    FItems: TList;
+    FParent: TDpiMenuItem;
+    FOnClick: TNotifyEvent;
+    function GetCaption: TTranslateString;
+    function GetChecked: Boolean;
+    function GetCount: Integer;
+    function GetEnabled: Boolean;
+    function GetGroupIndex: Byte;
+    function GetItem(Index: Integer): TDpiMenuItem;
+    function GetOnClick: TNotifyEvent;
+    function GetRadioItem: Boolean;
+    function GetShortCut: TShortCut;
+    function GetVisible: Boolean;
+    function IsCaptionStored: Boolean;
+    function IsCheckedStored: Boolean;
+    function IsEnabledStored: Boolean;
+    function IsShortCutStored: Boolean;
+    function IsVisibleStored: Boolean;
+    procedure SetCaption(AValue: TTranslateString);
+    procedure SetChecked(AValue: Boolean);
+    procedure SetEnabled(AValue: Boolean);
+    procedure SetGroupIndex(AValue: Byte);
+    procedure SetOnClick(AValue: TNotifyEvent);
+    procedure SetRadioItem(AValue: Boolean);
+    procedure SetShortCut(AValue: TShortCut);
+    procedure SetVisible(AValue: Boolean);
+    procedure OnClickHandler(Sender: TObject);
+  protected
+    function GetVclMenuItem: TMenuItem; virtual;
+    procedure SetParentComponent(AValue: TComponent); override;
+  public
+    VclMenuItem: TMenuItem;
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Delete(Index: Integer);
+    procedure Add(Item: TDpiMenuItem);
+    procedure Insert(Index: Integer; Item: TDpiMenuItem);
+    function IndexOf(Item: TDpiMenuItem): Integer;
+    procedure Remove(Item: TDpiMenuItem);
+    property Items[Index: Integer]: TDpiMenuItem read GetItem; default;
+    property Count: Integer read GetCount;
+  published
+    property RadioItem: Boolean read GetRadioItem write SetRadioItem default False;
+    property ShortCut: TShortCut read GetShortCut write SetShortCut
+      stored IsShortCutStored default 0;
+    property Enabled: Boolean read GetEnabled write SetEnabled
+      stored IsEnabledStored default True;
+    property Visible: Boolean read GetVisible write SetVisible
+      stored IsVisibleStored default True;
+    property Checked: Boolean read GetChecked write SetChecked
+      stored IsCheckedStored default False;
+    property Caption: TTranslateString read GetCaption write SetCaption
+      stored IsCaptionStored;
+    property OnClick: TNotifyEvent read GetOnClick write SetOnClick;
+    property GroupIndex: Byte read GetGroupIndex write SetGroupIndex default 0;
+  end;
+
+  TDpiMenu = class(TComponent)
+  private
+    FItems: TDpiMenuItem;
+  protected
+    function GetVclMenu: TMenu; virtual;
+  public
+    property Items: TDpiMenuItem read FItems;
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+  end;
+
+  { TDpiPopupMenu }
+
+  TDpiPopupMenu = class(TDpiMenu)
+  private
+    function GetAutoPopup: Boolean;
+    procedure SetAutoPopup(AValue: Boolean);
+  protected
+    function GetVclMenu: TMenu; override;
+    function GetVclPopupMenu: TPopupMenu; virtual;
+  public
+    VclPopupMenu: TPopupMenu;
+    procedure PopUp;
+    procedure PopUp(X, Y: Integer); virtual;
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+  published
+    property AutoPopup: Boolean read GetAutoPopup write SetAutoPopup default True;
+  end;
+
 var
   DpiFormFileDesc: TDpiFormFileDesc;
@@ -818 +909 @@
 implementation
 
+uses
+  LCLStrConsts;
+
 resourcestring
   SDpiFormTitle = 'DpiForm form';
@@ -827 +921 @@
   DpiFormFileDesc := TDpiFormFileDesc.Create;
   RegisterProjectFileDescriptor(DpiFormFileDesc);
-  RegisterComponents('DpiControls', [TDpiButton, TDpiImage, TDpiPaintBox, TDpiListBox]);
+  RegisterComponents('DpiControls', [TDpiButton, TDpiImage, TDpiPaintBox,
+    TDpiListBox, TDpiPopupMenu]);
 end;
 
@@ -897 +992 @@
   Result := BitBlt(DestDC, ScaleToVcl(X), ScaleToVcl(Y), ScaleToVcl(Width),
     ScaleToVcl(Height), SrcDC, ScaleToVcl(XSrc), ScaleToVcl(YSrc), Rop);
+end;
+
+{ TDpiMenu }
+
+function TDpiMenu.GetVclMenu: TMenu;
+begin
+  Result := nil;
+end;
+
+constructor TDpiMenu.Create(AOwner: TComponent);
+begin
+  inherited;
+  FItems := TDpiMenuItem.Create(Self);
+end;
+
+destructor TDpiMenu.Destroy;
+begin
+  FreeAndNil(FItems);
+  inherited;
+end;
+
+{ TDpiMenuItem }
+
+function TDpiMenuItem.GetCaption: TTranslateString;
+begin
+  Result := GetVclMenuItem.Caption;
+end;
+
+function TDpiMenuItem.GetChecked: Boolean;
+begin
+  Result := GetVclMenuItem.Checked;
+end;
+
+function TDpiMenuItem.GetCount: Integer;
+begin
+  Result := FItems.Count;
+end;
+
+function TDpiMenuItem.GetEnabled: Boolean;
+begin
+  Result := GetVclMenuItem.Enabled;
+end;
+
+function TDpiMenuItem.GetGroupIndex: Byte;
+begin
+  Result := GetVclMenuItem.GroupIndex;
+end;
+
+function TDpiMenuItem.GetItem(Index: Integer): TDpiMenuItem;
+begin
+  Result := TDpiMenuItem(FItems[Index]);
+end;
+
+function TDpiMenuItem.GetOnClick: TNotifyEvent;
+begin
+  Result := FOnClick;
+end;
+
+function TDpiMenuItem.GetRadioItem: Boolean;
+begin
+  Result := GetVclMenuItem.RadioItem;
+end;
+
+function TDpiMenuItem.GetShortCut: TShortCut;
+begin
+  Result := GetVclMenuItem.ShortCut;
+end;
+
+function TDpiMenuItem.GetVisible: Boolean;
+begin
+  Result := GetVclMenuItem.Visible;
+end;
+
+function TDpiMenuItem.IsCaptionStored: Boolean;
+begin
+  Result := False;
+end;
+
+function TDpiMenuItem.IsCheckedStored: Boolean;
+begin
+  Result := False;
+end;
+
+function TDpiMenuItem.IsEnabledStored: Boolean;
+begin
+  Result := False;
+end;
+
+function TDpiMenuItem.IsShortCutStored: Boolean;
+begin
+  Result := False;
+end;
+
+function TDpiMenuItem.IsVisibleStored: Boolean;
+begin
+  Result := False;
+end;
+
+procedure TDpiMenuItem.SetCaption(AValue: TTranslateString);
+begin
+  GetVclMenuItem.Caption := AValue;
+end;
+
+procedure TDpiMenuItem.SetChecked(AValue: Boolean);
+begin
+  GetVclMenuItem.Checked := AValue;
+end;
+
+procedure TDpiMenuItem.SetEnabled(AValue: Boolean);
+begin
+  GetVclMenuItem.Enabled := AValue;
+end;
+
+procedure TDpiMenuItem.SetGroupIndex(AValue: Byte);
+begin
+  GetVclMenuItem.GroupIndex := AValue;
+end;
+
+procedure TDpiMenuItem.SetOnClick(AValue: TNotifyEvent);
+begin
+  FOnClick := AValue;
+end;
+
+procedure TDpiMenuItem.SetRadioItem(AValue: Boolean);
+begin
+  GetVclMenuItem.RadioItem := AValue;
+end;
+
+procedure TDpiMenuItem.SetShortCut(AValue: TShortCut);
+begin
+  GetVclMenuItem.ShortCut := AValue;
+end;
+
+procedure TDpiMenuItem.SetVisible(AValue: Boolean);
+begin
+  GetVclMenuItem.Visible := AValue;
+end;
+
+procedure TDpiMenuItem.OnClickHandler(Sender: TObject);
+begin
+  if Assigned(FOnClick) then
+    FOnClick(Self);
+end;
+
+procedure TDpiMenuItem.Delete(Index: Integer);
+begin
+  FItems.Delete(Index);
+  GetVclMenuItem.Delete(Index);
+end;
+
+procedure TDpiMenuItem.Add(Item: TDpiMenuItem);
+begin
+  Insert(GetCount, Item);
+end;
+
+procedure TDpiMenuItem.Insert(Index: Integer; Item: TDpiMenuItem);
+begin
+  FItems.Insert(Index, Item);
+  GetVclMenuItem.Insert(Index, Item.GetVclMenuItem);
+end;
+
+function TDpiMenuItem.IndexOf(Item: TDpiMenuItem): Integer;
+begin
+  if FItems = nil then
+    Result := -1
+  else
+    Result := FItems.IndexOf(Item);
+end;
+
+procedure TDpiMenuItem.Remove(Item: TDpiMenuItem);
+var
+  I: Integer;
+begin
+  I := IndexOf(Item);
+  if I < 0 then
+    raise EMenuError.Create(SMenuNotFound);
+  Delete(I);
+end;
+
+function TDpiMenuItem.GetVclMenuItem: TMenuItem;
+begin
+  if not Assigned(VclMenuItem) then begin
+    VclMenuItem := TMenuItem.Create(nil);
+    VclMenuItem.Name := 'Vcl' + Name;
+    VclMenuItem.OnClick := @OnClickHandler;
+  end;
+  Result := VclMenuItem;
+end;
+
+procedure TDpiMenuItem.SetParentComponent(AValue: TComponent);
+begin
+  if (FParent = AValue) then Exit;
+  if Assigned(FParent) then FParent.Remove(Self);
+  if Assigned(AValue) then
+  begin
+    if (AValue is TDpiMenu)
+      then TDpiMenu(AValue).Items.Add(Self)
+    else if (AValue is TDpiMenuItem)
+      then TDpiMenuItem(AValue).Add(Self)
+    else
+      raise Exception.Create('TDpiMenuItem.SetParentComponent: suggested parent not of type TDpiMenu or TDpiMenuItem');
+   end;
+end;
+
+constructor TDpiMenuItem.Create(AOwner: TComponent);
+begin
+  inherited;
+  FItems := TList.Create;
+end;
+
+destructor TDpiMenuItem.Destroy;
+begin
+  FreeAndNil(FItems);
+  inherited Destroy;
+end;
+
+{ TDpiPopupMenu }
+
+procedure TDpiPopupMenu.PopUp;
+var
+  Pos: TPoint;
+begin
+  Pos := DpiMouse.CursorPos;
+  Popup(Pos.X, Pos.Y);
+end;
+
+procedure TDpiPopupMenu.PopUp(X, Y: Integer);
+begin
+  GetVclPopupMenu.PopUp(ScaleToVcl(X), ScaleToVcl(Y));
+end;
+
+constructor TDpiPopupMenu.Create(AOwner: TComponent);
+begin
+  inherited;
+  GetVclPopupMenu;
+end;
+
+function TDpiPopupMenu.GetAutoPopup: Boolean;
+begin
+  Result := GetVclPopupMenu.AutoPopup;
+end;
+
+procedure TDpiPopupMenu.SetAutoPopup(AValue: Boolean);
+begin
+  GetVclPopupMenu.AutoPopup := AValue;
+end;
+
+function TDpiPopupMenu.GetVclMenu: TMenu;
+begin
+  Result := GetVclPopupMenu;
+end;
+
+function TDpiPopupMenu.GetVclPopupMenu: TPopupMenu;
+begin
+  if not Assigned(VclPopupMenu) then begin
+    VclPopupMenu := TPopupMenu.Create(nil);
+    if Assigned(Items.VclMenuItem) then Items.VclMenuItem.Free;
+    Items.VclMenuItem := VclPopupMenu.Items;
+  end;
+  Result := VclPopupMenu;
+end;
+
+destructor TDpiPopupMenu.Destroy;
+begin
+  if Assigned(VclPopupMenu) then FreeAndNil(VclPopupMenu);
+  inherited Destroy;
 end;
 
@@ -2213 +2574 @@
 procedure TDpiScreen.UpdateScreen;
 begin
-  Dpi := 96 * 2; //Screen.PixelsPerInch;
+//  Dpi := 96 * 2;
+  Dpi := Screen.PixelsPerInch;
 end;