Кнопки с надписью не реагируют на щелчки мыши после рисования без клиента с помощью DWM в Delphi

Question

Кнопки с надписью не реагируют на щелчки мыши после рисования без клиента с помощью DWM в Delphi

Я рисую неклиентскую область приложения с помощью Desktop Window Manager, добавляя новую кнопку для тестирования.

После компиляции моя пользовательская кнопка доступна по клику, но кнопки заголовка по умолчанию («Свернуть», «Максимизировать» и «Закрыть») ничего не делают, когда я навис над ними или нажимаю на них.

Перекрашенная строка заголовка отвечает на перетаскивание и двойные щелчки. Форма максимизируется, когда я по умолчанию дважды щелкаю по заголовку. Кнопка «Закрыть» отвечает на самый угол ее возле правой границы формы.

Я написал свою процедуру рисования, как описано в этой статье.

Новые коды, которые я добавил:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ImgList, Buttons;

type
  TForm1 = class(TForm)
    ImageList1: TImageList;
    SpeedButton1: TSpeedButton;
    function GetSysIconRect: TRect;
    procedure PaintWindow(DC: HDC);
    procedure InvalidateTitleBar;
    procedure FormCreate(Sender: TObject);
    procedure WndProc(var Message: TMessage);
    procedure FormPaint(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
  protected
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
    procedure CMTextChanged(var Message: TMessage);
    procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
    procedure WMNCRButtonUp(var Message: TWMNCRButtonUp); message WM_NCRBUTTONUP;
  private
    { Private declarations }
    FWndFrameSize: Integer;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  DWMAPI, CommCtrl, Themes, UXTheme, StdCtrls;

{$R *.dfm}

{$IF not Declared(UnicodeString)}
type
  UnicodeString = WideString;
{$IFEND}

procedure DrawGlassCaption(Form: TForm; const Text: UnicodeString;
  Color: TColor; var R: TRect; HorzAlignment: TAlignment = taLeftJustify;
  VertAlignment: TTextLayout = tlCenter; ShowAccel: Boolean = False); overload;
const
  BasicFormat = DT_SINGLELINE or DT_END_ELLIPSIS;
  HorzFormat: array[TAlignment] of UINT = (DT_LEFT, DT_RIGHT, DT_CENTER);
  VertFormat: array[TTextLayout] of UINT = (DT_TOP, DT_VCENTER, DT_BOTTOM);
  AccelFormat: array[Boolean] of UINT = (DT_NOPREFIX, 0);
var
  DTTOpts: TDTTOpts;
  Element: TThemedWindow;
  IsVistaAndMaximized: Boolean;
  NCM: TNonClientMetrics;
  ThemeData: HTHEME;

  procedure DoTextOut;
  begin
    with ThemeServices.GetElementDetails(Element) do
      DrawThemeTextEx(ThemeData, Form.Canvas.Handle, Part, State, PWideChar(Text),
        Length(Text), BasicFormat or AccelFormat[ShowAccel] or
        HorzFormat[HorzAlignment] or VertFormat[VertAlignment], @R, DTTOpts);
  end;

begin
  if Color = clNone then Exit;
  IsVistaAndMaximized := (Form.WindowState = wsMaximized) and
    (Win32MajorVersion = 6) and (Win32MinorVersion = 0);
  ThemeData := OpenThemeData(0, 'CompositedWindow::Window');
  Assert(ThemeData <> 0, SysErrorMessage(GetLastError));
  Try
    NCM.cbSize := SizeOf(NCM);
    if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCM, 0) then
      if Form.BorderStyle in [bsToolWindow, bsSizeToolWin] then
        Form.Canvas.Font.Handle := CreateFontIndirect(NCM.lfSmCaptionFont)
      else
        Form.Canvas.Font.Handle := CreateFontIndirect(NCM.lfCaptionFont);
    ZeroMemory(@DTTOpts, SizeOf(DTTOpts));
    DTTOpts.dwSize := SizeOf(DTTOpts);
    DTTOpts.dwFlags := DTT_COMPOSITED or DTT_TEXTCOLOR;
    if Color <> clDefault then
      DTTOpts.crText := ColorToRGB(Color)
    else if IsVistaAndMaximized then
      DTTOpts.dwFlags := DTTOpts.dwFlags and not DTT_TEXTCOLOR
    else if Form.Active then
      DTTOpts.crText := GetSysColor(COLOR_CAPTIONTEXT)
    else
      DTTOpts.crText := GetSysColor(COLOR_INACTIVECAPTIONTEXT);
    if not IsVistaAndMaximized then
    begin
      DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_GLOWSIZE;
      DTTOpts.iGlowSize := 15;
    end;
    if Form.WindowState = wsMaximized then
      if Form.Active then
        Element := twMaxCaptionActive
      else
        Element := twMaxCaptionInactive
    else if Form.BorderStyle in [bsToolWindow, bsSizeToolWin] then
      if Form.Active then
        Element := twSmallCaptionActive
      else
        Element := twSmallCaptionInactive
    else
      if Form.Active then
        Element := twCaptionActive
      else
        Element := twCaptionInactive;
    DoTextOut;
    if IsVistaAndMaximized then DoTextOut;
  Finally
    CloseThemeData(ThemeData);
  end;
