unit SpTBXFormPopupMenu; {============================================================================== Version 2.4.4 The contents of this file are subject to the SpTBXLib License; you may not use or distribute this file except in compliance with the SpTBXLib License. A copy of the SpTBXLib License may be found in SpTBXLib-LICENSE.txt or at: http://www.silverpointdevelopment.com/sptbxlib/SpTBXLib-LICENSE.htm Alternatively, the contents of this file may be used under the terms of the Mozilla Public License Version 1.1 (the "MPL v1.1"), in which case the provisions of the MPL v1.1 are applicable instead of those in the SpTBXLib License. A copy of the MPL v1.1 may be found in MPL-LICENSE.txt or at: http://www.mozilla.org/MPL/ If you wish to allow use of your version of this file only under the terms of the MPL v1.1 and not to allow others to use your version of this file under the SpTBXLib License, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the MPL v1.1. If you do not delete the provisions above, a recipient may use your version of this file under either the SpTBXLib License or the MPL v1.1. Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License. The initial developer of this code is Robert Lee. Requirements: For Delphi/C++Builder 2009 or newer: - Jordan Russell's Toolbar 2000 http://www.jrsoftware.org For Delphi/C++Builder 7-2007: - Jordan Russell's Toolbar 2000 http://www.jrsoftware.org - Troy Wolbrink's TNT Unicode Controls http://www.tntware.com/delphicontrols/unicode/ History: 2 December 2009 - version 2.4.4 - Added AutoSize property to TSpTBXFormPopupMenu. 13 September 2009 - version 2.4.3 - No changes. 8 May 2009 - version 2.4.2 - No changes. 15 March 2009 - version 2.4.1 - No changes. 17 January 2009 - version 2.4 - Fixed incorrect focus handling on TSpTBXFormPopupMenu, when a dialog is showed on top of a TSpTBXFormPopupMenu and the app is deactivated the Popup is closed but the dialog stays, thanks to Sertac Akyuz for reporting this. 26 September 2008 - version 2.3 - No changes. 29 July 2008 - version 2.2 - No changes. 26 June 2008 - version 2.1 - No changes. 3 May 2008 - version 2.0 - No changes. 2 April 2008 - version 1.9.5 - No changes. 3 February 2008 - version 1.9.4 - No changes. 19 January 2008 - version 1.9.3 - No changes. 26 December 2007 - version 1.9.2 - Fixed incorrect focus handling on TSpTBXFormPopupMenu, thanks to Costas Stergiou for reporting this. 1 December 2007 - version 1.9.1 - Removed TBX dependency. 20 November 2007 - version 1.9 - Removed TBX dependency. 8 February 2007 - version 1.8.3 - No changes. 17 December 2006 - version 1.8.2 - No changes. 24 November 2006 - version 1.8.1 - Fixed TSpTBXFormPopupMenu resizing flicker. 27 August 2006 - version 1.8 - Initial release. ==============================================================================} interface {$BOOLEVAL OFF} // Unit depends on short-circuit boolean evaluation {$I TB2Ver.inc} uses Windows, Messages, Classes, SysUtils, Controls, Graphics, ImgList, Forms, Menus, StdCtrls, TB2Item, TB2Anim, SpTBXSkins, SpTBXItem; const WM_SPTBX_POPUPINVALIDATE = WM_USER + 887; WM_SPTBX_POPUPROLLUP = WM_USER + 888; type TSpTBXFormPopupMenu = class; TSpTBXCustomWrapperPopupForm = class; TSpTBXPopupAnimationType = ( patNone, patSlide, patFade ); TSpTBXPopupBorderStyleType = ( pbsFrame, pbsSizeable, pbsSizeableBottom, pbsSizeableRightBottom ); TSpTBXPopupFormState = record PopupForm: TCustomForm; BorderStyle: TFormBorderStyle; BoundsRect: TRect; end; TSpTBXRollDownEvent = procedure(Sender: TObject; var FormWidth, FormHeight: Integer) of object; TSpTBXRollUpEvent = procedure(Sender: TObject; Selected: Boolean) of object; TSpTBXGetFormClassEvent = procedure(Sender: TObject; var AFormClass: TCustomFormClass) of object; { TSpTBXPopupSizeGrip } TSpTBXPopupSizeGrip = class(TWinControl) private FSkinType: TSpTBXSkinType; FOnDrawBackground: TSpTBXDrawEvent; procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR; procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; protected FPopupForm: TSpTBXCustomWrapperPopupForm; procedure DoDrawBackground(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage; var PaintDefault: Boolean); procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; public constructor Create(AOwner: TComponent); override; function GetGripRect: TRect; function GetGripSizerRect: TRect; function IsScreenPointInGrip(P: TPoint): Boolean; published property SkinType: TSpTBXSkinType read FSkinType write FSkinType default sknSkin; property OnDrawBackground: TSpTBXDrawEvent read FOnDrawBackground write FOnDrawBackground; end; { TSpTBXWrapperPopupForm } TSpTBXCustomWrapperPopupForm = class(TCustomForm) private FHooksInstalled: Boolean; FOldAppOnMessage: TMessageEvent; FOldPopupControlWndProc: TWndMethod; FShowShadows: Boolean; FAnimation: TSpTBXPopupAnimationType; FAnimationDirection: TTBAnimationDirection; FBorderStyle: TSpTBXPopupBorderStyleType; FOnRollDown: TNotifyEvent; FOnRollUp: TSpTBXRollUpEvent; procedure SetBorderStyle(const Value: TSpTBXPopupBorderStyleType); procedure InstallHooks; procedure UninstallHooks; procedure CMChildKey(var Message: TCMChildKey); message CM_CHILDKEY; procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE; procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE; procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; procedure WMPrint(var Message: TMessage); message WM_PRINT; procedure WMSpTBXPopupInvalidate(var Message: TMessage); message WM_SPTBX_POPUPINVALIDATE; procedure WMSpTBXPopupRollUp(var Message: TMessage); message WM_SPTBX_POPUPROLLUP; protected FPopupControl: TControl; FFormPopupMenu: TSpTBXFormPopupMenu; FPaintingClientArea: Boolean; FSizeGrip: TSpTBXPopupSizeGrip; procedure CreateParams(var Params: TCreateParams); override; procedure PaintBackground(ACanvas: TCanvas; ARect: TRect); virtual; abstract; function GetSysAnimation: TSpTBXPopupAnimationType; procedure AppOnMessageHook(var Msg: TMsg; var Handled: Boolean); virtual; procedure PopupControlWindowProc(var Message: TMessage); virtual; procedure DoRollDown; virtual; procedure DoRollUp(Selected: Boolean); virtual; property Animation: TSpTBXPopupAnimationType read FAnimation write FAnimation; property AnimationDirection: TTBAnimationDirection read FAnimationDirection write FAnimationDirection default []; property BorderStyle: TSpTBXPopupBorderStyleType read FBorderStyle write SetBorderStyle default pbsFrame; property ShowShadows: Boolean read FShowShadows write FShowShadows default True; property OnRollDown: TNotifyEvent read FOnRollDown write FOnRollDown; property OnRollUp: TSpTBXRollUpEvent read FOnRollUp write FOnRollUp; public constructor Create(AFormPopupMenu: TSpTBXFormPopupMenu); reintroduce; virtual; destructor Destroy; override; procedure RollDown(X, Y, AWidth, AHeight: Integer; FocusPopup: Boolean = True); overload; virtual; procedure RollDown(APopupControl: TControl; AWidth, AHeight: Integer; IsVertical: Boolean = False; FocusPopup: Boolean = True); overload; virtual; procedure RollUp(Selected: Boolean; FocusParentControl: Boolean = True); virtual; property FormPopupMenu: TSpTBXFormPopupMenu read FFormPopupMenu; end; TSpTBXWrapperPopupForm = class(TSpTBXCustomWrapperPopupForm) private FSkinType: TSpTBXSkinType; procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED; procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; procedure SetSkinType(const Value: TSpTBXSkinType); protected procedure DestroyWindowHandle; override; procedure PaintBackground(ACanvas: TCanvas; ARect: TRect); override; public constructor Create(AFormPopupMenu: TSpTBXFormPopupMenu); override; destructor Destroy; override; published property Height; property Width; property BorderStyle; property ShowShadows; property OnRollDown; property OnRollUp; property SkinType: TSpTBXSkinType read FSkinType write SetSkinType default sknSkin; end; { TSpTBXFormPopupMenu } TSpTBXFormPopupMenu = class(TPopupMenu, ISpTBXPopupMenu) private FAutoSize: Boolean; FItems: Boolean; FNotifies: TList; FPopupFocus: Boolean; FPopupFormState: TSpTBXPopupFormState; FPopupFormPrevSize: TSize; FSkinType: TSpTBXSkinType; FOnClosePopup: TSpTBXRollUpEvent; FOnBeforeClosePopup: TSpTBXRollUpEvent; FOnBeforePopup: TSpTBXRollDownEvent; FOnGetPopupFormClass: TSpTBXGetFormClassEvent; function GetBorderStyle: TSpTBXPopupBorderStyleType; function GetShowShadows: Boolean; procedure SetBorderStyle(const Value: TSpTBXPopupBorderStyleType); procedure SetShowShadows(const Value: Boolean); procedure SetPopupForm(const Value: TCustomForm); procedure SetSkinType(const Value: TSpTBXSkinType); protected FPopupForm: TCustomForm; FWrapperForm: TSpTBXWrapperPopupForm; // Container of FPopupForm procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure BroadcastCloseMessage(Selected: Boolean); procedure DoGetPopupFormClass(var AFormClass: TCustomFormClass); virtual; function InternalPopup(X, Y: Integer; ForceFocus: Boolean; PopupControl: TControl = nil): Boolean; virtual; procedure InternalClosePopup(Sender: TObject; Selected: Boolean); virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Popup(X: Integer; Y: Integer); override; procedure PopupEx(X, Y: Integer; ForceFocus: Boolean); overload; procedure PopupEx(PopupControl: TControl; ForceFocus: Boolean); overload; procedure AddCloseNotification(AObject: TObject); procedure RemoveCloseNotification(AObject: TObject); procedure ClosePopup(Selected: Boolean); property PopupForm: TCustomForm read FPopupForm write SetPopupForm; published property Items: Boolean read FItems; // Hide the Items property property AutoSize: Boolean read FAutoSize write FAutoSize default False; property BorderStyle: TSpTBXPopupBorderStyleType read GetBorderStyle write SetBorderStyle default pbsFrame; property PopupFocus: Boolean read FPopupFocus write FPopupFocus default False; property ShowShadows: Boolean read GetShowShadows write SetShowShadows default True; property SkinType: TSpTBXSkinType read FSkinType write SetSkinType default sknSkin; property OnClosePopup: TSpTBXRollUpEvent read FOnClosePopup write FOnClosePopup; property OnBeforeClosePopup: TSpTBXRollUpEvent read FOnBeforeClosePopup write FOnBeforeClosePopup; property OnBeforePopup: TSpTBXRollDownEvent read FOnBeforePopup write FOnBeforePopup; property OnGetPopupFormClass: TSpTBXGetFormClassEvent read FOnGetPopupFormClass write FOnGetPopupFormClass; end; var ActiveFormPopupMenu: TSpTBXFormPopupMenu = nil; implementation uses Themes, UxTheme, Types, TB2Common, TB2Acc; const DefaultBorderSize = 2; type TCustomFormAccess = class(TCustomForm); //WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM { TSpTBXPopupSizeGrip } constructor TSpTBXPopupSizeGrip.Create(AOwner: TComponent); begin inherited; if Assigned(AOwner) and (AOwner is TSpTBXCustomWrapperPopupForm) then FPopupForm := AOwner as TSpTBXCustomWrapperPopupForm; FSkinType := sknSkin; Align := alBottom; Height := 10; end; procedure TSpTBXPopupSizeGrip.DoDrawBackground(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage; var PaintDefault: Boolean); begin if Assigned(FOnDrawBackground) then FOnDrawBackground(Self, ACanvas, ARect, PaintStage, PaintDefault); end; function TSpTBXPopupSizeGrip.GetGripRect: TRect; begin // Return the rect of the area that is sizeable. // If BorderStyle = pbsSizeableRightBottom the sizeable area is the // bottom right corner, when BorderStyle = pbsSizeableRightBottom the // sizeable area is the client rect of the SizeGrip Result := Rect(0, 0, 0, 0); if not (csDestroying in ComponentState) and Assigned(FPopupForm) and (FPopupForm.FBorderStyle in [pbsSizeableBottom, pbsSizeableRightBottom]) then begin Result := ClientRect; if FPopupForm.BorderStyle = pbsSizeableRightBottom then Result := GetGripSizerRect else Result := ClientRect; end; end; function TSpTBXPopupSizeGrip.GetGripSizerRect: TRect; begin // Return the rect of the grip sizer, the area that has the // dots on the sizer. Result := Rect(0, 0, 0, 0); if not (csDestroying in ComponentState) and Assigned(FPopupForm) then begin case FPopupForm.BorderStyle of pbsSizeableBottom: begin Result := ClientRect; Result.Left := (Result.Right + Result.Left - 20) div 2; Result.Right := Result.Left + 20; end; pbsSizeableRightBottom: begin Result := ClientRect; Result.Left := Result.Right - 14; end; end; end; end; function TSpTBXPopupSizeGrip.IsScreenPointInGrip(P: TPoint): Boolean; var GR: TRect; begin Result := False; P := ScreenToClient(P); GR := GetGripRect; if not IsRectEmpty(GR) and PtInRect(GR, P) then Result := True; end; procedure TSpTBXPopupSizeGrip.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var P: TPoint; const SC_SizeDown = $F006; SC_SizeDownRight = $F008; begin // Resize the StatusBar if the parent is TSpTBXTitleBar if not (csDesigning in ComponentState) and (Button = mbLeft) and Assigned(FPopupForm) then begin P := ClientToScreen(Point(X, Y)); if IsScreenPointInGrip(P) then begin ReleaseCapture; case FPopupForm.BorderStyle of pbsSizeableBottom: SendMessage(FPopupForm.Handle, WM_SYSCOMMAND, SC_SizeDown, 0); pbsSizeableRightBottom: SendMessage(FPopupForm.Handle, WM_SYSCOMMAND, SC_SizeDownRight, 0); end; Exit; end; end; inherited; end; procedure TSpTBXPopupSizeGrip.WMEraseBkgnd(var Message: TWMEraseBkgnd); var ACanvas: TCanvas; PaintDefault: Boolean; R, GR, CellR: TRect; C1, C2: TColor; T: TSpTBXSkinType; begin Message.Result := 1; if (csDestroying in ComponentState) then Exit; ACanvas := TCanvas.Create; ACanvas.Handle := Message.DC; try R := ClientRect; T := SpTBXSkinType(FSkinType); // Draw the background PaintDefault := True; DoDrawBackground(ACanvas, R, pstPrePaint, PaintDefault); if PaintDefault then begin GR := Rect(0, 0, 0, 0); SpDrawXPStatusBar(ACanvas, R, GR, T); end; // Draw the grip PaintDefault := True; DoDrawBackground(ACanvas, R, pstPostPaint, PaintDefault); if PaintDefault then begin C1 := SkinManager.CurrentSkin.Options(skncStatusBarGrip).Body.Color1; if (C1 = clNone) or (T <> sknSkin) then C1 := clBtnShadow; C2 := SkinManager.CurrentSkin.Options(skncStatusBarGrip).Body.Color2; if (C2 = clNone) or (T <> sknSkin) then C2 := clBtnHighlight; // Grip cells are 4x4 pixels case FPopupForm.BorderStyle of pbsSizeableBottom: begin GR := GetGripSizerRect; CellR := GR; CellR.Top := (CellR.Top + CellR.Bottom - 4) div 2 + 1; CellR.Bottom := CellR.Top + 3; SpDrawXPGrip(ACanvas, CellR, C1, C2); end; pbsSizeableRightBottom: begin GR := GetGripSizerRect; CellR := GR; // Draw 2 cells at the bottom CellR.Left := GR.Right - 8; CellR.Top := CellR.Bottom - 4; SpDrawXPGrip(ACanvas, CellR, C1, C2); // Draw 1 cell at the top CellR.Bottom := CellR.Top; CellR.Top := CellR.Bottom - 4; CellR.Left := CellR.Left + 4; SpDrawXPGrip(ACanvas, CellR, C1, C2); end; end; end; finally ACanvas.Handle := 0; ACanvas.Free; end; end; procedure TSpTBXPopupSizeGrip.WMSetCursor(var Message: TWMSetCursor); var P: TPoint; begin if not (csDesigning in ComponentState) and (Message.CursorWnd = Handle) and (Screen.Cursor = crDefault) and Assigned(FPopupForm) then begin GetCursorPos(P); if IsScreenPointInGrip(P) then begin case FPopupForm.BorderStyle of pbsSizeableBottom: Windows.SetCursor(Screen.Cursors[-7]); pbsSizeableRightBottom: Windows.SetCursor(Screen.Cursors[-8]); end; Message.Result := 1; Exit; end; end; inherited; end; //WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM { TSpTBXCustomWrapperPopupForm } constructor TSpTBXCustomWrapperPopupForm.Create(AFormPopupMenu: TSpTBXFormPopupMenu); begin // Form doesn't have DFM info inherited CreateNew(nil); Visible := False; SetBounds(0, 0, 0, 0); FFormPopupMenu := AFormPopupMenu; FAnimation := GetSysAnimation; FAnimationDirection := []; FShowShadows := True; FSizeGrip := TSpTBXPopupSizeGrip.Create(Self); FSizeGrip.Parent := Self; end; procedure TSpTBXCustomWrapperPopupForm.CreateParams(var Params: TCreateParams); begin inherited; if not (csDesigning in ComponentState) then with Params do begin Style := WS_POPUP or WS_CLIPCHILDREN; // Add the thickframe on all the BorderStyles // We should handle the NC HitTest Style := Style or WS_THICKFRAME; ExStyle := WS_EX_TOPMOST or WS_EX_TOOLWINDOW; WindowClass.Style := WindowClass.Style or CS_SAVEBITS; if IsWindowsXP then WindowClass.Style := WindowClass.Style or CS_DROPSHADOW; end; end; destructor TSpTBXCustomWrapperPopupForm.Destroy; begin FreeAndNil(FSizeGrip); inherited; end; procedure TSpTBXCustomWrapperPopupForm.DoRollDown; begin if Assigned(FOnRollDown) then FOnRollDown(Self); end; procedure TSpTBXCustomWrapperPopupForm.DoRollUp(Selected: Boolean); begin if Assigned(FOnRollUp) then FOnRollUp(Self, Selected); end; function TSpTBXCustomWrapperPopupForm.GetSysAnimation: TSpTBXPopupAnimationType; const SPI_GETMENUFADE = $1012; var Animate: BOOL; begin Result := patNone; if SystemParametersInfo(SPI_GETMENUANIMATION, 0, @Animate, 0) and Animate then if SystemParametersInfo(SPI_GETMENUFADE, 0, @Animate, 0) and Animate then Result := patFade else Result := patSlide; end; procedure TSpTBXCustomWrapperPopupForm.RollDown(X, Y, AWidth, AHeight: Integer; FocusPopup: Boolean = True); begin if not Visible then begin ActiveFormPopupMenu := FFormPopupMenu; // Set global variable used by RollUp // If FPopupControl is nil we should use the ActiveForm to set focus on RollUp if not Assigned(FPopupControl) then FPopupControl := Screen.ActiveForm; // Increase the size of the form if the size grip is visible if FBorderStyle in [pbsSizeableBottom, pbsSizeableRightBottom] then begin FSizeGrip.Visible := True; AHeight := AHeight + FSizeGrip.Height; end else FSizeGrip.Visible := False; InstallHooks; HandleNeeded; // We need the handle to set the Bounds and deactivate Vista form thick borders SetBounds(X, Y, AWidth, AHeight); SpActivateDwmNC(Self, False); // Make sure it will be showed on top of all the forms/dialogs SetWindowPos(WindowHandle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE); Visible := True; if FocusPopup then SetFocus; DoRollDown; end; end; procedure TSpTBXCustomWrapperPopupForm.RollDown(APopupControl: TControl; AWidth, AHeight: Integer; IsVertical: Boolean = False; FocusPopup: Boolean = True); var P, Size: TPoint; begin if Assigned(APopupControl) and Assigned(APopupControl.Parent) then begin FPopupControl := APopupControl; // Increase the size of the form if the size grip is visible Size.X := AWidth; Size.Y := AHeight; if FBorderStyle in [pbsSizeableBottom, pbsSizeableRightBottom] then Size.Y := Size.Y + FSizeGrip.Height; P := SpCalcPopupPosition(0, 0, Size.X, Size.Y, APopupControl, IsVertical); RollDown(P.X, P.Y, AWidth, AHeight, FocusPopup); end; end; procedure TSpTBXCustomWrapperPopupForm.RollUp(Selected: Boolean; FocusParentControl: Boolean = True); var W: TWinControl; Msg: TMessage; begin // Instead of checking for Self.Visible check if the actual wrapped form // is visible. if FFormPopupMenu.PopupForm.Visible then begin UninstallHooks; if Assigned(FPopupControl) and (FPopupControl is TWinControl) then begin W := FPopupControl as TWinControl; if FocusParentControl and W.CanFocus then W.SetFocus; // Send a message to the PopupControl and it's children controls // to inform that the Popup was closed. Msg.Msg := CM_SPPOPUPCLOSE; Msg.WParam := Integer(Self); if Selected then Msg.LParam := 1 else Msg.LParam := 0; Msg.Result := 0; PostMessage(W.Handle, Msg.Msg, Msg.WParam, Msg.LParam); W.Broadcast(Msg); end; Visible := False; // Broadcast the close message to all the notifies if Assigned(ActiveFormPopupMenu) then ActiveFormPopupMenu.BroadcastCloseMessage(Selected); ActiveFormPopupMenu := nil; // Reset global variable FPopupControl := nil; DoRollUp(Selected); end; end; procedure TSpTBXCustomWrapperPopupForm.SetBorderStyle(const Value: TSpTBXPopupBorderStyleType); begin if FBorderStyle <> Value then FBorderStyle := Value; end; procedure TSpTBXCustomWrapperPopupForm.InstallHooks; begin if not FHooksInstalled then begin FHooksInstalled := True; // Needed to handle main form mouse clicks when the popup is visible FOldAppOnMessage := Application.OnMessage; Application.OnMessage := AppOnMessageHook; if Assigned(FPopupControl) then begin // Needed to handle focus changes when the popup is visible but the // ParentControl has the focus, like the Comboboxes FOldPopupControlWndProc := FPopupControl.WindowProc; FPopupControl.WindowProc := PopupControlWindowProc; end; end; end; procedure TSpTBXCustomWrapperPopupForm.UninstallHooks; begin if FHooksInstalled then begin FHooksInstalled := False; Application.OnMessage := FOldAppOnMessage; FOldAppOnMessage := nil; if Assigned(FPopupControl) then begin FPopupControl.WindowProc := FOldPopupControlWndProc; FOldPopupControlWndProc := nil; end; end; end; procedure TSpTBXCustomWrapperPopupForm.AppOnMessageHook(var Msg: TMsg; var Handled: Boolean); begin if Assigned(FOldAppOnMessage) then FOldAppOnMessage(Msg, Handled); if not IsWindowEnabled(Handle) then begin Handled := False; Exit; end; case Msg.message of CM_DEACTIVATE: begin // Rollup when the popup is deactivated // Instead of calling Rollup post a message so the // Application.OnMessage is processed before // the popup is closed, this is needed to handle // the mouse clicks on the main form PostMessage(Handle, WM_SPTBX_POPUPROLLUP, 0, 0); // Set FocusParentControl param to False end; WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN: // If the click was not on the popup, rollup and Handle the message if (GetCapture = 0) and (Msg.hwnd <> Handle) and not Windows.IsChild(Handle, Msg.hwnd) then if Assigned(FPopupControl) and not (FPopupControl is TCustomForm) and (FPopupControl is TWinControl) then begin if Msg.hwnd <> TWinControl(FPopupControl).Handle then begin Handled := True; RollUp(False); end; end else begin Handled := True; RollUp(False); end; WM_NCLBUTTONDOWN..WM_NCMBUTTONDBLCLK: // If the click was not on the popup, rollup and Handle the message if (Msg.hwnd <> Handle) and not Windows.IsChild(Handle, Msg.hwnd) then begin Handled := True; RollUp(False); end; end; end; procedure TSpTBXCustomWrapperPopupForm.PopupControlWindowProc(var Message: TMessage); begin if Assigned(FOldPopupControlWndProc) then FOldPopupControlWndProc(Message); if Visible then case Message.Msg of CM_FOCUSCHANGED: // Rollup when the popup is deactivated // Instead of calling Rollup post a message so the // Application.OnMessage is processed before // the popup is closed, this is needed to handle // the focus change on the main form PostMessage(Handle, WM_SPTBX_POPUPROLLUP, 0, 0); // Set FocusParentControl param to False CM_CHILDKEY: if Message.WParam = VK_ESCAPE then RollUp(False); // CM_CANCELMODE: // RollUp(False); end; end; procedure TSpTBXCustomWrapperPopupForm.CMCancelMode(var Message: TCMCancelMode); begin inherited; RollUp(False); end; procedure TSpTBXCustomWrapperPopupForm.CMChildKey(var Message: TCMChildKey); begin inherited; if Message.CharCode = VK_ESCAPE then RollUp(False); end; procedure TSpTBXCustomWrapperPopupForm.WMActivate(var Message: TWMActivate); begin inherited; if Message.Active = WA_INACTIVE then begin // Rollup when the popup is deactivated // Instead of calling Rollup post a message so the // Application.OnMessage is processed before // the popup is closed, this is needed to handle // the mouse clicks on the main form // PostMessage(Handle, WM_SPTBX_POPUPROLLUP, 0, 1); // ^ Not needed end else begin // When the popup is activated redraw the caption bar of the Main Form // And invalidate the client and non client area SendMessage(Message.ActiveWindow, WM_NCACTIVATE, 1, 0); // Post the invalidate message on Vista to repaint the form borders if SpIsWinVistaOrUp then PostMessage(Handle, WM_SPTBX_POPUPINVALIDATE, 0, 0); end; end; procedure TSpTBXCustomWrapperPopupForm.WMNCCalcSize(var Message: TWMNCCalcSize); begin Message.Result := 0; InflateRect(Message.CalcSize_Params^.rgrc[0], -DefaultBorderSize, -DefaultBorderSize); end; procedure TSpTBXCustomWrapperPopupForm.WMNCHitTest(var Message: TWMNCHitTest); var P: TPoint; GR: TRect; HitOnBorder: Boolean; begin inherited; HitOnBorder := Message.Result in [HTLEFT, HTTOP, HTTOPLEFT, HTTOPRIGHT, HTRIGHT, HTBOTTOM, HTBOTTOMLEFT, HTBOTTOMRIGHT]; if HitOnBorder then case FBorderStyle of pbsFrame: Message.Result := HTNOWHERE; pbsSizeableBottom: begin // Make the NC area resizeable Message.Result := HTNOWHERE; P := FSizeGrip.ScreenToClient(SmallPointToPoint(Message.Pos)); GR := FSizeGrip.GetGripRect; if P.Y >= GR.Top then Message.Result := HTBOTTOM; end; pbsSizeableRightBottom: begin // Make the NC area resizeable Message.Result := HTNOWHERE; P := FSizeGrip.ScreenToClient(SmallPointToPoint(Message.Pos)); GR := FSizeGrip.GetGripRect; if P.Y >= GR.Top then if P.X >= GR.Left then Message.Result := HTBOTTOMRIGHT; end; end; end; procedure PopupWindowNCPaintProc(Wnd: HWND; DC: HDC; AppData: TObject); // Paints the NC area and the client background, used by WMEraseBkgnd, WMNCPaint, WMPrint var ACanvas: TCanvas; R: TRect; PopupWindow: TSpTBXCustomWrapperPopupForm; begin ACanvas := TCanvas.Create; try ACanvas.Handle := DC; GetWindowRect(Wnd, R); OffsetRect(R, -R.Left, -R.Top); // If it's used by WM_ERASEBKGND offset the rect PopupWindow := TSpTBXCustomWrapperPopupForm(AppData); if PopupWindow.FPaintingClientArea then begin PopupWindow.FPaintingClientArea := False; OffsetRect(R, -DefaultBorderSize, -DefaultBorderSize); end; PopupWindow.PaintBackground(ACanvas, R); finally ACanvas.Handle := 0; ACanvas.Free; end; end; procedure TSpTBXCustomWrapperPopupForm.WMEraseBkgnd(var Message: TWMEraseBkgnd); begin // There's no need to call PopupWindowNCPaintProc here, because the // ClientArea is filled with the child Form Message.Result := 1; end; procedure TSpTBXCustomWrapperPopupForm.WMNCPaint(var Message: TMessage); var DC: HDC; begin DC := GetWindowDC(Handle); try FPaintingClientArea := False; SelectNCUpdateRgn(Handle, DC, HRGN(Message.WParam)); PopupWindowNCPaintProc(Handle, DC, Self); finally ReleaseDC(Handle, DC); end; end; procedure TSpTBXCustomWrapperPopupForm.WMPrint(var Message: TMessage); begin FPaintingClientArea := False; HandleWMPrint(Handle, Message, PopupWindowNCPaintProc, Self); end; procedure TSpTBXCustomWrapperPopupForm.WMSpTBXPopupInvalidate(var Message: TMessage); begin if HandleAllocated then RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN or RDW_FRAME); end; procedure TSpTBXCustomWrapperPopupForm.WMSpTBXPopupRollUp(var Message: TMessage); var Selected, FocusParentControl: Boolean; begin Selected := Message.WParam <> 0; FocusParentControl := Message.LParam <> 0; RollUp(Selected, FocusParentControl); end; //WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM { TSpTBXWrapperPopupForm } constructor TSpTBXWrapperPopupForm.Create(AFormPopupMenu: TSpTBXFormPopupMenu); begin inherited; FSkinType := sknSkin; end; destructor TSpTBXWrapperPopupForm.Destroy; begin Destroying; if HandleAllocated then DestroyWindowHandle; inherited; end; procedure TSpTBXWrapperPopupForm.DestroyWindowHandle; begin { Cleanly destroy any timers before the window handle is destroyed } CallNotifyWinEvent(EVENT_SYSTEM_MENUPOPUPEND, WindowHandle, OBJID_CLIENT, CHILDID_SELF); inherited; end; procedure TSpTBXWrapperPopupForm.CMShowingChanged(var Message: TMessage); const ShowFlags: array[Boolean] of UINT = ( SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_HIDEWINDOW, SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW); var Blend: Boolean; begin { Must override TCustomForm/TForm's CM_SHOWINGCHANGED handler so that the form doesn't get activated when Visible is set to True. } { Handle animation } if Showing and not IsWindowVisible(WindowHandle) and (Animation <> patNone) then begin Blend := Animation = patFade; if Assigned(AnimateWindowProc) and (Blend or (FAnimationDirection <> [])) then begin AnimateWindowProc(Handle, 150, AW_BLEND); RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN); Exit; end; end; { No animation... } SetWindowPos(WindowHandle, 0, 0, 0, 0, 0, ShowFlags[Showing]); RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN); end; procedure TSpTBXWrapperPopupForm.PaintBackground(ACanvas: TCanvas; ARect: TRect); begin SpDrawXPMenuPopupWindow(ACanvas, ARect, Rect(0, 0, 0, 0), False, 0, FSkinType); end; procedure TSpTBXWrapperPopupForm.SetSkinType(const Value: TSpTBXSkinType); begin if FSkinType <> Value then begin FSkinType := Value; FSizeGrip.SkinType := Value; end; end; procedure TSpTBXWrapperPopupForm.WMEraseBkgnd(var Message: TWMEraseBkgnd); begin Message.Result := 1; end; //WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM { TSpTBXFormPopupMenu } constructor TSpTBXFormPopupMenu.Create(AOwner: TComponent); begin inherited; FSkinType := sknSkin; FNotifies := TList.Create; FWrapperForm := TSpTBXWrapperPopupForm.Create(Self); FWrapperForm.OnRollUp := InternalClosePopup; end; destructor TSpTBXFormPopupMenu.Destroy; var FC: TCustomFormClass; begin if Assigned(FPopupForm) then FPopupForm.Parent := nil; // Free the PopupForm if the OnGetPopupFormClass event returns // a valid form class. FC := nil; DoGetPopupFormClass(FC); if Assigned(FC) then FreeAndNil(FPopupForm); FreeAndNil(FNotifies); FreeAndNil(FWrapperForm); inherited; end; procedure TSpTBXFormPopupMenu.DoGetPopupFormClass(var AFormClass: TCustomFormClass); begin if Assigned(FOnGetPopupFormClass) then FOnGetPopupFormClass(Self, AFormClass); end; procedure TSpTBXFormPopupMenu.AddCloseNotification(AObject: TObject); begin if Assigned(AObject) then if FNotifies.IndexOf(AObject) < 0 then FNotifies.Add(AObject); end; procedure TSpTBXFormPopupMenu.RemoveCloseNotification(AObject: TObject); begin FNotifies.Remove(AObject); end; procedure TSpTBXFormPopupMenu.BroadcastCloseMessage(Selected: Boolean); var Msg: TMessage; I: Integer; begin if FNotifies.Count > 0 then begin Msg.Msg := CM_SPPOPUPCLOSE; Msg.WParam := Integer(FWrapperForm); if Selected then Msg.LParam := 1 else Msg.LParam := 0; Msg.Result := 0; for I := 0 to FNotifies.Count - 1 do TObject(FNotifies[I]).Dispatch(Msg); end; end; procedure TSpTBXFormPopupMenu.ClosePopup(Selected: Boolean); begin // Instead of calling Rollup post a message so the Application.OnMessage is // processed before the popup is closed, this is needed to handle the mouse // clicks on the main form. PostMessage(FWrapperForm.Handle, WM_SPTBX_POPUPROLLUP, Integer(Selected), 1); end; procedure TSpTBXFormPopupMenu.InternalClosePopup(Sender: TObject; Selected: Boolean); var FC: TCustomFormClass; begin if Assigned(FOnBeforeClosePopup) then FOnBeforeClosePopup(Self, Selected); if Assigned(FPopupForm) then begin if FAutoSize then begin FPopupFormPrevSize.cx := FPopupForm.ClientRect.Right; FPopupFormPrevSize.cy := FPopupForm.ClientRect.Bottom; end; FPopupForm.Visible := False; FPopupForm.Parent := nil; FPopupForm.Align := alNone; if FPopupFormState.PopupForm = FPopupForm then begin FPopupForm.BorderStyle := FPopupFormState.BorderStyle; FPopupForm.BoundsRect := FPopupFormState.BoundsRect; end; end; if Assigned(FOnClosePopup) then FOnClosePopup(Self, Selected); // Free the PopupForm if the OnGetPopupFormClass event returns // a valid form class. FC := nil; DoGetPopupFormClass(FC); if Assigned(FC) then FreeAndNil(FPopupForm); end; function TSpTBXFormPopupMenu.InternalPopup(X, Y: Integer; ForceFocus: Boolean; PopupControl: TControl = nil): Boolean; var ClientR: TRect; FC: TCustomFormClass; begin Result := False; {$IFDEF JR_D9} SetPopupPoint(Point(X, Y)); {$ELSE} PPoint(@PopupPoint)^ := Point(X, Y); {$ENDIF} // Create the PopupForm if the OnGetPopupFormClass event returns // a valid form class. // Otherwise try to use the assigned PopupForm property. FC := nil; DoGetPopupFormClass(FC); if Assigned(FC) then FPopupForm := FC.Create(nil); // Use the WrapperForm to show the PopupForm if Assigned(FPopupForm) then begin FPopupFormState.PopupForm := FPopupForm; FPopupFormState.BorderStyle := FPopupForm.BorderStyle; FPopupFormState.BoundsRect := FPopupForm.BoundsRect; ClientR := FPopupForm.ClientRect; if FAutoSize and (FPopupFormPrevSize.cx > 0) and (FPopupFormPrevSize.cy > 0) then begin ClientR.Right := FPopupFormPrevSize.cx; ClientR.Bottom := FPopupFormPrevSize.cy; end; FPopupForm.Parent := FWrapperForm; FPopupForm.Align := alClient; FPopupForm.BorderStyle := bsNone; FPopupForm.Visible := True; if Assigned(FOnBeforePopup) then FOnBeforePopup(Self, ClientR.Right, ClientR.Bottom); if Assigned(PopupControl) then FWrapperForm.RollDown(PopupControl, ClientR.Right + DefaultBorderSize * 2, ClientR.Bottom + DefaultBorderSize * 2, False, ForceFocus) else FWrapperForm.RollDown(X, Y, ClientR.Right + DefaultBorderSize * 2, ClientR.Bottom + DefaultBorderSize * 2, ForceFocus); if Assigned(OnPopup) then OnPopup(Self); Result := True; end; end; procedure TSpTBXFormPopupMenu.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if Operation = opRemove then if AComponent = PopupForm then begin // Weird Delphi IDE bug at design time. // When a Form is closed at design time it will fire the // FreeNotification, setting PopupForm to nil and not // saving it to the dfm SetPopupForm(nil); { TODO : Delphi IDE bug } // This line doesn't seem to fix it, it raises AVs in the IDE // PopupForm shouldn't be published. // if not (csDesigning in ComponentState) then // SetPopupForm(nil); end; end; procedure TSpTBXFormPopupMenu.Popup(X, Y: Integer); begin InternalPopup(X, Y, FPopupFocus); end; procedure TSpTBXFormPopupMenu.PopupEx(X, Y: Integer; ForceFocus: Boolean); begin InternalPopup(X, Y, ForceFocus); end; procedure TSpTBXFormPopupMenu.PopupEx(PopupControl: TControl; ForceFocus: Boolean); begin InternalPopup(0, 0, ForceFocus, PopupControl); end; function TSpTBXFormPopupMenu.GetBorderStyle: TSpTBXPopupBorderStyleType; begin Result := FWrapperForm.BorderStyle; end; function TSpTBXFormPopupMenu.GetShowShadows: Boolean; begin Result := FWrapperForm.ShowShadows; end; procedure TSpTBXFormPopupMenu.SetBorderStyle(const Value: TSpTBXPopupBorderStyleType); begin FWrapperForm.BorderStyle := Value; end; procedure TSpTBXFormPopupMenu.SetPopupForm(const Value: TCustomForm); begin if FPopupForm <> Value then begin if FWrapperForm.Visible then ClosePopup(False); if Assigned(FPopupForm) then FPopupForm.RemoveFreeNotification(Self); FPopupForm := Value; if Assigned(FPopupForm) then FPopupForm.FreeNotification(Self); end; end; procedure TSpTBXFormPopupMenu.SetShowShadows(const Value: Boolean); begin FWrapperForm.ShowShadows := Value; end; procedure TSpTBXFormPopupMenu.SetSkinType(const Value: TSpTBXSkinType); begin if FSkinType <> Value then begin FSkinType := Value; FWrapperForm.SkinType := Value; end; end; end.