end;

function GetDwmBorderIconsRect(Form: TForm): TRect;
begin
  if DwmGetWindowAttribute(Form.Handle, DWMWA_CAPTION_BUTTON_BOUNDS, @Result, SizeOf(Result)) <> S_OK then SetRectEmpty(Result);
end;

procedure DrawGlassCaption(Form: TForm; var R: TRect;
  HorzAlignment: TAlignment = taLeftJustify; VertAlignment: TTextLayout =  tlCenter;
  ShowAccel: Boolean = False); overload;
begin
  DrawGlassCaption(Form, Form.Caption, clDefault, R,
    HorzAlignment, VertAlignment, ShowAccel);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  R: TRect;
begin
  if DwmCompositionEnabled then
  begin
    SetRectEmpty(R);
    AdjustWindowRectEx(R, GetWindowLong(Handle, GWL_STYLE), False,
      GetWindowLong(Handle, GWL_EXSTYLE));
    FWndFrameSize := R.Right;
    GlassFrame.Top := -R.Top;
    GlassFrame.Enabled := True;
    SetWindowPos(Handle, 0, Left, Top, Width, Height, SWP_FRAMECHANGED);
    DoubleBuffered := True;
  end;
end;

procedure TForm1.InvalidateTitleBar;
var
  R: TRect;
begin
  if not HandleAllocated then Exit;
  R.Left := 0;
  R.Top := 0;
  R.Right := Width;
  R.Bottom := GlassFrame.Top;
  InvalidateRect(Handle, @R, False);
end;

procedure TForm1.CMTextChanged(var Message: TMessage);
begin
  inherited;
  InvalidateTitleBar;
end;

procedure TForm1.WMActivate(var Message: TWMActivate);
begin
  inherited;
  InvalidateTitleBar;
end;

procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
  ClientPos: TPoint;
  IconRect: TRect;
begin
  inherited;
  if not GlassFrame.Enabled then Exit;
  case Message.Result of
    HTCLIENT:
    HTMINBUTTON, HTMAXBUTTON, HTCLOSE:
    begin
      Message.Result := HTCAPTION; 
      Exit;
    end;
  else
    Exit;
  end;
  ClientPos := ScreenToClient(Point(Message.XPos, Message.YPos));
  if ClientPos.Y > GlassFrame.Top then Exit;
  if ControlAtPos(ClientPos, True) <> nil then Exit;
  IconRect := GetSysIconRect;
  if (ClientPos.X < IconRect.Right) and ((WindowState = wsMaximized) or
   ((ClientPos.Y >= IconRect.Top) and (ClientPos.Y < IconRect.Bottom))) then
    Message.Result := HTSYSMENU
  else if ClientPos.Y < FWndFrameSize then
    Message.Result := HTTOP
  else
    Message.Result := HTCAPTION;
end;

procedure ShowSystemMenu(Form: TForm; const Message: TWMNCRButtonUp);
var
  Cmd: WPARAM;
  Menu: HMENU;

  procedure UpdateItem(ID: UINT; Enable: Boolean; MakeDefaultIfEnabled: Boolean = False);
  const
    Flags: array[Boolean] of UINT = (MF_GRAYED, MF_ENABLED);
  begin
    EnableMenuItem(Menu, ID, MF_BYCOMMAND or Flags[Enable]);
    if MakeDefaultIfEnabled and Enable then
      SetMenuDefaultItem(Menu, ID, MF_BYCOMMAND);
  end;

begin
  Menu := GetSystemMenu(Form.Handle, False);
  if Form.BorderStyle in [bsSingle, bsSizeable, bsToolWindow, bsSizeToolWin] then
  begin
    SetMenuDefaultItem(Menu, UINT(-1), 0);
    UpdateItem(SC_RESTORE, Form.WindowState <> wsNormal, True);
    UpdateItem(SC_MOVE, Form.WindowState <> wsMaximized);
    UpdateItem(SC_SIZE, (Form.WindowState <> wsMaximized) and
      (Form.BorderStyle in [bsSizeable, bsSizeToolWin]));
    UpdateItem(SC_MINIMIZE, (biMinimize in Form.BorderIcons) and
      (Form.BorderStyle in [bsSingle, bsSizeable]));
    UpdateItem(SC_MAXIMIZE, (biMaximize in Form.BorderIcons) and
      (Form.BorderStyle in [bsSingle, bsSizeable]) and
      (Form.WindowState <> wsMaximized), True);
  end;
  if Message.HitTest = HTSYSMENU then
    SetMenuDefaultItem(Menu, SC_CLOSE, MF_BYCOMMAND);
  Cmd := WPARAM(TrackPopupMenu(Menu, TPM_RETURNCMD or
    GetSystemMetrics(SM_MENUDROPALIGNMENT), Message.XCursor,
    Message.YCursor, 0, Form.Handle, nil));
  PostMessage(Form.Handle, WM_SYSCOMMAND, Cmd, 0)
end;

procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosChanging);
const
  SWP_STATECHANGED = $8000;
begin
  if GlassFrame.Enabled then
    if (Message.WindowPos.flags and SWP_STATECHANGED) = SWP_STATECHANGED then
      Invalidate
  else
      InvalidateTitleBar;
  inherited;
end;

procedure TForm1.WMNCRButtonUp(var Message: TWMNCRButtonUp);
begin
  if not GlassFrame.Enabled or not (biSystemMenu in BorderIcons) then
    inherited
  else
    case Message.HitTest of
      HTCAPTION, HTSYSMENU: ShowSystemMenu(Self, Message);
    else
      inherited;
  end;
end;

procedure TForm1.WndProc(var Message: TMessage);  
begin
  if GlassFrame.Enabled and HandleAllocated and DwmDefWindowProc(Handle,
    Message.Msg, Message.WParam, Message.LParam, Message.Result) then
    Exit;
  inherited;
end;

procedure TForm1.PaintWindow(DC: HDC);
begin
  with GetClientRect do
    ExcludeClipRect(DC, 0, GlassFrame.Top, Right, Bottom);
  inherited;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  IconHandle: HICON;
  R: TRect; 
begin
  if ImageList1.Count = 0 then
  begin
    ImageList1.Width := GetSystemMetrics(SM_CXSMICON);
    ImageList1.Height := GetSystemMetrics(SM_CYSMICON);
    {$IF NOT DECLARED(TColorDepth)}
    ImageList1.Handle := ImageList_Create(ImageList1.Width,
      ImageList1.Height, ILC_COLOR32 or ILC_MASK, 1, 1);
    {$IFEND}
    IconHandle := Icon.Handle;
    if IconHandle = 0 then IconHandle := Application.Icon.Handle;
    ImageList_AddIcon(ImageList1.Handle, IconHandle);
  end;
  R := GetSysIconRect;
  ImageList1.Draw(Canvas, R.Left, R.Top, 0);
  R.Left := R.Right + FWndFrameSize - 3;
  if WindowState = wsMaximized then
    R.Top := FWndFrameSize
  else
   R.Top := 0;
  R.Right := GetDwmBorderIconsRect(Self).Left - FWndFrameSize - 1;
  R.Bottom := GlassFrame.Top;
  DrawGlassCaption(Self, R);
end;

function TForm1.GetSysIconRect: TRect;
begin
  if not (biSystemMenu in BorderIcons) or not (BorderStyle in [bsSingle, bsSizeable]) then
    SetRectEmpty(Result)
  else
  begin
    Result.Left := 0;
    Result.Right := GetSystemMetrics(SM_CXSMICON);
    Result.Bottom := GetSystemMetrics(SM_CYSMICON);
    if WindowState = wsMaximized then
      Result.Top := GlassFrame.Top - Result.Bottom - 2
    else
      Result.Top := 6;
    Inc(Result.Bottom, Result.

delphi,delphi-2010,dwm,

1

`Ответов: 1`

Дельфи, Дельфи-2010, DWM,

Похожие вопросы

score 2 · Accepted Answer

2 принят

Стандартные кнопки не работают, потому что ваш WM_NCHITTESTобработчик возвращается HTCAPTIONдля них. Вы лжете Windows, говоря, что мышь не над кнопками, даже если это действительно так. Если унаследованный обработчик вернется HTMINBUTTON, HTMAXBUTTONили HTCLOSEпросто выйдите без изменения Message.Result:

procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
  ClientPos: TPoint;
  IconRect: TRect;
begin
  inherited;
  if not GlassFrame.Enabled then Exit;
  case Message.Result of
    HTCLIENT:
    HTMINBUTTON, HTMAXBUTTON, HTCLOSE:
    begin
      //Message.Result := HTCAPTION; // <-- here
      Exit;
    end;
  else
    Exit;
  end;
  ...
end;