{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: Lean UI Area classes. Windowed and window- | } { | less. Non-rect shapes supported. | } { | | } { | Copyright (C) - 2002 - Gerrit Moeller. | } { | | } { | Source code dstributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} unit GMUICore; interface uses {$IFDEF JEDIAPI}jwaWinType, jwaWinUser, jwaWinGdi,{$ELSE}Windows,{$ENDIF} // jwaWinNT, GMStrDef, GMMessages, GMIntf, GMCommon, GMCollections, GMGdi; type TEdge = (edgLeft, edgTop, edgRight, edgBottom); // <- must match order in TRect type for Left, Top, right, bottom properties! // to enable typecasting to TEdgeRectValue in Get/Set handlers for fast access. TEdgeRectValue = array [TEdge] of LongInt; PEdgeRectValue = ^TEdgeRectValue; TEdges = set of TEdge; TEdgeAlign = (ealFixed, ealAligned, ealCentered, ealWrap); // ealFixed: Edge is not changed, if zero is passed CalculateWidth/Height is called // ealAligned: Edge is set to parent edge, edge position is interpreted as space to parent edge // ealCentered: Edge is centered in parent extend, edge position is interpreted as space to center TEdgesAlign = array [TEdge] of TEdgeAlign; TGMLayoutEdgeOrderMap = array [TEdge] of TEdge; TGMAreaAlignRec = record EdgeAlign: TEdgesAlign; ShrinkRestX: Boolean; ShrinkRestY: Boolean; end; TFrameShape = (frsNone, frsLowered, frsRaised, frsSpace); TFrameKind = (frkNone, frkTile, frkSoft, frkFlat); TFrameScale = -1 .. 1; TGMAreaRegionKind = (arkBounds, arkClient); // Relayed messages will be re-send as Msg + WM_APP TRelayedMessage = (rlmWMCommand, rlmWMNotify, rlmWMScroll, rlmWMOwnerDraw); TRelayedMessages = set of TRelayedMessage; TGMDragControl = (drgLeave, drgCancel, drgFinished); TGMShowWndKind = (swShowNormal, swShowNoActivate, swHide, swShowMinimized, swShowMaximized); const {$IFDEF FPC} {$IFNDEF JEDIAPI} // gradient drawing modes {$EXTERNALSYM GRADIENT_FILL_RECT_H} GRADIENT_FILL_RECT_H = $00000000; {$EXTERNALSYM GRADIENT_FILL_RECT_V} GRADIENT_FILL_RECT_V = $00000001; {$EXTERNALSYM GRADIENT_FILL_TRIANGLE} GRADIENT_FILL_TRIANGLE = $00000002; {$EXTERNALSYM GRADIENT_FILL_OP_FLAG} GRADIENT_FILL_OP_FLAG = $000000ff; {$ENDIF} {$ENDIF} UM_USER = GM_USER + 100; //UM_CLOSE = GM_USER + 1; UM_HANDLECREATED = GM_USER + 2; //UM_SETTEMPCURSOR = GM_USER + 3; UM_CALCWIDTH = GM_USER + 4; UM_CALCHEIGHT = GM_USER + 5; UM_STARTMOUSETRACK = GM_USER + 6; UM_MOUSEENTER = GM_USER + 7; UM_MOUSELEAVE = GM_USER + 8; UM_SELECTNEXTDLGTABAREA = GM_USER + 9; UM_DRAG_QUERYDROP = GM_USER + 11; UM_DRAG_CONTROL = GM_USER + 12; UM_DRAG_DROPPED = GM_USER + 13; UM_LANGUAGECHANGED = GM_USER + 14; //cCannotClose = 0; cDfltWndText = ''; cDfltWndStyle = 0; cDfltWndExStyle = 0; cPrntWndExStyle = cDfltWndExStyle or WS_EX_CONTROLPARENT; cDfltWndMenu = 0; //cDfltWndParent = 0; cDfltDlgData = nil; cDfltColor = clrBtnFace; cMinimizedOrMaximized = WS_MAXIMIZE or WS_MINIMIZE; cMFEnable: array [Boolean] of DWORD = (MF_GRAYED, MF_ENABLED); cAllEdges = [Low(TEdge) .. High(TEdge)]; cEdgesX = [edgLeft, edgRight]; cEdgesY = [edgTop, edgBottom]; cEdgesLeftTop = [edgLeft, edgTop]; cEdgesRightBottom = [edgRight, edgBottom]; cSelectAll = 1; cInvalidLayoutVal = -1; cCalcSizeAlignments = [ealFixed, ealWrap]; //cQAlignMultiplier = 10000; cQAlign = 100000; cQAlignDivisor = cQAlign * 10000; // Some useful area alignments cFixedPlace: TGMAreaAlignRec = (EdgeAlign: (ealFixed, ealFixed, ealFixed, ealFixed); ShrinkRestX: False; ShrinkRestY: False); cTopAligned: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealAligned, ealAligned, ealFixed); ShrinkRestX: False; ShrinkRestY: True); cBottomAligned: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealFixed, ealAligned, ealAligned); ShrinkRestX: False; ShrinkRestY: True); cLeftAligned: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealAligned, ealFixed, ealAligned); ShrinkRestX: True; ShrinkRestY: False); cRightAligned: TGMAreaAlignRec = (EdgeAlign: (ealFixed, ealAligned, ealAligned, ealAligned); ShrinkRestX: True; ShrinkRestY: False); cClientAligned: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealAligned, ealAligned, ealAligned); ShrinkRestX: False; ShrinkRestY: False); cTopLeftCorner: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealAligned, ealFixed, ealFixed); ShrinkRestX: False; ShrinkRestY: False); cTopRightCorner: TGMAreaAlignRec = (EdgeAlign: (ealFixed, ealAligned, ealAligned, ealFixed); ShrinkRestX: False; ShrinkRestY: False); cBottomRightCorner: TGMAreaAlignRec = (EdgeAlign: (ealFixed, ealFixed, ealAligned, ealAligned); ShrinkRestX: False; ShrinkRestY: False); cBottomLeftCorner: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealFixed, ealFixed, ealAligned); ShrinkRestX: False; ShrinkRestY: False); cTopLeftX: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealAligned, ealFixed, ealFixed); ShrinkRestX: True; ShrinkRestY: False); cTopLeftY: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealAligned, ealFixed, ealFixed); ShrinkRestX: False; ShrinkRestY: True); cTopRightX: TGMAreaAlignRec = (EdgeAlign: (ealFixed, ealAligned, ealAligned, ealFixed); ShrinkRestX: True; ShrinkRestY: False); cTopRightY: TGMAreaAlignRec = (EdgeAlign: (ealFixed, ealAligned, ealAligned, ealFixed); ShrinkRestX: False; ShrinkRestY: True); cBottomLeftX: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealFixed, ealFixed, ealAligned); ShrinkRestX: True; ShrinkRestY: False); cBottomLeftY: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealFixed, ealFixed, ealAligned); ShrinkRestX: False; ShrinkRestY: True); cBottomRightX: TGMAreaAlignRec = (EdgeAlign: (ealFixed, ealFixed, ealAligned, ealAligned); ShrinkRestX: True; ShrinkRestY: False); cBottomRightY: TGMAreaAlignRec = (EdgeAlign: (ealFixed, ealFixed, ealAligned, ealAligned); ShrinkRestX: False; ShrinkRestY: True); cWrapRightY: TGMAreaAlignRec = (EdgeAlign: (ealAligned, ealAligned, ealWrap, ealFixed); ShrinkRestX: False; ShrinkRestY: True); cDfltRelayedMessages = [Low(TRelayedMessage) .. High(TRelayedMessage)]; cDfltWndAnimation = AW_BLEND; // AW_CENTER; AW_BLEND cDfltWndAniDuration = 250; //275 300; // WS_CLIPCHILDREN causes problems with page control and decreases paint performance cDlgBaseStyle = WS_CAPTION or WS_BORDER; // or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_DLGFRAME cFixedDlgWndStyle = cDlgBaseStyle or WS_SYSMENU; cSizeDlgWndStyle = cDlgBaseStyle or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SIZEBOX; // or WS_THICKFRAME; cWSDisabled: array [Boolean] of DWORD = (0, WS_DISABLED); cVisibleTabstop = WS_VISIBLE or WS_TABSTOP; cBtnKindMask = $F; cFrameLines: array [TFrameShape] of LongInt = (0, 1, 1, 1); cWndObjPtrData = GWLP_USERDATA; //GWL_ID; GWLP_USERDATA //cShowWndFlag: array [Boolean] of LongInt = (SW_HIDE, SW_SHOW); cWinPosRedraw: array [Boolean] of DWORD = (SWP_NOREDRAW, 0); cWSVisible: array [Boolean] of DWORD = (0, WS_VISIBLE); cSWShow: array [Boolean] of DWORD = (SW_HIDE, SW_SHOW); cShowWndFlags: array [TGMShowWndKind] of DWORD = (SW_SHOWNORMAL, SW_SHOWNA, SW_HIDE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED); IDC_GMHSPLIT = 'GMHSplitCursor'; // PGMChar(32764); IDC_GMVSPLIT = 'GMVSplitCursor'; // PGMChar(32765); //IDC_GMDRAGCOPY = 'GMDragCopyCursor'; // PGMChar(32766); cResTextRefPrefix: TGMString = '#!$'; cResTextFmtSeparator: TGMChar = '#'; cNoSizeCnstr = 0; cSizeCnstrNoChange = Low(LongInt); //cAllMouseMsgMask: set of Byte = [0, 1]; cLayeredWndFlag: array [Boolean] of DWORD = (0, WS_EX_LAYERED); type RGMResTextRefData = record ResStringPtr: PResStringRec; FormatStr: TGMString; end; SGMKeyStates = set of (ksShift, ksCtrl, ksAlt); TGMWndObj = Int64; TGMWndMsg = LongWord; //IGMWndMessage = interface(IUnknown) // ['{C180AF7B-37DA-4F76-B225-48ABB5071306}'] // function GetWndMessage: TGMWndMsg; // property WndMessage: TGMWndMsg read GetWndMessage; //end; //TGMWndMessageObj = class(TGMRefCountedObj, IGMWndMessage, IGMHashCode) // protected // FWndMessage: TGMWndMsg; // // public // constructor Create(const AWndMessage: TGMWndMsg; const ARefLifeTime: Boolean); reintroduce; // function GetWndMessage: TGMWndMsg; // function HashCode: TGMHashCode; //end; TGMSizeConstraintsRec = record case LongInt of 0: (MinWidth, MinHeight, MaxWidth, MaxHeight: LongInt); 1: (MinSize: TPoint; MaxSize: TPoint) end; PGMDragMessageRec = ^TGMDragMessageRec; TGMDragMessageRec = packed record Msg: UINT; {$IFDEF CPU64}Filler1: LongWord;{$ENDIF} XPos: Smallint; YPos: Smallint; {$IFDEF CPU64}Filler2: LongWord;{$ENDIF} DragData: IUnknown; Result: PtrInt; end; TGMWinMenu = class(TGMRefCountedObj, IGMGetHandle) protected FHandle: HMenu; function GetHandle: THandle; stdcall; //procedure CreateEntries; virtual; public constructor CreateMenu(const ARefLifeTime: Boolean = True); constructor CreatePopupMenu(const ARefLifeTime: Boolean = True); destructor Destroy; override; end; RGMWndCreateData = packed record WndStyle: DWORD; WndExStyle: DWORD; Text: TGMString; ParentWnd: HWnd; Menu: HMENU; end; TGMWindowClass = class(TGMRefCountedObj, IGMGetName) protected FWndClass: TWndClassEx; FWndClassName: TGMString; // <- memory allocation for RegisterWndClass FMenuName: TGMString; // <- memory allocation for menuname FRegisteredClass: ATOM; public constructor Create(const AWndClassName: TGMString; const AClassStyle: DWORD = 0; const AIcon: HICON = 0; const ACursor: HCURSOR = 0; const ABkgndBrush: HBRUSH = 0; const AMenuName: TGMString = ''; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; function ClassIsRegistered: Boolean; function GetName: TGMString; stdcall; property Name: TGMString read FWndClassName; end; IGMAreaFrameDrawer = interface(IUnknown) ['{83DBF669-B36C-40a2-962A-7FB6B32ED13E}'] procedure DrawFrame(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const AColor: COLORREF); function CalculateClientRect(const ABoundsRect: TRect; const AScale: TFrameScale = 1): TRect; end; IGMMultiFrameProperties = interface(IUnknown) ['{5F0E1DAD-3D5D-4c00-B227-A6EF2CC75D1E}'] function GetFrameKind: TFrameKind; function GetInnerFrame: TFrameShape; function GetOuterFrame: TFrameShape; function GetFramedEdges: TEdges; function GetOuterSpace: LongInt; function GetFrameLook3D: Boolean; procedure SetFrameKind(const Value: TFrameKind); procedure SetInnerFrame(const Value: TFrameShape); procedure SetOuterFrame(const Value: TFrameShape); procedure SetFramedEdges(const Value: TEdges); procedure SetOuterSpace(const Value: LongInt); procedure SetFrameLook3D(const Value: Boolean); property FrameKind: TFrameKind read GetFrameKind write SetFrameKind; property InnerFrame: TFrameShape read GetInnerFrame write SetInnerFrame; property OuterFrame: TFrameShape read GetOuterFrame write SetOuterFrame; property FramedEdges: TEdges read GetFramedEdges write SetFramedEdges; property OuterSpace: LongInt read GetOuterSpace write SetOuterSpace; property FrameLook3D: Boolean read GetFrameLook3D write SetFrameLook3D; end; IGMUiAreaFrame = interface(IUnknown) ['{0741BF81-E0EE-497A-83B8-707DAC3D5CDB}'] function GetFrame: IGMAreaFrameDrawer; procedure SetFrame(const AFrame: IGMAreaFrameDrawer); property Frame: IGMAreaFrameDrawer read GetFrame write SetFrame; end; TGMAreaMultiFrame = class(TGMRefCountedObj, IGMAreaFrameDrawer, IGMMultiFrameProperties) protected FFrameKind: TFrameKind; FInnerFrame: TFrameShape; FOuterFrame: TFrameShape; FFramedEdges: TEdges; FOuterSpace: LongInt; FFrameLook3D: Boolean; public // IGMMultiFrameProperties function GetFrameKind: TFrameKind; virtual; function GetInnerFrame: TFrameShape; virtual; function GetOuterFrame: TFrameShape; virtual; function GetFramedEdges: TEdges; virtual; function GetOuterSpace: LongInt; virtual; function GetFrameLook3D: Boolean; virtual; procedure SetFrameKind(const Value: TFrameKind); virtual; procedure SetInnerFrame(const Value: TFrameShape); virtual; procedure SetOuterFrame(const Value: TFrameShape); virtual; procedure SetFramedEdges(const Value: TEdges); virtual; procedure SetOuterSpace(const Value: LongInt); virtual; procedure SetFrameLook3D(const Value: Boolean); virtual; public constructor Create(const AReflifeTime: Boolean = True); reintroduce; function CalculateClientRect(const ABoundsRect: TRect; const AScale: TFrameScale = 1): TRect; virtual; //function Extend(const AEdges: TEdges = cAllEdges): TPoint; virtual; procedure DrawFrame(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const AColor: COLORREF); virtual; function EdgeWidth: LongInt; property FrameKind: TFrameKind read GetFrameKind write SetFrameKind; property InnerFrame: TFrameShape read GetInnerFrame write SetInnerFrame; property OuterFrame: TFrameShape read GetOuterFrame write SetOuterFrame; property FramedEdges: TEdges read GetFramedEdges write SetFramedEdges; property OuterSpace: LongInt read GetOuterSpace write SetOuterSpace; property FrameLook3D: Boolean read GetFrameLook3D write SetFrameLook3D; end; TGMAreaSimpleFrame = class(TGMRefCountedObj, IGMAreaFrameDrawer) protected FEdgeWidth: LongInt; FFramedEdges: TEdges; public constructor Create(const AEdgeWidth: LongInt = 1; const AFramedEdges: TEdges = cAllEdges; const AReflifeTime: Boolean = True); reintroduce; function CalculateClientRect(const ABoundsRect: TRect; const AScale: TFrameScale = 1): TRect; virtual; procedure DrawFrame(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const AColor: COLORREF); virtual; end; TGMAreaFakeFrame = class(TGMAreaSimpleFrame) public procedure DrawFrame(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const AColor: COLORREF); override; end; TGMAreaRegionFrame = class(TGMRefCountedObj, IGMAreaFrameDrawer) protected FFrameWidth, FFrameHeight: LongInt; public constructor Create(const AFrameWidth, AFrameHeight: LongInt; const AReflifeTime: Boolean = True); reintroduce; procedure DrawFrame(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const AColor: COLORREF); virtual; function CalculateClientRect(const ABoundsRect: TRect; const AScale: TFrameScale = 1): TRect; virtual; end; IGMGetSizeConstraints = interface(IUnknown) ['{26B7B511-1E51-47c4-8347-FF98122DABFF}'] function GetSizeContraints: TGMSizeConstraintsRec; end; IGMGetSetSizeConstraints = interface(IGMGetSizeConstraints) ['{26B7B511-1E51-47c4-8347-FF98122DABFF}'] procedure SetSizeContraints(const Value: TGMSizeConstraintsRec); end; IGMSetShowing = interface(IUnknown) ['{80B5A764-D144-4e35-88C9-6F546F2ADD84}'] procedure SetShowing(const Value: Boolean); end; IGMCalcAreaRegion = interface(IUnknown) ['{270D904B-EBF4-4D81-86DA-15288A2AC421}'] function CreateAreaRegion(const ABoundingRect: TRect; const ARegionKind: TGMAreaRegionKind): IGMGetHandle; end; IGMIsDefaultDlgBtn = interface(IUNknown) ['{774C8E43-C77A-46E2-8E6A-C86B6ACE743D}'] function IsDefaultDlgBtn: Boolean; procedure Click(const ASender: TObject = nil); end; IGMLanguageChanged = interface(IUNknown) ['{7CB496F0-83A0-4884-8A44-2983403B84CC}'] procedure LanguageChanged(const ANewLanguage: LPARAM); end; //IGMPaint = interface(IUnknown) // ['310DAC2E-45CA-472d-9C91-703CAA96D19F'] // function Paint(const ADC: HDC): Boolean; // <- return False to pass WM_PAINT to chained handlers too //end; //IGMIsTabStop = interface(IUnknown) // ['{88773B33-B60A-47B5-A3A0-6187A0FC1D19}'] // function IsTabstop: Boolean; //end; IGMMessageHandler = interface(IUnknown) ['{AB3B765C-C39F-4fd1-BB1D-60546C117FE4}'] procedure WindowProc(var Msg: TMessage); procedure DispatchMsg(var Msg: TMessage); end; IGMUiLayouter = interface(IUnknown) ['{F3857A7B-4C33-4454-9F4C-E9E5C6F01170}'] procedure LayoutContainedAreasIfNeeded(const ARepaint: Boolean); //: TPoint; end; IGMSetFonColor = interface(IUnknown) ['{C30F9B85-F641-44EC-B666-8C99C38A366E}'] procedure SetFontColor(const AColor: COLORREF); end; procedure GMSetFontColor(const AUIArea: IUnknown; const AColor: COLORREF); //IGMGetVisible = interface(IUnknown) // ['{70542EB9-376A-4179-B433-8DF3231FC484}'] // function GetVisible: Boolean; // property Visible: Boolean read GetVisible; // write SetVisible; //end; type IGMSetVisible = interface(IUnknown) ['{53849ADE-29C1-405f-A928-E81AD79F344A}'] procedure SetVisible(const Value: Boolean; const Relayout: Boolean = True); end; IGMUiArea = interface(IGMUiLayouter) ['{CB4FFF8D-8BF6-4522-BA2F-48F4D7FC1AE8}'] //function GetParentObj: TObject; stdcall; //procedure SetParentObj(const Value: TObject; const Relayout: Boolean = True); stdcall; function OwnArea(const Area: TObject): TObject; function ClientAreaSize: TPoint; function ClientAreaOrigin: TPoint; function GetVisible: Boolean; function GetAreaAlign: TGMAreaAlignRec; procedure SetAreaAilgn(const AAreaAlign: TGMAreaAlignRec); function GetLayoutBounds: TRect; function GetLayoutSpace: TRect; procedure SetLayoutSpace(const Value: TRect); function RootForRelayout: TObject; procedure SetLayoutBounds(const Value: TRect; const ARepaint: Boolean); procedure LayoutContainedAreas(const ARepaint: Boolean); // : TPoint; procedure InvalidateCachedLayoutValues; procedure SetVisible(const Value: Boolean; const Relayout: Boolean = True); procedure SetShowing(const Value: Boolean); function GetAutoCalcSize(const Direction: TGM2DDirection): Boolean; procedure SetAutoCalcSize(const Direction: TGM2DDirection; const Value: Boolean); // function GetAutoCalcWidth: Boolean; function CalculateWidth(const ANewSize: TPoint): LongInt; function CalculateHeight(const ANewSize: TPoint): LongInt; function CalculateSurfaceRect(const ARect: TRect): TRect; function CreateAreaRegion(const ABoundingRect: TRect; const ARegionKind: TGMAreaRegionKind): IGMGetHandle; function PointInsideArea(const APoint: TPoint): Boolean; function AreaContainingPoint(const APoint: TPoint): TObject; function SubtractContainedAreas(const ARect: TRect; const HFillRgn: HRGN): Boolean; function PaintingRect: TRect; function IsLayoutChild: Boolean; function IsTabstop: Boolean; function ProcessHelp(var AHelpInfo: THelpInfo): Boolean; function GetEnabled: Boolean; stdcall; // <- matches IGMGetEnabled interface method signature! function PaintsComplete: Boolean; function FillsComplete: Boolean; function ParticipateInLayouting: Boolean; function IsFramed: Boolean; function GetFrame: IGMAreaFrameDrawer; procedure SetFrame(const AFrame: IGMAreaFrameDrawer); procedure ScheduleRepaint; procedure CreateHandle; function GetContainedAreas: IGMObjArrayCollection; function GetOwnedAreas: IGMObjArrayCollection; function PaintToRect(const ADC: HDC; const ARect: TRect): Boolean; property Visible: Boolean read GetVisible; // write SetVisible; property AreaAlign: TGMAreaAlignRec read GetAreaAlign write SetAreaAilgn; property LayoutBounds: TRect read GetLayoutBounds; // write SetLayoutBounds; property LayoutSpace: TRect read GetLayoutSpace write SetLayoutSpace; function GetEdgeAlign(const Edge: TEdge): TEdgeAlign; procedure SetEdgeAlign(const Edge: TEdge; const Value: TEdgeAlign); function GetEdgePosition(const Edge: TEdge): LongInt; procedure SetEdgePosition(const Edge: TEdge; const Value: LongInt); function GetEdgeSpace(const Edge: TEdge): LongInt; procedure SetEdgeSpace(const Edge: TEdge; const Value: LongInt); property ContainedAreas: IGMObjArrayCollection read GetContainedAreas; // <- for painting and layouting property OwnedAreas: IGMObjArrayCollection read GetOwnedAreas; // <- for liftetime control property AutoCalcSize[const Direction: TGM2DDirection]: Boolean read GetAutoCalcSize write SetAutoCalcSize; property EdgeAlign[const Edge: TEdge]: TEdgeAlign read GetEdgeAlign write SetEdgeAlign; property EdgePosition[const Edge: TEdge]: LongInt read GetEdgePosition write SetEdgePosition; property EdgeSpace[const Edge: TEdge]: LongInt read GetEdgeSpace write SetEdgeSpace; property Frame: IGMAreaFrameDrawer read GetFrame write SetFrame; end; {TGMAreaLayouter = class(TGMRefCountedObj, IGMUiLayouter) protected FOwner: TObject; FChildList: TGMObjArrayCollection; public constructor Create(const AOwner: TObject; const AReflifeTime: Boolean = False); reintroduce; destructor Destroy; override; procedure LayoutContainedAreasIfNeeded(const ARepaint: Boolean); virtual; abstract; function SubtractContainedAreas(const HFillRgn: HRGN): Boolean; virtual; procedure PaintContainedAreas(const ADC: HDC); virtual; function AreaContainingPoint(const APoint: TPoint): TObject; virtual; //property Owner: TObject read FOwner; property ContainedAreas: TGMObjArrayCollection read FChildList; end; //TGMAreaLayouterClass = class of TGMAreaLayouter; TGMStandardLayouter = class(TGMAreaLayouter) protected function AdjustRestRect(const AreaAlign: TGMAreaAlignRec; const RCtl, RRest: TRect): TRect; function AdjustCalcSize(const Area: IGMUiArea; const RCtl: TRect): TRect; public procedure LayoutContainedAreasIfNeeded(const ARepaint: Boolean); override; end;} IGMAreaFiller = interface(IUnknown) ['{1EF3144A-CA8D-4208-8485-68097371384C}'] procedure Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); end; TGMAreaRegionFiller = class(TGMRefCountedObj, IGMAreaFiller) public procedure Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); end; TGMAreaRectFiller = class(TGMRefCountedObj, IGMAreaFiller) public procedure Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); end; TColorArray = array of COLORREF; TGMGlassLookFiller = class(TGMRefCountedObj, IGMAreaFiller) protected FColors: TColorArray; public constructor Create(const AColors: array of COLORREF; {const ARounded: Boolean = False;} const ARefLifeTime: Boolean = True); reintroduce; procedure Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); virtual; property Colors: TColorArray read FColors; end; TGMSimpleGlassLookFiller = class(TGMRefCountedObj, IGMAreaFiller) protected // FColor: COLORREF; public // constructor Create(const AColor: COLORREF; {const ARounded: Boolean = False;} const ARefLifeTime: Boolean = True); reintroduce; constructor Create(const ARefLifeTime: Boolean = True); override; procedure Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); virtual; end; TGMAreaGradientFiller = class(TGMGlassLookFiller, IGMAreaFiller) protected FDirection: TGM2DDirection; public constructor Create(const ADirection: TGM2DDirection; const AColors: array of COLORREF; const ARefLifeTime: Boolean = True); reintroduce; procedure Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); override; end; TGMGetColorFunc = function: COLORREF of object; stdcall; TGMGetHandleFunc = function: THandle of object; // A windowed area maintains a OS window handle. See: TGMWindow // A windowless area is just an logical area inside the parent area. TGMUiAreaBase = class(TGMRefCountedObj, IGMUiArea, IGMMessageHandler, IGMBkgndColor, IGMGetParentObj, IGMGetSetParentObj, IGMCalcAreaRegion, IGMGetSetBkgndColor, IGMUiAreaFrame, IGMUiLayouter, IGMSetShowing, // IGMPaint, IGMGetSizeConstraints, IGMGetSetSizeConstraints, IGMSetVisible, IGMGetEnabled, // IGMSetVisible, // IGMIsTabStop, IGMExecuteOperation, IGMClear) protected FParent: TObject; FLayoutBounds: TRect; FLayoutSpace: TRect; FAreaAlign: TGMAreaAlignRec; FFrame: IGMAreaFrameDrawer; FBkgndColor: COLORREF; FBkgndBrush: IGMGetHandle; //FAreaFiller: IGMAreaFiller; FVisible: Boolean; FSizeConstraints: TGMSizeConstraintsRec; FLastLayoutOrigin: TPoint; FLastLayoutSize: TPoint; FAutoCalcSize: array [TGM2DDirection] of Boolean; FOwnedAreas: IGMObjArrayCollection; FContainedAreas: IGMObjArrayCollection; //FCachedCalcWidth: TPoint; //FCachedCalcHeight: TPoint; procedure WMMouseMove(var Msg: TWMMouseMove); message WM_MOUSEMOVE; procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN; procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; procedure UMDragQueryDrop(var Msg: TMessage); message UM_DRAG_QUERYDROP; function GetVisible: Boolean; virtual; procedure InternalSetVisible(const Value: Boolean{; const Relayout: Boolean}); virtual; function InternalPaintToRect(const ADC: HDC; const ADestRect: TRect): Boolean; virtual; public function InternalCalcWidth(const ANewSize: TPoint): LongInt; virtual; function InternalCalcHeight(const ANewSize: TPoint): LongInt; virtual; public // Interfaces //function GetBkgndColor: COLORREF; virtual; stdcall; procedure Clear(const ANotify: Boolean = True); virtual; procedure SetBkgndColor(const AValue: COLORREF; const ARepaint: Boolean = True); virtual; stdcall; //nction QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; override; function GetParentObj: TObject; virtual; function GetAreaAlign: TGMAreaAlignRec; virtual; procedure SetAreaAilgn(const AAreaAlign: TGMAreaAlignRec); function GetLayoutBounds: TRect; virtual; procedure SetLayoutBounds(const AValue: TRect; const ARepaint: Boolean); virtual; procedure LayoutContainedAreas(const ARepaint: Boolean); virtual; //: TPoint; virtual; procedure LayoutContainedAreasIfNeeded(const ARepaint: Boolean); virtual; //: TPoint; virtual; function CalculateWidth(const ANewSize: TPoint): LongInt; virtual; function CalculateHeight(const ANewSize: TPoint): LongInt; virtual; function PointInsideArea(const APoint: TPoint): Boolean; virtual; function AreaContainingPoint(const APoint: TPoint): TObject; virtual; //function ChildAreaContainingPoint(const APoint: TPoint): TObject; function GetLayoutSpace: TRect; virtual; procedure SetLayoutSpace(const AValue: TRect); function GetContainedAreas: IGMObjArrayCollection; function GetOwnedAreas: IGMObjArrayCollection; procedure SetShowing(const Value: Boolean); virtual; function GetSizeContraints: TGMSizeConstraintsRec; virtual; procedure SetSizeContraints(const AValue: TGMSizeConstraintsRec); function GetEdgeAlign(const Edge: TEdge): TEdgeAlign; virtual; procedure SetEdgeAlign(const Edge: TEdge; const Value: TEdgeAlign); function GetEdgePosition(const AEdge: TEdge): LongInt; virtual; procedure SetEdgePosition(const AEdge: TEdge; const AValue: LongInt); virtual; function GetEdgeSpace(const AEdge: TEdge): LongInt; virtual; procedure SetEdgeSpace(const AEdge: TEdge; const AValue: LongInt); virtual; function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; virtual; stdcall; function GetFrame: IGMAreaFrameDrawer; virtual; procedure SetFrame(const AFrame: IGMAreaFrameDrawer); virtual; function GetEnabled: Boolean; virtual; stdcall; // function GetAutoCalcHeight: Boolean; // function GetAutoCalcWidth: Boolean; function ProcessHelp(var AHelpInfo: THelpInfo): Boolean; virtual; function GetAutoCalcSize(const ADirection: TGM2DDirection): Boolean; procedure SetAutoCalcSize(const ADirection: TGM2DDirection; const AValue: Boolean); public ScrollOffset: TPoint; CornerRounding: TPoint; BufferedPainting: Boolean; ClippedPainting: Boolean; OnGetHBkgndBrush: TGMGetHandleFunc; OnGetFontColor: TGMGetColorFunc; OnGetBkgndColor: TGMGetColorFunc; constructor Create(const ARefLifeTime: Boolean = False); overload; override; constructor Create(const AParent: TObject; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const ABkgndColor: COLORREF = cDfltColor; const AVisible: Boolean = True; const ARefLifeTime: Boolean = False); reintroduce; overload; virtual; destructor Destroy; override; procedure CreateHandle; virtual; function OwnArea(const AArea: TObject): TObject; function ClientAreaOrigin: TPoint; virtual; function ClientAreaSize: TPoint; virtual; function CalculateSurfaceRect(const ARect: TRect): TRect; virtual; function PaintingRect: TRect; virtual; function IsFramed: Boolean; virtual; function IsLayoutChild: Boolean; virtual; function ParticipateInLayouting: Boolean; virtual; //function ClippedPainting: Boolean; virtual; function PaintsComplete: Boolean; virtual; function FillsComplete: Boolean; virtual; procedure InvalidateCachedLayoutValues; virtual; function Paint(const ADC: HDC): Boolean; virtual; // <- return False to pass WM_PAINT to chained handlers too function PaintToRect(const ADC: HDC; const ADestRect: TRect): Boolean; virtual; procedure PaintBackground(const ADC: HDC; const AClientRect: TRect; const ARegion: IGMGetHandle); virtual; function PaintArea(const ADC: HDC; const ARect: TRect): Boolean; virtual; procedure PaintContainedAreas(const ADC: HDC; const AClientRect: TRect); virtual; function SubtractContainedAreas(const ARect: TRect; const AResultRegion: HRGN): Boolean; virtual; procedure SetVisible(const AValue: Boolean; const ARelayout: Boolean = True); virtual; procedure SetParentObj(const AValue: TObject; const ARelayout: Boolean = True); virtual; procedure ScheduleRepaint; virtual; function RootForRelayout: TObject; virtual; function MouseInside: Boolean; virtual; function HasFocus: Boolean; virtual; function IsPopupWindow: Boolean; virtual; function IsDialogKeyMsg(const Msg: TMessage): Boolean; virtual; procedure DispatchMsg(var Msg: TMessage); virtual; procedure WindowProc(var Msg: TMessage); virtual; function BkgndColor: COLORREF; virtual; stdcall; function HBkgndBrush: THandle; virtual; function FontHandle: THandle; virtual; function FontColor: COLORREF; virtual; stdcall; function FontBkgndColor: COLORREF; virtual; function CreateAreaRegion(const ABoundingRect: TRect; const ARegionKind: TGMAreaRegionKind): IGMGetHandle; virtual; function AreaFiller: IGMAreaFiller; virtual; function FrameColor: COLORREF; virtual; function IsTabStop: Boolean; virtual; procedure AssignCtrlColorValues(var Msg: TMessage); virtual; procedure SurfaceOriginChanged; virtual; procedure AfterParentChanged; virtual; property LayoutBounds: TRect read GetLayoutBounds; // write SetLayoutBounds; //property LayoutSpace: TRect read FLayoutSpace write FLayoutSpace; property Parent: TObject read GetParentObj; //property BkgndColor: COLORREF read GetBkgndColor; // write SetBkgndColor; property Visible: Boolean read GetVisible; // write SetVisible; //property AreaFiller: IGMAreaFiller read FAreaFiller write FAreaFiller; property OwnedAreas: IGMObjArrayCollection read FOwnedAreas; property ContainedAreas: IGMObjArrayCollection read FContainedAreas; property Left: LongInt index edgLeft read GetEdgePosition write SetEdgePosition; property Top: LongInt index edgTop read GetEdgePosition write SetEdgePosition; property Right: LongInt index edgRight read GetEdgePosition write SetEdgePosition; property Bottom: LongInt index edgBottom read GetEdgePosition write SetEdgePosition; property EdgeAlign[const Edge: TEdge]: TEdgeAlign read GetEdgeAlign write SetEdgeAlign; property EdgePosition[const Edge: TEdge]: LongInt read GetEdgePosition write SetEdgePosition; property Frame: IGMAreaFrameDrawer read GetFrame write SetFrame; property AutoCalcSize[const Direction: TGM2DDirection]: Boolean read GetAutoCalcSize write SetAutoCalcSize; end; TGMUiArea = class(TGMUiAreaBase) // // Invalidates it's area and paints background if not completely covered by child areas. // protected //FDispatchToParentMessages: IGMIntfCollection; FDispatchToParentMessages: IGMGenericCollection<TGMWndMsg>; procedure InternalSetVisible(const Value: Boolean{; const Relayout: Boolean}); override; public //DispatchToParentMessages: TGMPtrIntArray; constructor Create(const ARefLifeTime: Boolean = False); override; overload; procedure SetShowing(const Value: Boolean); override; procedure DispatchMsg(var AMsg: TMessage); override; //function Paint(const ADC: HDC): Boolean; override; //function PaintClientArea(const ADC: HDC; var RClient: TRect): Boolean; virtual; procedure SetLayoutBounds(const AValue: TRect; const ARepaint: Boolean); override; property DispatchToParentMessages: IGMGenericCollection<TGMWndMsg> read FDispatchToParentMessages; end; TGMLayoutAreaClass = class of TGMUiArea; TGMForeignWndContainer = class(TGMUiArea) // // A layout area containing another window by only knowing its handle. // -> TGMForeignWinCtrlImpl is designed to be such a window. // protected FForeignWnd: HWnd; function InternalCreateForeignWnd: HWnd; virtual; abstract; procedure CreateForeignWnd; virtual; procedure InternalSetVisible(const Value: Boolean{; const Relayout: Boolean}); override; public constructor Create(const AParent: TObject; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const AForeignWnd: HWnd; const ABkgndColor: COLORREF = cDfltColor; const AVisible: Boolean = True; const ARefLifeTime: Boolean = False); reintroduce; overload; procedure SetLayoutBounds(const Value: TRect; const ARepaint: Boolean); override; function InternalCalcWidth(const ANewSize: TPoint): LongInt; override; function InternalCalcHeight(const ANewSize: TPoint): LongInt; override; function PaintsComplete: Boolean; override; end; TGMSurroundingUiArea = class(TGMUiArea) // // Calculates size to contain all childs (recursive) + PaddSpace. // protected FPaddSpace: TPoint; public constructor Create(const AParent: TObject; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const APaddSpace: TPoint; const ABkgndColor: COLORREF = cDfltColor; const AVisible: Boolean = True; const ARefLifeTime: Boolean = False); reintroduce; overload; virtual; function InternalCalcWidth(const ANewSize: TPoint): LongInt; override; function InternalCalcHeight(const ANewSize: TPoint): LongInt; override; function RootForRelayout: TObject; override; end; //TGMWndPaintDisableImpl = class(TGMRefCountedObj, IGMEnableDisablePaint) // protected // FOwner: TObject; // FPaintDisableCount: LongInt; // // procedure SendEnableMsg(const AEnable: Boolean); // // public // // IUnknown // function QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; override; // function _AddRef: LongInt; override; // function _Release: LongInt; override; // // public // constructor Create(const AOwner: TObject; const ARefLifeTime: Boolean = False); // function EnablePaint: LongInt; stdcall; // function DisablePaint: LongInt; stdcall; // function GetPaintDisabledCount: LongInt; stdcall; //end; TGMWindow = class(TGMUiAreaBase, IGMGetHandle, IGMHandleAllocated, IGMGetText, IGMGetSetText, IGMGetSetEnabled, IGMLanguageChanged) // // Maintains a window handle // protected //FPaintDisabler: TGMWndPaintDisableImpl; FTextResData: RGMResTextRefData; FCreateData: RGMWndCreateData; FHandle: HWnd; FOrgWndProc: Pointer; FOrgWndPtrData: PtrInt; FPassMessageToOriginalHandler: Boolean; FIsMouseTracking: Boolean; FRelayedMessages: TRelayedMessages; function GetWndStyle: DWORD; function GetWndExStyle: DWORD; procedure SetParentWnd(const AWnd: HWnd); procedure SetWndStyle(const AValue: DWORD); procedure SetWndExStyle(const AValue: DWORD); procedure SetText(const AValue: TGMString); virtual; stdcall; procedure InternalSetVisible(const AValue: Boolean{; const Relayout: Boolean}); override; procedure InternalCreateHandle; virtual; procedure CreateParentHandle; virtual; //function GetVisible: Boolean; override; public // Window message handlers procedure WMHelp(var Msg: TWMHelp); message WM_HELP; procedure WMSize(var Msg: TWMSize); message WM_SIZE; procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; procedure WMMove(var Msg: TWMMove); message WM_MOVE; procedure WMMouseLeave(var Msg: TMessage); message WM_MOUSELEAVE; procedure UMStartMouseTrack(var Msg: TMessage); message UM_STARTMOUSETRACK; procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND; //procedure WMPrint(var Msg: TMessage); message WM_PRINT; procedure WMPrintClient(var Msg: TMessage); message WM_PRINTCLIENT; procedure WMNCDestroy(var Msg: TWMNCDestroy); message WM_NCDESTROY; procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT; procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO; procedure WMSetCursor(var Msg: TMessage); message WM_SETCURSOR; procedure WMCommand(var Msg: TMessage); message WM_COMMAND; procedure WMNotify(var Msg: TMessage); message WM_NOTIFY; procedure WMDrawItem(var Msg: TMessage); message WM_DRAWITEM; procedure WMVScroll(var Msg: TMessage); message WM_VSCROLL; procedure WMHScroll(var Msg: TMessage); message WM_HSCROLL; procedure WMSetFocus(var Msg: TMessage); message WM_SETFOCUS; procedure WMKillFocus(var Msg: TMessage); message WM_KILLFOCUS; public constructor Create(const ARefLifeTime: Boolean = False); override; constructor Create(const AParent: TGMWndObj; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const AWndStyle: DWORD = cDfltWndStyle; const AWndExStyle: DWORD = cDfltWndExStyle; const AText: TGMString = cDfltWndText; const AMenu: HMENU = cDfltWndMenu; const ABkgndColor: COLORREF = cDfltColor; const ARefLifeTime: Boolean = False); reintroduce; overload; virtual; destructor Destroy; override; procedure CreateHandle; override; procedure DestroyHandle(const ARememberState: Boolean); virtual; procedure DispatchMsg(var Msg: TMessage); override; procedure WindowProc(var Msg: TMessage); override; function HasWindowRegion: Boolean; virtual; function IsLayoutChild: Boolean; override; function IsTabStop: Boolean; override; function WndCreateRect: TRect; virtual; function ClientAreaOrigin: TPoint; override; function ClientAreaSize: TPoint; override; function PaintingRect: TRect; override; function RegisterWndClass: TGMString; virtual; function WndClassRegName: TGMString; virtual; function CursorHandle: HCURSOR; virtual; procedure LanguageChanged(const ANewLanguage: LPARAM); virtual; //function TempCursor: HCURSOR; virtual; function WndSizeFromClientSize(const AClientSize: TPoint): TPoint; virtual; //function Paint(const ADC: HDC): Boolean; override; procedure ScheduleRepaint; override; function GetHandle: THandle; stdcall; procedure SetLayoutBounds(const ALayoutBounds: TRect; const ARepaint: Boolean); override; function GetHandleAllocated: Boolean; stdcall; function GetEnabled: Boolean; override; procedure SetEnabled(const AValue: Boolean); stdcall; procedure SetShowing(const AValue: Boolean); override; //procedure SetParentObj(const Value: TObject; const Relayout: Boolean = True); override; procedure AfterParentChanged; override; function GetText: TGMString; virtual; stdcall; function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown): Boolean; override; function GetFrame: IGMAreaFrameDrawer; override; property Handle: THandle read GetHandle; //property PaintDisabler: TGMWndPaintDisableImpl read FPaintDisabler implements IGMEnableDisablePaint; property RelayedMessages: TRelayedMessages read FRelayedMessages; property WndStyle: DWORD read GetWndStyle write SetWndStyle; // FCreateData.WndStyle property WndExStyle: DWORD read GetWndExStyle write SetWndExStyle; // FCreateData.WndExStyle property ParentWnd: HWnd read FCreateData.ParentWnd write SetParentWnd; property HandleAllocated: Boolean read GetHandleAllocated; property Text: TGMString read GetText write SetText; end; TGMWinControl = class(TGMWindow) // // Always a child window, often a user input control // protected // FFocusNextControl: Boolean; procedure WMCancelMode(var Msg: TWMCancelMode); message WM_CANCELMODE; //procedure WMMouseActivate(var Msg: TWMMouseActivate); message WM_MOUSEACTIVATE; procedure WMKeyDown(var Msg: TWMKeyDown); message WM_KEYDOWN; //procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN; // procedure WMEnable(var Msg: TWMEnable); message WM_ENABLE; procedure CreateParentHandle; override; public constructor Create(const AParent: TGMWndObj; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const AText: TGMString = cDfltWndText; const AWndStyle: DWORD = cDfltWndStyle; const AWndExStyle: DWORD = cDfltWndExStyle; const ABkgndColor: COLORREF = cDfltColor; const ARefLifeTime: Boolean = False); reintroduce; overload; virtual; function IsPopupWindow: Boolean; override; procedure SurfaceOriginChanged; override; //function IsDialogKeyMsg(const Msg: TMessage): Boolean; override; function ClosePopupState(const RestoreActiveCtrl: Boolean = False): Boolean; virtual; end; TGMWinControlClass = class of TGMWinControl; TGMOEMControl = class(TGMWinControl) // // Designed to have no contained areas, best base for existing controls of the OS // protected procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN; //procedure WMMouseActivate(var Msg: TWMMouseActivate); message WM_MOUSEACTIVATE; procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; //procedure WMPrint(var Msg: TMessage); message WM_PRINT; procedure WMPrintClient(var Msg: TMessage); message WM_PRINTCLIENT; procedure WMMouseLeave(var Msg: TMessage); message WM_MOUSELEAVE; procedure UMStartMouseTrack(var Msg: TMessage); message UM_STARTMOUSETRACK; procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND; procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT; procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE; public procedure WindowProc(var Msg: TMessage); override; end; TGMNCWinControl = class(TGMOEMControl) // // Some standard windows controls dont paint their frames into // WM_PRINT DC's. This class provides a simple work around. // protected procedure UMHandleCreated(var Msg: TMessage); message UM_HANDLECREATED; procedure FinalizeShow; virtual; end; //TGMPopupControl = class(TGMWindow) // protected // //end; TGMForeignWinCtrlImpl = class(TGMWinControl) // // A window that can participate layouting by only exposing a window handle. // -> TGMForeignWndContainer is designed to communicate with such windows. // protected procedure UMCalcWidth(var Msg: TMessage); message UM_CALCWIDTH; procedure UMCalcHeight(var Msg: TMessage); message UM_CALCHEIGHT; //public //function CalculateWidth(const ANewSize: TPoint): LongInt; override; //function CalculateHeight(const ANewSize: TPoint): LongInt; override; end; TGMDlgWindow = class(TGMWindow) protected //FParentWasEnabled: Boolean; FDlgData: Pointer; //FTempCursor: HCursor; //FModalDisabledWindows: TGMPtrIntArray; //FIsModalDialog: Boolean; //procedure WMDestroy(var Msg: TMessage); message WM_DESTROY; //procedure UMClose(var Msg: TMessage); message UM_CLOSE; // <- Introduce one level of indirection, to be able to override WM_CLOSE behavior procedure WMClose(var Msg: TMessage); message WM_CLOSE; procedure WMKeyDown(var Msg: TWMKeyDown); message WM_KEYDOWN; procedure WMSysKeyDown(var Msg: TWMSysKeyDown); message WM_SYSKEYDOWN; //procedure WMSysKeyUp(var Msg: TMessage); message WM_SYSKEYUP; //procedure WMChar(var Msg: TMessage); message WM_CHAR; //procedure WMPrintClient(var Msg: TMessage); message WM_PRINTCLIENT; //procedure WMPrint(var Msg: TMessage); message WM_PRINT; //procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND; procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE; //procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCACTIVATE; //procedure UMSetTempCursor(var Msg: TMessage); message UM_SETTEMPCURSOR; procedure UMSelectNextDlgTabArea(var Msg: TMessage); message UM_SELECTNEXTDLGTABAREA; procedure UMLanguageChanged(var Msg: TMessage); message UM_LANGUAGECHANGED; //procedure ReEnableOtherWindows; //procedure InternalCreateHandle; override; // procedure CreateParentHandle; override; public ActiveControl: TObject; constructor Create(const APosition: TRect; const AWndStyle: DWORD = cSizeDlgWndStyle; const AWndExStyle: DWORD = cPrntWndExStyle; const ATitle: TGMString = cDfltWndText; const AParent: TGMWndObj = cDfltPrntWnd; const ADlgData: Pointer = cDfltDlgData; const AMenu: HMENU = cDfltWndMenu; const ABkgndColor: COLORREF = cDfltColor; const ARefLifeTime: Boolean = False); reintroduce; overload; virtual; procedure CreateHandle; override; function IsModalDialog: Boolean; virtual; function IsDialogKeyMsg(const Msg: TMessage): Boolean; override; function CloseOnEscape: Boolean; virtual; procedure SetBkgndColor(const Value: COLORREF; const ARepaint: Boolean = True); override; function RegisterWndClass: TGMString; override; procedure InitControls; virtual; procedure SetupControls; virtual; function CanClose(const ASetData: Boolean): Boolean; virtual; procedure DoneDialog(const ASetData: Boolean); virtual; procedure GetDlgData; virtual; //procedure SetDlgData; virtual; property DlgData: Pointer read FDlgData; //property TempCursor: HCursor read FTempCursor write FTempCursor; //function TempCursor: HCURSOR; override; end; TGMDlgWindowClass = class of TGMDlgWindow; TGMStackedDlgWindow = class(TGMDlgWindow) // // The Handle will be pushed on the window stack, and popped when closed // protected procedure WMNCDestroy(var Msg: TWMNCDestroy); message WM_NCDESTROY; procedure InternalCreateHandle; override; end; TGMMainWindow = class(TGMStackedDlgWindow) // // Adds ExStyle WS_EX_APPWINDOW => will be shown on the task bar // Calls PostQuitMessage when cosed // protected procedure WMQueryEndSession(var Msg: TMessage); message WM_QUERYENDSESSION; procedure WMNCDestroy(var Msg: TWMNCDestroy); message WM_NCDESTROY; public constructor Create(const APosition: TRect; const AWndStyle: DWORD = cSizeDlgWndStyle; const AWndExStyle: DWORD = cPrntWndExStyle; const ATitle: TGMString = cDfltWndText; const AParent: TGMWndObj = cDfltPrntWnd; const ADlgData: Pointer = cDfltDlgData; const AMenu: HMENU = cDfltWndMenu; const ABkgndColor: COLORREF = cDfltColor; const ARefLifeTime: Boolean = False); override; function CanClose(const ASetData: Boolean): Boolean; override; end; {TGMMainWindow = class(TGMMainWindow); protected procedure WMNCDestroy(var Msg: TWMNCDestroy); message WM_NCDESTROY; procedure InternalCreateHandle; override; end;} {TGMMsgHookWindow = class(TGMWindow) protected FHookWnd: HWnd; public constructor Create(const AHookWnd: HWnd; const AParent: TGMWndObj = 0; const ARefLifeTime: Boolean = False); //reintroduce; overload; property HookWnd: HWnd read FHookWnd write FHookWnd; end;} TGMWindowDisabler = class(TGMRefCountedObj) // // Temporary disable user input to a window. // Stable against cascaded usage. // protected FWnd: HWnd; FWasEnabled: Boolean; public constructor Create(const AWnd: HWnd; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; TGMDragPainter = class(TGMRefCountedObj, IGMMessageHandler, IGMGetParentObj) protected FParent: TObject; FDragData: IUnknown; FDragLastWndOver: HWnd; FOldKeyboardFocusArea: TObject; procedure WMKeyDown(var Msg: TWMKey); message WM_KEYDOWN; procedure WMKeyUp(var Msg: TWMKey); message WM_KEYUP; procedure WMMouseMove(var Msg: TWMMouseMove); message WM_MOUSEMOVE; procedure WMLButtonUp(var Msg: TWMLButtonUp); message WM_LBUTTONUP; procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; procedure WMCancelMode(var Msg: TWMCancelMode); message WM_CANCELMODE; procedure WMMouseWheel(var Msg: TMessage); message WM_MOUSEWHEEL; procedure DragToScreenPos(const AScreenPos: TPoint); virtual; abstract; function FindWindowFromScreenPoint(const AScreenPos: TPoint): HWnd; virtual; procedure ExitDragState; virtual; public constructor Create(const AParent: TObject; //const ADragOffs: TPoint; const ADragData: IUnknown; const ARefLifeTime: Boolean = True); reintroduce; overload; function GetParentObj: TObject; virtual; procedure WindowProc(var Msg: TMessage); virtual; procedure DispatchMsg(var Msg: TMessage); virtual; procedure CancelDrag; virtual; // (const ScreenPos: TPoint); function DragAndQueryDropTarget(AScreenPos: TPoint): Boolean; virtual; property DragData: IUnknown read FDragData; property Parent: TObject read FParent; end; TGMDragWindow = class(TGMWindow) protected FBitmap, FBmpDC: IGMGetHandle; FImageSize: TPoint; //procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND; public constructor Create(const AParent: TGMWndObj; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const ABitmap: IGMGetHandle; const AWndStyle: DWORD = cDfltWndStyle; const AWndExStyle: DWORD = cDfltWndExStyle; // const AText: TGMString = cDfltWndText; const AMenu: HMENU = cDfltWndMenu; const ABkgndColor: COLORREF = cDfltColor; const ARefLifeTime: Boolean = True); reintroduce; overload; function PaintToRect(const ADC: HDC; const ARect: TRect): Boolean; override; end; TGMTransparentDragPainter = class(TGMDragPainter) protected FDragWindow: IGMGetHandle; FDragOffs: TPoint; procedure DragToScreenPos(const AScreenPos: TPoint); override; procedure ExitDragState; override; public constructor Create(const AParent: TObject; const ABitmap: IGMGetHandle; const ATransparentColor: COLORREF; const ADragOffs: TPoint; const ADragData: IUnknown = nil; const ARefLifeTime: Boolean = True); reintroduce; overload; end; TGMTimerWnd = class(TGMWindow) protected FOwner: TObject; procedure WMTimer(var Msg: TMessage); message WM_TIMER; public constructor Create(const AOwner: TObject; const ARefLifeTime: Boolean = True); end; TGMWndTimerWithHandle = class(TGMWndTimer) protected FOnTimerProc: TGMObjNotifyProc; FWindow: IGMGetHandle; public Caller: TObject; constructor Create(const AOnTimerProc: TGMObjNotifyProc = nil; const ACaller: TObject = nil; const AMilliSeconds: LongInt = cDfltTimerInterval; const AAutoStart: Boolean = False; const ARefLifeTime: Boolean = True); reintroduce; overload; virtual; function GetHandle: THandle; override; end; TGMHideDragPainter = class(TGMRefCountedObj) protected FDragPainter: IGMSetVisible; public constructor Create(const ADragPainter: IUnknown; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; TGMWndPaintDisabler = class(TGMRefCountedObj) // // Temporary disable window painting. // NOT stable against cascaded usage. // protected FWnd: HWnd; public constructor Create(const AWnd: HWnd; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; //TGMWndTempCursor = class(TGMRefCountedObj) // protected // FDlgWnd: HWnd; // FOldCursor: HCursor; // // public // constructor Create(const ATempCursor: TGMCursor; AWnd: HWnd = 0; const ARefLifeTime: Boolean = True); reintroduce; // destructor Destroy; override; //end; {TGMAppTempCursor = class(TGMRefCountedObj) protected FOldCursor: HCursor; public constructor Create(const ATempCursor: TGMCursor; const ARefLifeTime: Boolean = True); destructor Destroy; override; end;} // Borlands definition of TriVertex is wrong .. {$IFNDEF JEDIAPI} PGMTriVertexRec = ^TGMTriVertexRec; TGMTriVertexRec = packed record X, Y: LongInt; Red, Green, Blue, Alpha: Word; end; {$ENDIF} TGMObjVisitFunc = function (const AObj: TObject; const AData: Pointer): Boolean; function GMWindowClassList: IGMIntfArrayCollection; function GMRegisterWindowClass(const AWndClassName: TGMString; const ACursor: HCURSOR = 0; const AClassStyle: DWORD = 0; const AIcon: HICON = 0; const ABkgndBrush: HBRUSH = 0; const AMenuName: TGMString = ''): IGMGetName; function GMOwnArea(const Owner, Area: TObject): TObject; function GMMessageRec(const Msg: UINT; const wParam: WPARAM = 0; const lParam: LPARAM = 0; const lResult: LRESULT = 0): TMessage; function GMTriVertex(const Pt: TPoint; Red: Word = 0; Green: Word = 0; Blue: Word = 0; Alpha: Word = 0): {$IFNDEF JEDIAPI}TGMTriVertexRec{$ELSE}TTriVertex{$ENDIF}; function GMRectCenterX(const RInner, ROuter: TRect): TRect; function GMRectCenterY(const RInner, ROuter: TRect): TRect; function GMLimitRectToScreen(const ARect: TRect; const Edges: TEdges = CAllEdges): TRect; function GMAreaRect(Left: LongInt = CInvalidUIPos; Top: LongInt = CInvalidUIPos; Width: LongInt = CInvalidUIPos; Height: LongInt = CInvalidUIPos): TRect; function GMDesktopClientRect: TRect; function GMCenteredWndRect(const WndSize: TPoint; const Parent: TGMWndObj = cDfltPrntWnd): TRect; function GMAreaAlign(const Left, Top, Right, Bottom: TEdgeAlign; const ShrinkRestX: Boolean = False; const ShrinkRestY: Boolean = False): TGMAreaAlignRec; function GMSplitDirectionFromAlign(const AAlign: TEdgesAlign; const ASpace: TRect): TGM2DDirection; function GMAreaRegionFiller: IGMAreaFiller; function GMAreaRectFiller: IGMAreaFiller; function GMLoadRect(const Source: IGMValueStorage; const DirPath, RectName: TGMString; const DefaultRect: TRect): TRect; procedure GMStoreRect(const Dest: IGMValueStorage; const DirPath, RectName: TGMString; const Value: TRect); function GMLoadDlgRect(const ASource: IGMValueStorage; const ALoadPath, ARectName: TGMString; const ADlgSize: TPoint; const AParent: TGMWndObj): TRect; overload; function GMLoadDlgRect(const ASource: IGMValueStorage; const ALoadPath, ARectName: TGMString; const ADlgRect: TRect): TRect; overload; function GMResTextRefDataRec(const AResStringPtr: PResStringRec; const AFormatStr: TGMString = ''): RGMResTextRefData; function GMMakeResRefText(const AResStringRecPtr: Pointer; const AFormatString: TGMString = ''): TGMString; function GMResolveTextResData(const AText: TGMString; var ATextResData: RGMResTextRefData): TGMString; function GMBuildTextFromResRef(const ATextResData: RGMResTextRefData; const AText: TGMString): TGMString; function GMNextCtrlID: PtrInt; function GMObjFromWnd(const AHWnd: HWnd): TObject; function GMHWndFromWndObj(const AWndObj: TGMWndObj): HWnd; function GMObjFromWndObj(const WndObj: TGMWndObj): TObject; function GMDlgParentWndFromObj(const AObj: TObject): HWnd; function GMStdWndProc(AWnd: HWND; AMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; function GMStdIWndProc(Wnd: HWND; AMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; //procedure GMHideAndShowWnd(const WndObj: TGMWndObj); //procedure GMRepaintArea(const Area: TObject); procedure GMPaintWndFrame(const AWndObj: TGMWndObj); function GMAnimateWindow(Wnd: HWND; dwTime: DWORD; dwFlags: DWORD): BOOL; procedure GMShowWindowAnimated(const AWnd: HWnd; const AShowKind: TGMShowWndKind = swShowNormal); //function GMWndAnimationData: TGMWndAnimationData; procedure GMExecPendingPainting(const AArea: TObject); procedure GMCloseAllThreadWindows(const ACallingWnd: HWnd); procedure GMLoadNewLanguageToUI(const ANewLanguage: LangId); procedure GMCallObjWindowProc(const AObj: TObject; var AMsg: TMessage); overload; function GMCallObjWindowProc(const AObj: TObject; const AMsg: UINT; const wParam: WPARAM = 0; const lParam: LPARAM = 0): LRESULT; overload; procedure GMCallIntfWindowProc(const Intf: IUnknown; var Msg: TMessage); overload; function GMCallIntfWindowProc(const Intf: IUnknown; const Msg: UINT; const wParam: WPARAM = 0; const lParam: LPARAM = 0): LRESULT; overload; procedure GMDispatchObjMsg(const AObj: TObject; var AMsg: TMessage); //function GMDispatchObjMsg(const Obj: TObject; const Msg: UINT; const wParam: WPARAM = 0; const lParam: LPARAM = 0): LongInt; //function GMPostIntfMessage(Intf: IUnknown; AMsg: UINT; wParam: WPARAM = 0; lParam: LPARAM = 0): Boolean; procedure GMPostSeletNextDlgTabAreaMsg(const AArea: TObject); procedure GMEnableWindow(const AObj: TObject; const Enable: Boolean); function GMPostObjMessage(const AObj: TObject; AMsg: UINT; wParam: WPARAM = 0; lParam: LPARAM = 0): Boolean; function GMPostIntfMessage(const AIntf: IUnknown; AMsg: UINT; wParam: WPARAM = 0; lParam: LPARAM = 0): Boolean; function GMSendObjMessage(const AObj: TObject; AMsg: UINT; wParam: WPARAM = 0; lParam: LPARAM = 0): LRESULT; procedure GMAddDispatchToParentMessages(const AArea: TObject; const AMessages: array of TGMWndMsg); procedure GMSetObjVisible(const AObj: TObject; const AVisible, ARelayout: Boolean); function GMFindParentDlg(const AArea: TObject; var ADlg: TObject): Boolean; function GMFindWindowedParent(AArea: TObject): IGMGetHandle; function GMFindAllocatedParentHandle(const AArea: TObject; var AHandle: HWnd): Boolean; function GMParentHandleAllocated(const AArea: TObject): Boolean; function GMModalDlgParentWndObj(const AParentWnd: TGMWndObj): TGMWndObj; function GMScreenRect: TRect; function GMScreenSize: TPoint; function GMClientToScreen(const AArea: TObject; const APoint: TPoint): TPoint; overload; function GMClientToScreen(const AArea: TObject; const ARect: TRect): TRect; overload; function GMScreenToClient(const AArea: TObject; const APoint: TPoint): TPoint; overload; function GMScreenToClient(const AArea: TObject; const ARect: TRect): TRect; overload; function GMAreaToScreen(const AArea: TObject; APoint: TPoint): TPoint; function GMScreenToArea(const AArea: TObject; const APoint: TPoint): TPoint; function GMCalcPopupRect(const AArea: TObject; const ARequestedHeight, ASpace: LongInt): TRect; function GMAreaBoundsOffset(const AContainerArea, AContainedArea: TObject): TRect; procedure GMCaptureMouseInput(const AArea: TObject); procedure GMReleaseMouseCapture; procedure GMSetFocus(const AArea: TObject); procedure GMCancelPopup; function GMFindNextDlgTabAreaByUIPosition(const ADlg, AStartArea: TObject; const AReverse: Boolean): TObject; function GMCalcHintShowTimeMS(const AText: TGMString): LongInt; function GMFrameExtent(const AFrame: IUnknown; const AEdges: TEdges = cAllEdges): TPoint; function GMSetSizeConstraints(const AArea: TObject; const AMinWidth: LongInt = cSizeCnstrNoChange; const AMaxWidth: LongInt = cSizeCnstrNoChange; const AMinHeight: LongInt = cSizeCnstrNoChange; const AMaxHeight: LongInt = cSizeCnstrNoChange): TObject; function GMCalculateClientRect(const AFrame: IGMAreaFrameDrawer; const ABoundsRect: TRect): TRect; procedure GMSetObjAreaFrame(const AArea: TObject; const AFrame: IUnknown); function GMSetIntfMultifFrame(const Area: IUnknown; const InnerFrame: TFrameShape; const OuterFrame: TFrameShape; const FramedEdges: TEdges = CAllEdges; const FrameKind: TFrameKind = frkTile; const OuterSpace: LongInt = 0; const FrameLook3D: Boolean = True): IUnknown; function GMSetObjMultiFrame(const Area: TObject; const InnerFrame: TFrameShape; const OuterFrame: TFrameShape; const FramedEdges: TEdges = CAllEdges; const FrameKind: TFrameKind = frkTile; const OuterSpace: LongInt = 0; const FrameLook3D: Boolean = True): TObject; //function GMPaintingClientRect(const AArea: TObject): TRect; function GMKeyDataToKeyState(const AKeyData: LongInt): SGMKeyStates; function GMIconInstance: THandle; function GMFindFirstIcon(const Module: HModule): HIcon; function GMAreaHasWndHandle(const AArea: TObject): Boolean; function GMIsEqualAlign(const AreaAlign1, AreaAlign2: TGMAreaAlignRec): Boolean; procedure GMReLayoutContainedAreas(const AArea: TObject; const ARepaint: Boolean = True; const ARecurse: Boolean = True); procedure GMScheduleRepaint(const Area: TObject); function GMParentRootForRelayout(const Area: TObject): TObject; //function GMIsAutoCalcHeight(const EdgeAlign: TEdgesAlign; const Bounds: TRect): Boolean; //function GMIsAutoCalcWidth(const EdgeAlign: TEdgesAlign; const Bounds: TRect): Boolean; function GMWndSizeFromClientSize(const AClientSize: TPoint; const AWndStyle, AWndExStyle: DWORD; const AHasMEnu: Boolean = False): TPoint; function GMCalcMsgDlgClientSize(const AMsgText: TGMString; const AFont: HFont; const ADlgMinSize, AExtraSize: TPoint; var AVScrollBarNeeded: Boolean): TPoint; function GMVisitAllChildAreas(const AArea: TObject; const AVisitFunc: TGMObjVisitFunc; const AAreasToIgnore: array of TObject; const ARecurse: Boolean = True; const AData: Pointer = nil): Boolean; procedure GMClearControls(const AArea: TObject; const ARecurse: Boolean; const AAreasToIgnore: array of TObject); procedure GMEnableControls(const AArea: TObject; const AEnable, ARecurse: Boolean; const AAreasToIgnore: array of TObject); function GMAreaIsShowing(const AArea: TObject): Boolean; //function GMCompareByWndMessage(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareByUIPosition(const ItemA, ItemB: IUnknown): TGMCompareResult; procedure GMCallInitProcs; procedure GMApplicationMessageLoop; function GMCallTerminateProcs: Boolean; function GMShowModalDlg(const ADlgWndClass: TGMDlgWindowClass; const AShowKind: TGMShowWndKind = swShowNormal; const ADlgData: Pointer = nil; const ATitle: TGMString = ''; const AParent: TGMWndObj = cDfltPrntWnd): PtrInt; function GMShowModalWnd(AModalWnd: TGMWndObj; const AShowKind: TGMShowWndKind = swShowNormal): PtrInt; function GMIsWindow(const AWindow: TGMWndObj): Boolean; inline; //function GMCalcBoundingChildHeight(const AContainedAreas: IGMObjArrayCollection): LongInt; //function GMCalcBoundingChildWidth(const AContainedAreas: IGMObjArrayCollection): LongInt; function GMCalcBoundingHeight(const AContainingArea: TGMUiAreaBase; const ANewSize: TPoint; const ARelayout: Boolean = True): LongInt; function GMCalcBoundingWidth(const AContainingArea: TGMUiAreaBase; const ANewSize: TPoint; const ARelayout: Boolean = True): LongInt; //function GMParticipateInLayouting(const AArea: IGMUiArea): Boolean; procedure GMLayoutContainedAreas(const Area: IGMUiArea; const ARepaint: Boolean; const ALayoutEdgeOrderMap: TGMLayoutEdgeOrderMap); //: TPoint; procedure GMWrapLayoutContainedAreas(const Area: IGMUiArea; const ARepaint: Boolean; const AHorzAlign: TGMHorizontalAlignment; const AVLineSpace: LongInt); //: TPoint; //function GMAreaAlignToLongInt(const Value: TGMAreaAlignRec): LongInt; //function GMAreaAlignFromLongInt(const Value: LongInt): TGMAreaAlignRec; //procedure GMPrintClientImpl(const Wnd: HWnd; const ADC: HDC; const Brush: HBRUSH); // Borlands definition of GradientFill is wrong .. {$IFNDEF JEDIAPI} function GMGradientFill(ADC: HDC; pVertex: PGMTriVertexRec; dwNumVertex: DWORD; pMesh: Pointer; dwNumMesh, dwMode: DWORD): BOOL; stdcall; external 'msimg32.dll' name 'GradientFill'; {$ENDIF} procedure GMGradientFillRect(const ADC: HDC; const Color1, Color2: COLORREF; const ARect: TRect; const Direction: TGM2DDirection); procedure GMGlassFillRect(const ADC: HDC; const ARect: TRect; const AColors: array of COLORREF); //const clTop, clMidHi, clMidLo, clBottom, clCorner: COLORREF); procedure GMGlassFillRectSimple(const ADC: HDC; const ARect: TRect; const ADarkestColor: COLORREF); function GMAssignRoundedAreaProperties(const AArea: TObject): TObject; function GMPanelAreaFrame: IGMAreaFrameDrawer; function SmallPointToPoint(const P: TSmallPoint): TPoint; function PointToSmallPoint(const P: TPoint): TSmallPoint; //procedure GMSetCornerPixels(const ADC: HDC; const ARect: TRect; const AColor: COLORREF); var //vDefaultUIFont: TDefaultFont = dfUIFont; vGMLayoutEdgeOrderMap: TGMLayoutEdgeOrderMap = (edgLeft, edgTop, edgRight, edgBottom); vGMMouseCaptureArea: TObject = nil; vGMPopupArea: TObject = nil; vGMMouseInsideArea: TObject = nil; vGMKeyboardFocusArea: TObject = nil; vGMDragPainter: IUnknown = nil; vGMDropTargetArea: TObject = nil; vGMWndAnimation: DWORD = cDfltWndAnimation; vGMWndAniDuration: DWORD = cDfltWndAniDuration; vGMPopupAniDuration: DWORD = 180; vLightGray: COLORREF = $EBEBEB; vGMDfltCornerRounding: TPoint = (x:4; y:4); vGMShrinkAnimationCount: LongInt = 15; implementation uses SysUtils{$IFDEF JEDIAPI}, jwaWinBase{$ENDIF}; type PHIcon = ^HIcon; var vGMAreaRegionFiller: IGMAreaFiller = nil; vGMAreaRectFiller: IGMAreaFiller = nil; vGMWindowClassList: IGMIntfArrayCollection = nil; vGMNextCtrlId: PtrInt = 0; vGMPanelAreaFrame: IGMAreaFrameDrawer = nil; vGMTerminateProcsCalled: Boolean = False; { ------------------------- } { ---- Global Routines ---- } { ------------------------- } function GMPanelAreaFrame: IGMAreaFrameDrawer; begin if vGMPanelAreaFrame = nil then vGMPanelAreaFrame := TGMAreaSimpleFrame.Create; Result := vGMPanelAreaFrame; end; function GMMessageRec(const Msg: UINT; const wParam: WPARAM; const lParam: LPARAM; const lResult: LRESULT): TMessage; begin Result.Msg := Msg; Result.WParam := wParam; Result.LParam := lParam; Result.Result := lResult; end; function GMTriVertex(const Pt: TPoint; Red: Word; Green: Word; Blue: Word; Alpha: Word): {$IFNDEF JEDIAPI}TGMTriVertexRec{$ELSE}TTriVertex{$ENDIF}; begin Result.X := Pt.X; Result.Y := Pt.Y; Result.Red := Red; Result.Green := Green; Result.Blue := Blue; Result.Alpha := Alpha; end; function SmallPointToPoint(const P: TSmallPoint): TPoint; begin Result.X := P.X; Result.Y := P.Y; end; function PointToSmallPoint(const P: TPoint): TSmallPoint; begin Result.X := P.X; Result.Y := P.Y; end; //function GMDispatchObjMsg(const Obj: TObject; const Msg: UINT; const wParam: WPARAM = 0; const lParam: LPARAM = 0): LongInt; //var PIWndProc: IGMMessageHandler; MsgRec: TMessage; //begin // if (Obj = nil) or not Obj.GetInterface(IGMMessageHandler, PIWndProc) then Result := 0 else // begin // MsgRec := GMMessageRec(Msg, WParam, LParam, 0); // PIWndProc.DispatchMsg(MsgRec); // Result := MsgRec.Result; // end; //end; procedure GMDispatchObjMsg(const AObj: TObject; var AMsg: TMessage); var msgHandler: IGMMessageHandler; // weakMsgHandler: Pointer; begin // We don't want a ref counted call here, the object may delete itself when executing the message and then decrementing the refcount crashes because the object is gone if AObj is TGMUiAreaBase then TGMUiAreaBase(AObj).DispatchMsg(AMsg) else // A Drag painter implements IGMMessageHandler but is NOT derived from TGMUiAreaBase if GMGetInterface(AObj, IGMMessageHandler, msgHandler) then msgHandler.DispatchMsg(AMsg); //if GMGetWeakInterface(AObj, IGMMessageHandler, weakMsgHandler) then IGMMessageHandler(weakMsgHandler).DispatchMsg(AMsg); end; procedure GMCallObjWindowProc(const AObj: TObject; var AMsg: TMessage); var msgHandler: IGMMessageHandler; // weakMsgHandler: Pointer; begin // We don't want a ref counted call here, the object may delete itself when executing the message and then decrementing the refcount crashes because the object is gone if AObj is TGMUiAreaBase then TGMUiAreaBase(AObj).WindowProc(AMsg) else // A Drag painter implements IGMMessageHandler but is NOT derived from TGMUiAreaBase if GMGetInterface(AObj, IGMMessageHandler, msgHandler) then msgHandler.WindowProc(AMsg); //if GMGetWeakInterface(AObj, IGMMessageHandler, weakMsgHandler) then IGMMessageHandler(weakMsgHandler).WindowProc(AMsg); end; function GMCallObjWindowProc(const AObj: TObject; const AMsg: UINT; const wParam: WPARAM; const lParam: LPARAM): LRESULT; var msgHandler: IGMMessageHandler; msg: TMessage; begin if not GMGetInterface(AObj, IGMMessageHandler, msgHandler) then Result := 0 else begin msg := GMMessageRec(AMsg, WParam, LParam, 0); msgHandler.WindowProc(msg); Result := msg.Result; end; end; procedure GMCallIntfWindowProc(const Intf: IUnknown; var Msg: TMessage); var msgHandler: IGMMessageHandler; begin if GMQueryInterface(Intf, IGMMessageHandler, msgHandler) then msgHandler.WindowProc(Msg); end; function GMCallIntfWindowProc(const Intf: IUnknown; const Msg: UINT; const wParam: WPARAM; const lParam: LPARAM): LRESULT; var msgHandler: IGMMessageHandler; MsgRec: TMessage; begin if (Intf = nil) or not GMQueryInterface(Intf, IGMMessageHandler, msgHandler) then Result := 0 else begin MsgRec := GMMessageRec(Msg, WParam, LParam, 0); msgHandler.WindowProc(MsgRec); Result := MsgRec.Result; end; end; //function GMPostIntfMessage(Intf: IUnknown; AMsg: UINT; wParam: WPARAM; lParam: LPARAM): Boolean; ////var PIHAlloc: IGMHandleAllocated; PIHandle: IGMGetHandle; //var Handle: THandle; //begin // if GMGetAllocatedObjHandle(Intf, Handle) then Result := PostMessage(FHandle, AMsg, wParam, lParam) else Result := False; // // //if (Wnd <> nil) and ((Wnd.QueryInterface(IGMHandleAllocated, PIHAlloc) <> S_OK) or PIHAlloc.HandleAllocated) and // // (Wnd.QueryInterface(IGMGetHandle, PIHandle) = S_OK) then // // Result := PostMessage(PIHandle.Handle, AMsg, wParam, lParam) else Result := False; //end; procedure GMPostSeletNextDlgTabAreaMsg(const AArea: TObject); var dlg: TGMDlgWindow; begin if GMFindParentObj(AArea, TGMDlgWindow, dlg) then GMPostObjMessage(dlg, UM_SELECTNEXTDLGTABAREA); end; procedure GMEnableWindow(const AObj: TObject; const Enable: Boolean); var Wnd: THandle; begin if GMGetAllocatedObjHandle(AObj, Wnd) then EnableWindow(Wnd, Enable); end; function GMPostObjMessage(const AObj: TObject; AMsg: UINT; wParam: WPARAM; lParam: LPARAM): Boolean; var Wnd: THandle; begin if GMGetAllocatedObjHandle(AObj, Wnd) then Result := PostMessage(Wnd, AMsg, wParam, lParam) else Result := False; end; function GMPostIntfMessage(const AIntf: IUnknown; AMsg: UINT; wParam: WPARAM = 0; lParam: LPARAM = 0): Boolean; var Wnd: THandle; begin if GMGetAllocatedIntfHandle(AIntf, Wnd) then Result := PostMessage(Wnd, AMsg, wParam, lParam) else Result := False; end; function GMSendObjMessage(const AObj: TObject; AMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; var Wnd: THandle; begin if GMGetAllocatedObjHandle(AObj, Wnd) then Result := SendMessage(Wnd, AMsg, wParam, lParam) else Result := 0; end; procedure GMSetObjVisible(const AObj: TObject; const AVisible, ARelayout: Boolean); var setVisible: IGMSetVisible; begin if GMGetInterface(AObj, IGMSetVisible, setVisible) then setVisible.SetVisible(AVisible, ARelayout); end; procedure GMAddDispatchToParentMessages(const AArea: TObject; const AMessages: array of TGMWndMsg); var msg: TGMWndMsg; begin if AArea is TGMUiArea then for msg in AMessages do TGMUiArea(AArea).DispatchToParentMessages.Add(msg); end; function GMFindParentDlg(const AArea: TObject; var ADlg: TObject): Boolean; var parent: IGMGetParentObj; area: IGMUiArea; begin ADlg := AArea; while (ADlg <> nil) and (not ADlg.GetInterface(IGMUiArea, area) or area.IsLayoutChild) do begin GMCheckGetInterface(ADlg, IGMGetParentObj, parent, {$I %CurrentRoutine%}); ADlg := parent.ParentObj; end; Result := ADlg <> nil; end; function GMFindWindowedParent(AArea: TObject): IGMGetHandle; var prntObj: IGMGetParentObj; begin while AArea <> nil do begin if AArea.GetInterface(IGMGetHandle, Result) then Exit; GMCheckGetInterface(AArea, IGMGetParentObj, prntObj, {$I %CurrentRoutine%}); AArea := prntObj.ParentObj; end; Result := nil; end; function GMParentHandleAllocated(const AArea: TObject): Boolean; begin Result := GMIsHandleAllocated(GMFindWindowedParent(AArea)); end; function GMFindAllocatedParentHandle(const AArea: TObject; var AHandle: HWnd): Boolean; begin Result := GMGetAllocatedIntfHandle(GMFindWindowedParent(AArea), THandle(AHandle)); end; function GMModalDlgParentWndObj(const AParentWnd: TGMWndObj): TGMWndObj; var obj, dlg: TObject; wnd: HWnd; begin Result := 0; obj := GMObjFromWndObj(AParentWnd); if (obj <> nil) and GMFindParentDlg(obj, dlg) and GMGetAllocatedObjHandle(dlg, wnd) then Result := -Int64(dlg); if Result = 0 then Result := GMModalDlgParentWnd(GMHWndFromWndObj(AParentWnd)); end; function GMWindowClassList: IGMIntfArrayCollection; begin if vGMWindowClassList = nil then vGMWindowClassList := TGMIntfArrayCollection.Create(False, True, GMCompareByName); Result := vGMWindowClassList; end; function GMScreenRect: TRect; begin Result := GMRect(GetSystemMetrics(SM_XVIRTUALSCREEN), GetSystemMetrics(SM_YVIRTUALSCREEN), GetSystemMetrics(SM_XVIRTUALSCREEN) + GetSystemMetrics(SM_CXVIRTUALSCREEN), GetSystemMetrics(SM_YVIRTUALSCREEN) + GetSystemMetrics(SM_CYVIRTUALSCREEN)); end; function GMScreenSize: TPoint; begin Result := GMPoint(GetSystemMetrics(SM_CXVIRTUALSCREEN), GetSystemMetrics(SM_CYVIRTUALSCREEN)); end; function GMClientToScreen(const AArea: TObject; const APoint: TPoint): TPoint; var wnd: HWnd; begin Result := APoint; if not GMFindAllocatedParentHandle(AArea, wnd) then Exit; ClientToScreen(wnd, Result); end; function GMClientToScreen(const AArea: TObject; const ARect: TRect): TRect; begin Result.TopLeft := GMClientToScreen(AArea, ARect.TopLeft); Result.BottomRight := GMClientToScreen(AArea, ARect.BottomRight); end; function GMScreenToClient(const AArea: TObject; const APoint: TPoint): TPoint; var Wnd: HWnd; begin Result := APoint; if not GMFindAllocatedParentHandle(AArea, Wnd) then Exit; ScreenToClient(Wnd, Result); end; function GMScreenToClient(const AArea: TObject; const ARect: TRect): TRect; begin Result.TopLeft := GMScreenToClient(AArea, ARect.TopLeft); Result.BottomRight := GMScreenToClient(AArea, ARect.BottomRight); end; function GMAreaToScreen(const AArea: TObject; APoint: TPoint): TPoint; var area: IGMUiArea; begin if GMGetInterface(AArea, IGMUiArea, area) then APoint := GMAddPoints(APoint, area.ClientAreaOrigin); Result := GMClientToScreen(AArea, APoint); end; function GMScreenToArea(const AArea: TObject; const APoint: TPoint): TPoint; var area: IGMUiArea; begin Result := GMScreenToClient(AArea, APoint); if GMGetInterface(AArea, IGMUiArea, area) then Result := GMAddPoints(Result, area.ClientAreaOrigin, -1); end; function GMCalcPopupRect(const AArea: TObject; const ARequestedHeight, ASpace: LongInt): TRect; var area: IGMUiArea; rScreen: TRect; begin Result := cNullRect; if not GMGetInterface(AArea, IGMUiArea, area) then Exit; Result := GMClientToScreen(AArea, area.CalculateSurfaceRect(area.LayoutBounds)); rScreen := GMScreenRect; if (ARequestedHeight <= GMRectSize(rScreen).y - Result.Bottom - 1 - ASpace) or (GMRectSize(rScreen).y - Result.Bottom >= Result.Top) then begin Result.Top := Result.Bottom + 1 + ASpace; Result.Bottom := Min(rScreen.Bottom, Result.Top + ARequestedHeight); end else begin Result.Bottom := Result.Top - 1 - ASpace; Result.Top := Max(rScreen.Top, Result.Bottom - ARequestedHeight); end; end; function GMAreaBoundsOffset(const AContainerArea, AContainedArea: TObject): TRect; var PIPrnt: IGMGetParentObj; PIArea: IGMUiArea; begin //FillByte(Result, SizeOf(Result), 0); Result := Default(TRect); if not GMGetInterface(AContainedArea, IGMUiArea, PIArea) then Exit; Result := PIArea.LayoutBounds; if not GMGetInterface(AContainedArea, IGMGetParentObj, PIPrnt) then Exit; while PIPrnt.ParentObj <> AContainerArea do begin if PIPrnt.ParentObj = nil then Exit; if not GMGetInterface(PIPrnt.ParentObj, IGMUiArea, PIArea) then Exit; //Result := GMaddPoints(Result, PIArea.LayoutBounds.TopLeft); //OffsetRect(AreaRect, PIArea.LayoutBounds.TopLeft.x, PIArea.LayoutBounds.TopLeft.y); Result := GMMoveRect(Result, PIArea.LayoutBounds.TopLeft); if not GMGetInterface(PIPrnt.ParentObj, IGMGetParentObj, PIPrnt) then Exit; end; end; function GMOwnArea(const Owner, Area: TObject): TObject; begin if Area <> nil then (Owner as TGMUiAreaBase).OwnArea(Area); Result := Area; end; function GMRegisterWindowClass(const AWndClassName: TGMString; const ACursor: HCURSOR; const AClassStyle: DWORD; const AIcon: HICON; const ABkgndBrush: HBRUSH; const AMenuName: TGMString): IGMGetName; var searchName: IGMGetName; WndClass: IUnknown; begin searchName := TGMNameObj.Create(AWndClassName, True); if GMWindowClassList.Find(searchName, WndClass) then GMCheckQueryInterface(WndClass, IGMGetName, Result, {$I %CurrentRoutine%}) else begin Result := TGMWindowClass.Create(AWndClassName, AClassStyle, AIcon, ACursor, ABkgndBrush, AMenuName, True); GMWindowClassList.Add(Result); end; end; function GMIconInstance: THandle; begin Result := GetModuleHandle(nil); end; function TellIconRessourceName(hModule: HMODULE; lpszType: PGMChar; lpszName: PGMChar; Param: PtrInt): BOOL; stdcall; var Icon: HICON; begin if Param = 0 then begin Result := False; Exit; end; // <- Stop iteration Icon := LoadIcon(hModule, lpszName); if Icon <> 0 then begin PHIcon(Param)^ := Icon; Result := False; end else Result := True; end; function GMFindFirstIcon(const Module: HModule): HIcon; begin Result := LoadIcon(0, IDI_APPLICATION); EnumResourceNames(Module, Pointer(RT_GROUP_ICON), {$IFNDEF JEDIAPI}@{$ENDIF}TellIconRessourceName, PtrUInt(@Result)); end; function GMKeyDataToKeyState(const AKeyData: LongInt): SGMKeyStates; const cAltMask = $20000000; begin Result := []; if GetKeyState(VK_SHIFT) < 0 then Include(Result, ksShift); if GetKeyState(VK_CONTROL) < 0 then Include(Result, ksCtrl); if AKeyData and cAltMask <> 0 then Include(Result, ksAlt); end; function GMAreaHasWndHandle(const AArea: TObject): Boolean; var unk: IUnknown; begin Result := GMGetInterface(AArea, IGMGetHandle, unk); end; function GMIsEqualAlign(const AreaAlign1, AreaAlign2: TGMAreaAlignRec): Boolean; begin Result := CompareMem(@AreaAlign1.EdgeAlign, @AreaAlign2.EdgeAlign, SizeOf(AreaAlign1.EdgeAlign)); end; function GMIsAutoCalcHeight(const EdgeAlign: TEdgesAlign; const Bounds: TRect): Boolean; begin Result := ((EdgeAlign[edgBottom] in cCalcSizeAlignments) and (Bounds.Bottom = 0)) or ((EdgeAlign[edgTop] in cCalcSizeAlignments) and (Bounds.Top = 0)) or ((EdgeAlign[edgTop] = ealCentered) and (EdgeAlign[edgBottom] = ealCentered) and (GMRectSize(Bounds).y = 0)); end; function GMIsAutoCalcWidth(const EdgeAlign: TEdgesAlign; const Bounds: TRect): Boolean; begin Result := ((EdgeAlign[edgRight] in cCalcSizeAlignments) and (Bounds.Right = 0)) or ((EdgeAlign[edgLeft] in cCalcSizeAlignments) and (Bounds.Left = 0)) or ((EdgeAlign[edgLeft] = ealCentered) and (EdgeAlign[edgRight] = ealCentered) and (GMRectSize(Bounds).x = 0)); end; procedure GMCaptureMouseInput(const AArea: TObject); var parentWnd: HWnd; begin if AArea = nil then Exit; vGMMouseCaptureArea := AArea; if GMFindAllocatedParentHandle(AArea, parentWnd) then SetCapture(parentWnd); end; procedure GMReleaseMouseCapture; begin vGMMouseCaptureArea := nil; ReleaseCapture; end; procedure GMSetFocus(const AArea: TObject); var wndPrnt: HWnd; Dlg: TObject; //Fcs, Prnt: TObject; begin if (AArea = nil) or (AArea = vGMKeyboardFocusArea) or not GMFindAllocatedParentHandle(AArea, wndPrnt) then Exit; if GMFindParentDlg(AArea, Dlg) and (GMSendObjMessage(Dlg, WM_MOUSEACTIVATE) = MA_NOACTIVATE) then Exit; //Fcs := GMObjFromWnd(Getfocus); //Prnt := GMObjFromWnd(wndPrnt); if Getfocus <> wndPrnt then begin if GMObjFromWnd(Getfocus) <> vGMKeyboardFocusArea then GMCallObjWindowProc(vGMKeyboardFocusArea, WM_KILLFOCUS); if GMObjFromWnd(wndPrnt) <> AArea then vGMKeyboardFocusArea := AArea; // <- need to set vGMKeyboardFocusArea before WM_SETFOCUS is send to parent Window SetFocus(wndPrnt); end else begin GMCallObjWindowProc(vGMKeyboardFocusArea, WM_KILLFOCUS); GMCallObjWindowProc(AArea, WM_SETFOCUS); // <- will set vGMKeyboardFocusArea end; end; procedure GMCancelPopup; begin if vGMPopupArea <> nil then GMSendObjMessage(vGMPopupArea, WM_CANCELMODE); end; function GMAreaRegionFiller: IGMAreaFiller; begin if vGMAreaRegionFiller = nil then vGMAreaRegionFiller := TGMAreaRegionFiller.Create(True); Result := vGMAreaRegionFiller; end; function GMAreaRectFiller: IGMAreaFiller; begin if vGMAreaRectFiller = nil then vGMAreaRectFiller := TGMAreaRectFiller.Create(True); Result := vGMAreaRectFiller; end; function GMAssignRoundedAreaProperties(const AArea: TObject): TObject; begin Result := AArea; if AArea is TGMUiAreaBase then begin TGMUiAreaBase(AArea).CornerRounding := vGMDfltCornerRounding; TGMUiAreaBase(AArea).Frame := GMPanelAreaFrame; end; end; {function GMAreaAlignToLongInt(const Value: TGMAreaAlignRec): LongInt; begin Result := (Ord(Value[edgLeft]) shl 24) or (Ord(Value[edgTop]) shl 16) or (Ord(Value[edgRight]) shl 8) or Ord(Value[edgBottom]); end; function GMAreaAlignFromLongInt(const Value: LongInt): TGMAreaAlignRec; var Edge: TEdge; begin for Edge:=Low(Edge) to High(Edge) do Result[Edge] := TEdgeAlign(GMBoundedInt((Value and ($FF shl (Ord(Edge) * 8))) shr (Ord(Edge) * 8), Ord(Low(Edge)), Ord(High(Edge)))); end;} function GMSetSizeConstraints(const AArea: TObject; const AMinWidth, AMaxWidth, AMinHeight, AMaxHeight: LongInt): TObject; var PISizeCnstrnts: IGMGetSetSizeConstraints; Constraints: TGMSizeConstraintsRec; begin Result := AArea; if (AArea = nil) or not AArea.GetInterface(IGMGetSetSizeConstraints, PISizeCnstrnts) then Exit; Constraints := PISizeCnstrnts.GetSizeContraints; if AMinWidth <> cSizeCnstrNoChange then Constraints.MinWidth := AMinWidth; if AMaxWidth <> cSizeCnstrNoChange then Constraints.MaxWidth := AMaxWidth; if AMinHeight <> cSizeCnstrNoChange then Constraints.MinHeight := AMinHeight; if AMaxHeight <> cSizeCnstrNoChange then Constraints.MaxHeight := AMaxHeight; PISizeCnstrnts.SetSizeContraints(Constraints); end; function GMFrameExtent(const AFrame: IUnknown; const AEdges: TEdges = cAllEdges): TPoint; const cRDummy: TRect = (Left: 0; Top: 0; Right: 100; Bottom: 100); var frame: IGMAreaFrameDrawer; frameRect: TRect; begin Result := cNullPoint; if not GMQueryInterface(AFrame, IGMAreaFrameDrawer, frame) then Exit; frameRect := frame.CalculateClientRect(cRDummy); if edgLeft in AEdges then Inc(Result.x, frameRect.Left - cRDummy.Left); if edgTop in AEdges then Inc(Result.y, frameRect.Top - cRDummy.Top); if edgRight in AEdges then Inc(Result.x, cRDummy.Right - frameRect.Right); if edgBottom in AEdges then Inc(Result.y, cRDummy.Bottom - frameRect.Bottom); //Result := GMAddPoints(GMRectSize(cRDummy), GMRectSize(frameRect), -1); end; procedure GMSetObjAreaFrame(const AArea: TObject; const AFrame: IUnknown); var framedArea: IGMUiAreaFrame; frameDrawer: IGMAreaFrameDrawer; begin if not GMGetInterface(AArea, IGMUiAreaFrame, framedArea) or not GMQueryInterface(AFrame, IGMAreaFrameDrawer, frameDrawer) then Exit; framedArea.SetFrame(frameDrawer); end; function GMSetIntfMultifFrame(const Area: IUnknown; const InnerFrame: TFrameShape; const OuterFrame: TFrameShape; const FramedEdges: TEdges; const FrameKind: TFrameKind; const OuterSpace: LongInt; const FrameLook3D: Boolean): IUnknown; var PIDrawFrame: IGMAreaFrameDrawer; PIFrameProperties: IGMMultiFrameProperties; PIAreaFrame: IGMUiAreaFrame; begin Result := Area; if not GMQueryInterface(Area, IGMUiAreaFrame, PIAreaFrame) then Exit; PIDrawFrame := TGMAreaMultiFrame.Create; PIAreaFrame.Frame := PIDrawFrame; if not GMQueryInterface(PIDrawFrame, IGMMultiFrameProperties, PIFrameProperties) then Exit; PIFrameProperties.FrameKind := FrameKind; PIFrameProperties.InnerFrame := InnerFrame; PIFrameProperties.OuterFrame := OuterFrame; PIFrameProperties.FramedEdges := FramedEdges; PIFrameProperties.OuterSpace := OuterSpace; PIFrameProperties.FrameLook3D := FrameLook3D; end; function GMSetObjMultiFrame(const Area: TObject; const InnerFrame: TFrameShape; const OuterFrame: TFrameShape; const FramedEdges: TEdges = CAllEdges; const FrameKind: TFrameKind = frkTile; const OuterSpace: LongInt = 0; const FrameLook3D: Boolean = True): TObject; begin Result := Area; GMSetIntfMultifFrame(GMObjAsIntf(Area), InnerFrame, OuterFrame, FramedEdges, FrameKind, OuterSpace, FrameLook3D); end; function GMCalculateClientRect(const AFrame: IGMAreaFrameDrawer; const ABoundsRect: TRect): TRect; begin if AFrame = nil then Result := ABoundsRect else Result := AFrame.CalculateClientRect(ABoundsRect); end; //procedure GMPrintClientImpl(const Wnd: HWnd; const ADC: HDC; const Brush: HBRUSH); //var RClient: TRect; //begin // if (Wnd = 0) or (ADC = 0) or (Brush = 0) then Exit; // GetClientRect(Wnd, RClient); // FillRect(ADC, RClient, Brush); //end; // //function GMWndAnimationData: TGMWndAnimationData; //begin // Result.Animation := cDfltWndAnimation; // Result.Duration := cDfltWndAniDuration; //end; // //procedure GMRepaintArea(const Area: TObject); //var PIArea: IGMUiArea; //begin // if (Area = nil) or not Area.GetInterface(IGMUiArea, PIArea) then Exit; // PIArea.ScheduleRepaint; //end; procedure GMPaintWndFrame(const AWndObj: TGMWndObj); var Wnd: HWnd; begin Wnd := GMHWndFromWndObj(AWndObj); if (Wnd = 0) or (GetWindowLong(Wnd, GWL_STYLE) and WS_VISIBLE = 0) then Exit; SendMessage(Wnd, WM_NCPAINT, 1, 0); end; procedure GMReLayoutContainedAreas(const AArea: TObject; const ARepaint: Boolean; const ARecurse: Boolean); var layoutArea: IGMUiArea; layoutRoot: TObject; begin if (AArea = nil) or not AArea.GetInterface(IGMUiArea, layoutArea) then Exit; layoutRoot := layoutArea.RootForRelayout; if (layoutRoot = nil) or not layoutRoot.GetInterface(IGMUiArea, layoutArea) then Exit; if ARecurse then begin layoutArea.InvalidateCachedLayoutValues; layoutArea.LayoutContainedAreasIfNeeded(ARepaint); // layoutArea.LayoutContainedAreas(ARepaint); end else layoutArea.LayoutContainedAreas(ARepaint); if ARepaint then layoutArea.ScheduleRepaint; // <- childs may have moved and dont completely cover the area end; procedure GMScheduleRepaint(const Area: TObject); var PIArea: IGMUiArea; begin if (Area <> nil) and Area.GetInterface(IGMUiArea, PIArea) then PIArea.ScheduleRepaint; end; function GMParentRootForRelayout(const Area: TObject): TObject; var PIParent: IGMGetParentObj; PIArea: IGMUiArea; begin Result := Area; if (Area = nil) or not Area.GetInterface(IGMGetParentObj, PIParent) then Exit; if (PIParent.ParentObj = nil) or not PIParent.ParentObj.GetInterface(IGMUiArea, PIArea) then Exit; Result := PIArea.RootForRelayout; // <- recursive! end; function APIAnimateWindowProcAddr: Pointer; var HUser32: THandle; begin HUser32 := GetModuleHandle('user32.dll'); if HUser32 <> 0 then Result := GetProcAddress(HUser32, 'AnimateWindow') else Result := nil; end; function GMAnimateWindow(Wnd: HWND; dwTime: DWORD; dwFlags: DWORD): BOOL; var fAPIAnimateWindow: function (Wnd: HWND; dwTime: DWORD; dwFlags: DWORD): BOOL; stdcall; begin // // Windows NT does not have AnimateWindow // @fAPIAnimateWindow := APIAnimateWindowProcAddr; if not Assigned(fAPIAnimateWindow) then Result := ShowWindow(Wnd, cSWShow[dwFlags and AW_HIDE = 0]) else begin Result := fAPIAnimateWindow(Wnd, dwTime, dwFlags); if not Result then begin Result := ShowWindow(Wnd, cSWShow[dwFlags and AW_HIDE = 0]) {ToDo: AnimateWindow Sometimes returns "Access denied" on XP, why?} {ToDo: AnimateWindow for popup windows works only on the second call why? First call returns: Accessing invalid token} // GMTrace('AnimateWindow: ' + GMSysErrorMsg(LongInt(GetLastError), []), tpError); // Result := fAPIAnimateWindow(Wnd, dwTime, dwFlags); // if not Result then GMTrace('AnimateWindow: ' + GMSysErrorMsg(LongInt(GetLastError), []), tpError); end; end; end; procedure GMShowWindowAnimated(const AWnd: HWnd; const AShowKind: TGMShowWndKind); const cAnimateWnd: array [Boolean, Boolean] of DWORD = ((AW_HIDE, AW_HIDE), (0, AW_ACTIVATE)); begin if not IsWindow(AWnd) then Exit; if (AShowKind in [swShowNormal, swShowNoActivate, swHide]) and (vGMWndAniDuration > 0) and (vGMWndAnimation <> 0) then GMAnimateWindow(AWnd, vGMWndAniDuration, vGMWndAnimation or cAnimateWnd[AShowKind in [swShowNormal, swShowNoActivate], AShowKind = swShowNormal]) else ShowWindow(AWnd, cShowWndFlags[AShowKind]); end; procedure GMExecPendingPainting(const AArea: TObject); var Wnd: HWnd; begin if GMFindAllocatedParentHandle(AArea, Wnd) then UpdateWindow(Wnd); //GMProcessMessages([WM_NCPAINT, WM_PAINT]); end; //procedure GMHideAndShowWnd(const WndObj: TGMWndObj); //var Wnd: HWnd; //begin // Wnd := GMHWndFromWndObj(WndObj); // if (Wnd = 0) or (GetWindowLong(Wnd, GWL_STYLE) and WS_VISIBLE = 0) then Exit; // ShowWindow(Wnd, SW_HIDE); // ShowWindow(Wnd, SW_SHOW); //end; function CloseThreadWndFunc(Wnd: HWnd; Param: LParam): BOOL; stdcall; begin Result := True; Wnd := GMDlgRootWindow(Wnd); if not IsWindow(Wnd) or (Wnd = HWnd(Param)) or (GetWindowLong(Wnd, GWL_STYLE) and WS_CHILD <> 0) or (GetWindowLong(Wnd, GWL_STYLE) and WS_VISIBLE = 0) then Exit; SendMessage(Wnd, WM_CLOSE, IDCANCEL, 0); end; procedure GMCloseAllThreadWindows(const ACallingWnd: HWnd); begin // // Should be called only by main thread. // Windows of other threads will be closed by the system when the threads are terminated/destroyed. // EnumThreadWindows(GetCurrentThreadID, {$IFNDEF JEDIAPI}@{$ENDIF}CloseThreadWndFunc, LPARAM(ACallingWnd)); end; function ReloadWndWithNewLanguage(Wnd: HWnd; Param: LParam): BOOL; stdcall; begin Result := True; Wnd := GMDlgRootWindow(Wnd); if Wnd <> 0 then SendMessage(Wnd, UM_LANGUAGECHANGED, 0, Param); end; procedure GMLoadNewLanguageToUI(const ANewLanguage: LangId); begin EnumThreadWindows(GetCurrentThreadID, {$IFNDEF JEDIAPI}@{$ENDIF}ReloadWndWithNewLanguage, ANewLanguage); end; function GMResTextRefDataRec(const AResStringPtr: PResStringRec; const AFormatStr: TGMString = ''): RGMResTextRefData; begin Result.ResStringPtr := AResStringPtr; Result.FormatStr := AFormatStr; end; function GMMakeResRefText(const AResStringRecPtr: Pointer; const AFormatString: TGMString): TGMString; begin Result := GMStringJoin(cResTextRefPrefix + '$' + GMIntToHexStr(PtrInt(AResStringRecPtr)), cResTextFmtSeparator, AFormatString); end; function GMResolveTextResData(const AText: TGMString; var ATextResData: RGMResTextRefData): TGMString; var resPtr: PtrUInt; convCode: Integer; chPos: PtrInt; token: TGMString; begin Result := AText; //ATextResData := GMResTextRefDataRec(nil); if GMIsPrefixStr(cResTextRefPrefix, AText) then begin chPos := Length(cResTextRefPrefix) + 1; token := GMNextWord(chPos, AText, cResTextFmtSeparator); Val(token, resPtr, convCode); if (convCode = 0) and not IsBadReadPtr(Pointer(resPtr), SizeOf(TResStringRec)) then ATextResData.ResStringPtr := Pointer(resPtr); ATextResData.FormatStr := Copy(AText, chPos, Length(AText) - chPos + 1); Result := GMBuildTextFromResRef(ATextResData, ''); end; end; function GMBuildTextFromResRef(const ATextResData: RGMResTextRefData; const AText: TGMString): TGMString; begin if ATextResData.ResStringPtr = nil then Result := AText else begin Result := LoadResString(ATextResData.ResStringPtr); if Length(ATextResData.FormatStr) > 0 then Result := GMFormat(ATextResData.FormatStr, [Result]); end; end; function GMNextCtrlID: PtrInt; begin if vGMNextCtrlId >= High(Word) then vGMNextCtrlId := 1 else Inc(vGMNextCtrlId); Result := vGMNextCtrlId; end; function GMVisitAllChildAreas(const AArea: TObject; const AVisitFunc: TGMObjVisitFunc; const AAreasToIgnore: array of TObject; const ARecurse: Boolean; const AData: Pointer): Boolean; var PIArea: IGMUiArea; i: LongInt; function IgnoreArea(const AArea: TObject): Boolean; var i: LongInt; begin for i:=Low(AAreasToIgnore) to High(AAreasToIgnore) do if AAreasToIgnore[i] = AArea then begin Result := True; Exit; end; Result := False; end; begin Result := True; if not Assigned(AVisitFunc) or (AArea = nil) or not AArea.GetInterface(IGMUiArea, PIarea) then Exit; for i:=0 to PIArea.ContainedAreas.Count-1 do begin if IgnoreArea(PIArea.ContainedAreas[i]) then Continue; Result := AVisitFunc(PIArea.ContainedAreas[i], AData) and (not ARecurse or GMVisitAllChildAreas(PIArea.ContainedAreas[i], AVisitFunc, AAreasToIgnore, ARecurse, AData)); if not Result then Exit; end; end; function ClearArea(const AArea: TObject; const AData: Pointer): Boolean; var clear: IGMClear; begin if GMGetInterface(AArea, IGMClear, clear) then clear.Clear; //GMExecuteOperation(AArea, Ord(opClear)); Result := True; end; procedure GMClearControls(const AArea: TObject; const ARecurse: Boolean; const AAreasToIgnore: array of TObject); begin GMVisitAllChildAreas(AArea, ClearArea, AAreasToIgnore, ARecurse, nil); end; function EnableArea(const AArea: TObject; const AData: Pointer): Boolean; const cOperation: array [Boolean] of LongInt = (Ord(goDisable), Ord(goEnable)); begin GMExecuteOperation(AArea, cOperation[AData <> nil]); Result := True; end; procedure GMEnableControls(const AArea: TObject; const AEnable, ARecurse: Boolean; const AAreasToIgnore: array of TObject); const cBoolPtr: array [Boolean] of Pointer = (nil, Pointer(1)); begin GMVisitAllChildAreas(AArea, EnableArea, AAreasToIgnore, ARecurse, cBoolPtr[AEnable]); end; function GMCompareByUIPosition(const ItemA, ItemB: IUnknown): TGMCompareResult; const cTolerance = 5; var AreaA, AreaB: IGMUiArea; uiPosA, uiPosB: TPoint; Wnd: HWnd; begin GMCheckQueryInterface(ItemA, IGMUiArea, AreaA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMUiArea, AreaB, {$I %CurrentRoutine%}); //uiPosA := AreaA.CalculateSurfaceRect(AreaA.LayoutBounds).TopLeft; // <- dont use PaintingRect here, it would return 0,0 for windowed controls uiPosA := AreaA.PaintingRect.TopLeft; if GMFindAllocatedParentHandle(GMObjFromIntf(AreaA), Wnd) then ClientToScreen(Wnd, uiPosA); //uiPosB := AreaB.CalculateSurfaceRect(AreaB.LayoutBounds).TopLeft; // <- dont use PaintingRect here, it would return 0,0 for windowed controls uiPosB := AreaB.PaintingRect.TopLeft; // <- dont use PaintingRect here, it would return 0,0 for windowed controls if GMFindAllocatedParentHandle(GMObjFromIntf(AreaB), Wnd) then ClientToScreen(Wnd, uiPosB); if GMIsInRange(uiPosA.y, uiPosB.y - cTolerance, uiPosB.y + cTolerance) then Result := crAEqualToB else if uiPosA.y < uiPosB.y then Result := crALessThanB else Result := crAGreaterThanB; if Result = crAEqualToB then if GMIsInRange(uiPosA.x, uiPosB.x - cTolerance, uiPosB.x + cTolerance) then Result := crAEqualToB else if uiPosA.x < uiPosB.x then Result := crALessThanB else Result := crAGreaterThanB; end; function GMAreaIsShowing(const AArea: TObject): Boolean; var parent: IGMGetParentObj; area: IGMUiArea; begin Result := ((AArea is TGMWindow) and (TGMWindow(AArea).WndStyle and WS_VISIBLE <> 0)) or (not (AArea is TGMWindow) and GMGetInterface(AArea, IGMUiArea, area) and area.Visible and GMGetInterface(AArea, IGMGetParentObj, parent) and GMAreaIsShowing(parent.ParentObj)); end; function GMFindNextDlgTabAreaByUIPosition(const ADlg, AStartArea: TObject; const AReverse: Boolean): TObject; var tabAreas: IGMObjArrayCollection; dlg: IGMUiArea; idx: PtrInt; procedure FindAllTabAreas(const ATabAreas: IGMObjCollection); var area: TObject; areaIntf: IGMUiArea; areaIt: IGMIterator; begin if ATabAreas = nil then Exit; areaIt := ATabAreas.CreateIterator; while areaIt.Nextentry(area) do // for i:=0 to ATabAreas.Count-1 do if GMAreaIsShowing(area) and GMGetInterface(area, IGMUiArea, areaIntf) and areaIntf.GetEnabled then begin if areaIntf.IsTabstop then tabAreas.Add(area); FindAllTabAreas(areaIntf.ContainedAreas); end; end; begin Result := nil; if not GMGetInterface(ADlg, IGMUiArea, dlg) then Exit; tabAreas := TGMObjArrayCollection.Create(False, True, True, GMCompareByUIPosition, True); FindAllTabAreas(dlg.ContainedAreas); if tabAreas.IsEmpty then Exit; idx := tabAreas.IndexOfObj(AStartArea); if idx = cInvalidItemIdx then idx := 0 else begin if AReverse then Dec(idx) else Inc(idx); if idx < 0 then idx := tabAreas.Count-1; if idx >= tabAreas.Count then idx := 0; end; Result := tabAreas[idx]; end; function GMCalcHintShowTimeMS(const AText: TGMString): LongInt; begin //Result := 3000 + GMWordCount(AText, cWhiteSpace + '&/\=+*-,.;:') * 330; Result := GMBoundedInt(3000 + ((Length(AText) div 5) * 330), 1000, High(SmallInt)); // <- the high word must be zero, interpreted as signed 16-Bit value! end; //procedure GMNotifyCursorChange; //var CurPos: TPoint; //begin // CurPos := GMMousePosition; // SetCursorPos(CurPos.x, CurPos.y); // <- trigger system to send a WM_SETCURSOR message // GMProcessMessages([WM_SETCURSOR]); //end; function GMFindDfltDlgCtrl(const AParentArea: TObject; var ADefaultCtrl: IGMIsDefaultDlgBtn): Boolean; var PIArea, PIChildArea: IGMUiArea; i: LongInt; begin Result := False; if not GMGetInterface(AParentArea, IGMUiArea, PIArea) then Exit; for i:=0 to PIArea.ContainedAreas.Count-1 do if GMAreaIsShowing(PIArea.ContainedAreas[i]) and GMGetInterface(PIArea.ContainedAreas[i], IGMUiArea, PIChildArea) and PIChildArea.GetEnabled then begin Result := GMQueryInterface(PIChildArea, IGMIsDefaultDlgBtn, ADefaultCtrl) and ADefaultCtrl.IsDefaultDlgBtn; if not Result then Result := GMFindDfltDlgCtrl(PIArea.ContainedAreas[i], ADefaultCtrl); if Result then Break else ADefaultCtrl := nil; end; end; //function GMCompareByWndMessage(const ItemA, ItemB: IUnknown): TGMCompareResult; //var MsgObjA, MsgObjB: IGMWndMessage; //begin // GMCheckQueryInterface(ItemA, IGMWndMessage, MsgObjA, {$I %CurrentRoutine%}); // GMCheckQueryInterface(ItemB, IGMWndMessage, MsgObjB, {$I %CurrentRoutine%}); // if MsgObjA.WndMessage > MsgObjB.WndMessage then Result := crAGreaterThanB else // if MsgObjA.WndMessage = MsgObjB.WndMessage then Result := crAEqualToB else // Result := crALessThanB; //end; procedure GMSetFontColor(const AUIArea: IUnknown; const AColor: COLORREF); var setFontColor: IGMSetFonColor; begin if GMQueryInterface(AUIArea, IGMSetFonColor, setFontColor) then setFontColor.SetFontColor(AColor); end; { -------------------------- } { ---- Window Procedure ---- } { -------------------------- } function GMHWndFromWndObj(const AWndObj: TGMWndObj): HWnd; begin if AWndObj >= 0 then Result := HWnd(AWndObj) else try if not GMGetAllocatedObjHandle(TObject(-AWndObj), THandle(Result)) then Result := 0; except Result := 0; end; if not IsWindow(Result) then Result := 0; // <- dont use GMIsWindow here -> endless recursion end; function GMObjFromWndObj(const WndObj: TGMWndObj): TObject; begin if WndObj < 0 then Result := TObject(-WndObj) else Result := nil; end; function GMIsWindow(const AWindow: TGMWndObj): Boolean; //var Wnd: HWnd; begin Result := AWindow <> 0; //Wnd := GMHWndFromWndObj(AWindow); //Result := (Wnd <> 0) and IsWindow(Wnd); end; function GMDlgParentWndFromObj(const AObj: TObject): HWnd; var Dlg: TObject; begin if GMFindParentDlg(AObj, Dlg) then Result := GMModalDlgParentWnd(GMHWndFromWndObj(-Int64(Dlg))) else Result := 0; end; function GMObjFromWnd(const AHWnd: HWnd): TObject; begin Result := nil; if AHWnd <> 0 then try Result := TObject(GetWindowLongPtr(AHWnd, cWndObjPtrData)); if Result <> nil then Result.ClassType; // <- just call something to see if it really is a TObject (otherwise an exception is thrown). And use it to avoid compiler hint except Result := nil; end; end; function GMStdWndProc(AWnd: HWND; AMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; // // Works only for classes derived from TGMWindow, but should be a bit faster than getting 3 interfaces // var Obj: TObject; Msg: TMessage; // PIHandle: IGMGetHandle; PIHAlloc: IGMHandleAllocated; WndProc: IGMMessageHandler; begin // The message handling code has high impact on performance! Everything done here should be as simple and fast as possible! //try Result := 0; if AWnd <> 0 then begin Obj := GMObjFromWnd(AWnd); if Obj is TGMWindow then // <- should be a bit faster than getting 3 interfaces with TGMWindow(Obj) do // with Obj as TGMWindow do begin _AddRef; // <- put an additional reference on the window object for the scope of this call. In case the object is // RefLifeTime and releases the last reference to itself when handling this message (e.g. WM_NCDESTROY). // The additional reference will do no harm if the window object is not RefLifeTime. try if {HandleAllocated} (AWnd <> 0) and (FHandle = AWnd) then begin Msg := GMMessageRec(AMsg, wParam, lParam, Result); WindowProc(Msg); //WndProc.WindowProc(Msg); Result := Msg.Result; end; finally _Release; // <- remove the additional reference now that we are done with this call, may cause freeing the window object end; end; end; //except // The modal message loop needs the exceptions to be handled there! // on ex: TObject do begin vfGMHrExceptionHandler(ex, cDfltPrntWnd); Result := 0; end; //end; end; function GMStdIWndProc(Wnd: HWND; AMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; // // Interfaced version for classes not derived from TGMWindow, works for TGMWindow decendants too // var obj: TObject; msg: TMessage; handle: IGMGetHandle; hAlloc: IGMHandleAllocated; wndProc: IGMMessageHandler; begin //try Result := 0; if Wnd <> 0 then begin obj := GMObjFromWnd(Wnd); if (obj <> nil) and (not obj.GetInterface(IGMHandleAllocated, hAlloc) or hAlloc.HandleAllocated) and obj.GetInterface(IGMGetHandle, handle) and (handle.Handle = Wnd) and obj.GetInterface(IGMMessageHandler, wndProc) then begin msg := GMMessageRec(AMsg, wParam, lParam, Result); //WindowProc(msg); wndProc.WindowProc(msg); Result := msg.Result; end; end; //except // on ex: TObject do begin vfGMHrExceptionHandler(ex, cDfltPrntWnd); Result := 0; end; //end; end; { ----------------------- } { ---- Message Loops ---- } { ----------------------- } procedure GMCallInitProcs; begin if InitProc <> nil then TProcedure(InitProc); end; function GMCallTerminateProcs: Boolean; begin if vGMTerminateProcsCalled then begin Result := True; Exit; end; if ExitProc <> nil then TProcedure(ExitProc); vGMTerminateProcsCalled := CallTerminateProcs; Result := vGMTerminateProcsCalled; if Result then PostQuitMessage(0); end; procedure GMApplicationMessageLoop; var Msg: TMsg; begin while True do try WaitMessage; while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin case Msg.message of // WM_QUERYENDSESSION is handeled by TGMMainWindow //WM_QUIT: begin ExitCode := GMWndStackCloseAll(0, IDABORT); Exit; end; // <- NOTE: Exit here! WM_QUIT: begin ExitCode := GMWndStackCloseAll(0, ExitCode); Exit; end; // <- NOTE: Exit here! WM_ENDSESSION: if Msg.wParam <> cFalseInt then Exit; // <- NOTE: Exit here! // WM_KEYDOWN, WM_KEYUP, WM_CHAR: // if Msg.wParam in [VK_RETURN, VK_ESCAPE, VK_TAB] then // begin // if not IsDialogMessage(Msg.hwnd, Msg) then GMTranslateAndDispatchMsg(Msg); // Continue; // end; end; //if not IsDialogMessage(Msg.hwnd, Msg) then GMTranslateAndDispatchMsg(Msg); end; except on ex: TObject do vfGMHrExceptionHandler(ex, cDfltPrntWnd); end; end; function EnumWindowToArrayFunc(wnd: HWnd; param: LPARAM): BOOL; stdcall; //var wndClassName: TGMString; begin Result := True; // <- continue iteration if param = 0 then Exit; wnd := GMDlgRootWindow(wnd); if IsWindow(wnd) and IsWindowEnabled(wnd) and (wnd <> vGMModalWnd) and (GetWindowLong(wnd, GWL_STYLE) and WS_VISIBLE <> 0) and not GMIsOneOfIntegers(PtrInt(wnd), PGMPtrIntArray(param)^) and (wnd <> GetDesktopWindow) then begin //SetLength(wndClassName, 255); //SetLength(wndClassName, GetClassName(wnd, PGMChar(wndClassName), Length(wndClassName))); // //if CompareText(wndClassName, 'tooltips_class32') = 0 then Exit; //if CompareText(wndClassName, 'TAppWindow') = 0 then Exit; GMAddIntegersToArray(PGMPtrIntArray(param)^, [PtrInt(wnd)]); end; end; function GMShowModalWnd(AModalWnd: TGMWndObj; const AShowKind: TGMShowWndKind): PtrInt; var oldModalWnd, oldForeGroundWnd: HWnd; disabledWindows: TGMPtrIntArray; modalDlg: TGMDlgWindow; procedure DisableAllOtherwindows; var wnd: PtrInt; begin SetLength(disabledWindows, 0); EnumThreadWindows(GetCurrentThreadID, {$IFNDEF JEDIAPI}@{$ENDIF}EnumWindowToArrayFunc, LPARAM(@disabledWindows)); if GetCurrentThreadID <> gGMMainThreadID then EnumThreadWindows(gGMMainThreadID, {$IFNDEF JEDIAPI}@{$ENDIF}EnumWindowToArrayFunc, LPARAM(@disabledWindows)); for wnd in disabledWindows do EnableWindow(HWnd(wnd), False); end; procedure ReEnableOtherWindows; var wnd: PtrInt; begin for wnd in disabledWindows do EnableWindow(HWnd(wnd), True); SetLength(disabledWindows, 0); end; function ModalMessageLoop(const AModalWnd: HWnd): WPARAM; var Msg: TMsg; begin Result := IDCANCEL; if not IsWindow(AModalWnd) then Exit; while True do try WaitMessage; while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin if (Msg.message = WM_CLOSE) and (Msg.hwnd = vGMModalWnd) then begin // ReEnableOtherWindows must be done before the modal dialog window is closed! // Otherwise the system cannot re-activate the window that was active before the modal dialog was displayed. // NOTE: modalDlg.CanClose may raise! if (modalDlg <> nil) and not modalDlg.CanClose(Msg.wParam = IDOK) then Continue; // <- NOTE: may skip rest of the loop! ReEnableOtherWindows; end; //Result := GMTranslateAndDispatchMsg(Msg); if (Msg.message = WM_CLOSE) and (Msg.hwnd = vGMModalWnd) then Exit(Msg.wParam); // <- NOTE: May Exit Here! // When the close button of a window is pressed the WM_CLOSE message will be send directly to the WndProc of the // corresponding window and we will NOT see that WM_CLOSE message here! // Or another thread handled the Message in a MsgWaitForMultipleObjects wait condition. // So this is the emergency exit if the modal window has gone by means we cannot see here. if not Iswindow(vGMModalWnd) then Exit(IDCANCEL); end; except on ex: TObject do Result := vfGMHrExceptionHandler(ex, AModalWnd); end; end; begin Result := IDCANCEL; AModalWnd := GMHWndFromWndObj(AModalWnd); if not GMIsWindow(AModalWnd) then Exit; if GMObjFromWnd(AModalWnd) is TGMDlgWindow then modalDlg := TGMDlgWindow(GMObjFromWnd(AModalWnd)) else modalDlg := nil; oldForeGroundWnd := GMActiveProcessWindow; oldModalWnd := vGMModalWnd; try vGMModalWnd := AModalWnd; GMPushModalDlgWnd(AModalWnd); try GMShowWindowAnimated(AModalWnd, AShowKind); //BringWindowToTop(AModalWnd); //SetForeGroundwindow(Dlg.Handle); DisableAllOtherwindows; try Result := ModalMessageLoop(AModalWnd); finally ReEnableOtherWindows; // <- should already have been done by ModalMessageLoop, but when a thread MsgWait.. function has handled the WM_CLOSE message we need to do this here! Does no harm if done twice! end; finally GMPopModalDlgWnd; SetForegroundWindow(oldForeGroundWnd); //BringWindowToTop(GMTopwindow); //SetActiveWindow(GMTopwindow); end; finally vGMModalWnd := oldModalWnd; end; end; function GMShowModalDlg(const ADlgWndClass: TGMDlgWindowClass; const AShowKind: TGMShowWndKind; const ADlgData: Pointer; const ATitle: TGMString; const AParent: TGMWndObj): PtrInt; var dlg: TGMDlgWindow; begin Result := IDCANCEL; if ADlgWndClass = nil then Exit; dlg := ADlgWndClass.Create(cNullRect, 0, cPrntWndExStyle, ATitle, {ParentWnd}AParent, ADlgData); try Result := GMShowModalWnd(dlg.Handle, AShowKind); finally dlg.Free; end; end; function GMWndSizeFromClientSize(const AClientSize: TPoint; const AWndStyle, AWndExStyle: DWORD; const AHasMEnu: Boolean): TPoint; const cOffs = 100; var R: TRect; begin R := GMRect(cOffs, cOffs, AClientSize.x + cOffs, AClientSize.y + cOffs); if AdjustWindowRectEx(R, AWndStyle, AHasMEnu, AWndExStyle) then Result := GMRectSize(R) else begin GMTrace('AdjustWindowRectEx: ' + GMSysErrorMsg(LongInt(GetLastError), []), tpError); Result := AClientSize; end; end; function GMCalcMsgDlgClientSize(const AMsgText: TGMString; const AFont: HFont; const ADlgMinSize, AExtraSize: TPoint; var AVScrollBarNeeded: Boolean): TPoint; var maxTxtSize: LongInt; begin // Calculate size without wrapping first Result := GMCalcTextAreaSize(AMsgText, GMPoint(10, 10), cNullPoint, cNullPoint, AFont, DT_NOCLIP or DT_NOPREFIX); // Limit width to half of the screen Result.x := Min(Result.x, (GetSystemMetrics(SM_CXSCREEN) div 2) - AExtraSize.x); // Now calculate again with word wrapping Result := GMCalcTextAreaSize(AMsgText, GMPoint(Result.x, 10), cNullPoint, cNullPoint, AFont, DT_NOCLIP or DT_NOPREFIX or DT_WORDBREAK); maxTxtSize := (GetSystemMetrics(SM_CYSCREEN) div 2) - AExtraSize.y; AVScrollBarNeeded := Result.y > maxTxtSize; Result.y := Min(Result.y, maxTxtSize); Result := GMAddPoints(Result, AExtraSize); Result.x := Max(Result.x, ADlgMinSize.x); Result.y := Max(Result.y, ADlgMinSize.y); if AVScrollBarNeeded then Inc(Result.x, GetSystemMetrics(SM_CXVSCROLL)); end; { ---------------------------- } { ---- Rectangle Routines ---- } { ---------------------------- } function GMRectCenterX(const RInner, ROuter: TRect): TRect; var RSize: TPoint; begin Result.Top := RInner.Top; Result.Bottom := RInner.Bottom; RSize := GMRectSize(RInner); Result.Left := ((ROuter.Left + ROuter.Right) div 2) - (RSize.x div 2); Result.Right := Result.Left + RSize.x; end; function GMRectCenterY(const RInner, ROuter: TRect): TRect; var RSize: TPoint; begin Result.Left := RInner.Left; Result.Right := RInner.Right; RSize := GMRectSize(RInner); Result.Top := ((ROuter.Top + ROuter.Bottom) div 2) - (RSize.y div 2); Result.Bottom := Result.Top + RSize.y; end; function GMLimitRectToScreen(const ARect: TRect; const Edges: TEdges = CAllEdges): TRect; var rScreen: TRect; begin Result := ARect; rScreen := GMScreenRect; //GMRect(GetSystemMetrics(SM_XVIRTUALSCREEN), GetSystemMetrics(SM_YVIRTUALSCREEN), // GetSystemMetrics(SM_XVIRTUALSCREEN) + GetSystemMetrics(SM_CXVIRTUALSCREEN), // GetSystemMetrics(SM_YVIRTUALSCREEN) + GetSystemMetrics(SM_CYVIRTUALSCREEN)); if ([edgLeft, edgRight] <= Edges) and (Result.Right > rScreen.Right) then Result := GMMoveRect(Result, rScreen.Right - Result.Right, 0); if (edgLeft in Edges) and (Result.Left < rScreen.Left) then Result := GMMoveRect(Result, rScreen.Left - Result.Left, 0); if edgRight in Edges then Result.Right := Min(Result.Right, rScreen.Right); if ([edgTop, edgBottom] <= Edges) and (Result.Bottom > rScreen.Bottom) then Result := GMMoveRect(Result, 0, rScreen.Bottom - Result.Bottom); if (edgTop in Edges) and (Result.Top < rScreen.Top) then Result := GMMoveRect(Result, 0, rScreen.Top - Result.Top); if edgBottom in Edges then Result.Bottom := Min(Result.Bottom, rScreen.Bottom); end; function GMAreaRect(Left, Top, Width, Height: LongInt): TRect; begin if Left = CInvalidUIPos then Left := 50; if Top = CInvalidUIPos then Top := 50; if Width = CInvalidUIPos then Width := Round(GetSystemMetrics(SM_CXFULLSCREEN) * 0.33); if Height = CInvalidUIPos then Height := Round(GetSystemMetrics(SM_CYFULLSCREEN) * 0.66); Result := GMRect(Left, Top, Left + Width, Top + Height); end; function GMAreaAlign(const Left, Top, Right, Bottom: TEdgeAlign; const ShrinkRestX: Boolean; const ShrinkRestY: Boolean): TGMAreaAlignRec; begin Result.EdgeAlign[edgLeft] := Left; Result.EdgeAlign[edgTop] := Top; Result.EdgeAlign[edgRight] := Right; Result.EdgeAlign[edgBottom] := Bottom; Result.ShrinkRestX := ShrinkRestX; Result.ShrinkRestY := ShrinkRestY; end; function GMSplitDirectionFromAlign(const AAlign: TEdgesAlign; const ASpace: TRect): TGM2DDirection; begin if (AAlign[edgLeft] = ealAligned) and (ASpace.Left < cQAlign) and (AAlign[edgRight] = ealAligned) and (ASpace.Right < cQAlign) then Result := d2dVertical else Result := d2dHorizontal; end; function GMDesktopClientRect: TRect; begin Result := cNullRect; GetClientRect(GetDesktopWindow, Result); end; function GMCenteredWndRect(const WndSize: TPoint; const Parent: TGMWndObj): TRect; var prntRect: TRect; parentWnd: HWnd; begin parentWnd := GMModalDlgParentWnd(GMHWndFromWndObj(Parent)); if IsWindow(parentWnd) and (GetWindowLong(parentWnd, GWL_STYLE) and WS_VISIBLE <> 0) then GetWindowRect(parentWnd, prntRect) else prntRect := GMDesktopClientRect; Result := GMLimitRectToScreen(GMCenterExtentInRect(WndSize, prntRect)); end; function GMLoadRect(const Source: IGMValueStorage; const DirPath, RectName: TGMString; const DefaultRect: TRect): TRect; var threadSync: RGMCriticalSectionLock; dirKeeper: IUnknown; begin try Result := DefaultRect; threadSync.Lock(Source); dirKeeper := TGMVsdDirPathKeeper.Create(Source); if (DirPath = '') or GMVsdOpenDir(Source, DirPath, False) then Result := GMReadRect(Source, RectName, DefaultRect); except Result := DefaultRect; end; end; procedure GMStoreRect(const Dest: IGMValueStorage; const DirPath, RectName: TGMString; const Value: TRect); var threadSync: RGMCriticalSectionLock; dirKeeper: IUnknown; begin //try if (Dest = nil) or (DirPath = '') then Exit; threadSync.Lock(Dest); dirKeeper := TGMVsdDirPathKeeper.Create(Dest, DirPath, True); GMWriteRect(Dest, RectName, Value); //except end; end; function GMLoadDlgRect(const ASource: IGMValueStorage; const ALoadPath, ARectName: TGMString; const ADlgSize: TPoint; const AParent: TGMWndObj): TRect; begin Result := GMLimitRectToScreen(GMLoadRect(ASource, ALoadPath, ARectName, GMCenteredWndRect(ADlgSize, AParent))); end; function GMLoadDlgRect(const ASource: IGMValueStorage; const ALoadPath, ARectName: TGMString; const ADlgRect: TRect): TRect; overload; begin Result := GMLimitRectToScreen(GMLoadRect(ASource, ALoadPath, ARectName, ADlgRect)); end; procedure GMGradientFillRect(const ADC: HDC; const Color1, Color2: COLORREF; const ARect: TRect; const Direction: TGM2DDirection); const cFill: array [TGM2DDirection] of DWORD = (GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V); var Vertexes: array [0..1] of {$IFNDEF JEDIAPI}TGMTriVertexRec{$ELSE}TTriVertex{$ENDIF}; RGradient: GRADIENT_RECT; function WordColor(Value: Byte): Word; begin Result := Round((Value / $FF) * $FF00); end; begin Vertexes[0] := GMTriVertex(ARect.TopLeft, WordColor(GetRValue(Color1)), WordColor(GetGValue(Color1)), WordColor(GetBValue(Color1))); Vertexes[1] := GMTriVertex(ARect.BottomRight, WordColor(GetRValue(Color2)), WordColor(GetGValue(Color2)), WordColor(GetBValue(Color2))); RGradient.UpperLeft := 0; RGradient.LowerRight := 1; GMAPICheckObj('GradientFill', '', GetLastError, {$IFNDEF JEDIAPI}GMGradientFill{$ELSE}GradientFill{$ENDIF} (ADC, @Vertexes[0], 2, @RGradient, 1, cFill[Direction])); end; procedure GMGlassFillRect(const ADC: HDC; const ARect: TRect; const AColors: array of COLORREF); //const clTop, clMidHi, clMidLo, clBottom, clCorner: COLORREF); var m: LongInt; begin m := GMRectSize(ARect).y div 2; with ARect do begin GMGradientFillRect(ADC, AColors[0], AColors[1], GMRect(Left, Top, Right, Top + m), d2dVertical); GMGradientFillRect(ADC, AColors[2], AColors[3], GMRect(Left, Top + m, Right, Bottom), d2dVertical); end; {with ARect do begin GMGradientFillRect(ADC, clTop, clMidHi, GMRect(Left, Top, Right, Top + m), d2dVertical); GMGradientFillRect(ADC, clMidLo, clBottom, GMRect(Left, Top + m, Right, Bottom), d2dVertical); end;} end; procedure GMGlassFillRectSimple(const ADC: HDC; const ARect: TRect; const ADarkestColor: COLORREF); //var MidColor: COLORREF; begin //MidColor := GMChangeColorLightness(ADarkestColor, 150); GMGlassFillRect(ADC, ARect, [clWhite, GMChangeColorLightness(ADarkestColor, 100), ADarkestColor, GMChangeColorLightness(ADarkestColor, 150)]); end; {procedure GMSetCornerPixels(const ADC: HDC; const ARect: TRect; const AColor: COLORREF); begin with ARect do begin SetPixel(ADC, Left, Top, AColor); SetPixel(ADC, Right-1, Top, AColor); SetPixel(ADC, Right-1, Bottom-1, AColor); SetPixel(ADC, Left, Bottom-1, AColor); end; end;} { ------------------------- } { ---- Child layouting ---- } { ------------------------- } function GMCalcBoundingChildHeight(const AContainedAreas: IGMObjArrayCollection): LongInt; var i: LongInt; rCtl: TRect; childArea: IGMUiArea; edgeAlign: TEdgesAlign; begin Result := 0; if AContainedAreas = nil then Exit; // // If both horizontal edges are aligned the control cannot dictate it's height! // for i:=0 to AContainedAreas.Count-1 do if GMGetInterface(AContainedAreas[i], IGMUiArea, childArea) and childArea.Visible then begin edgeAlign := childArea.AreaAlign.EdgeAlign; if ((edgeAlign[edgTop] <> ealAligned) or ((edgeAlign[edgBottom] <> ealAligned))) then begin rCtl := childArea.LayoutBounds; if (edgeAlign[edgBottom] <> ealAligned) then Result := Max(Result, rCtl.Bottom) else Result := Max(Result, rCtl.Bottom - rCtl.Top); // <- rCtl.Top may be negative! end; end; end; function GMCalcBoundingChildWidth(const AContainedAreas: IGMObjArrayCollection): LongInt; var i: LongInt; rCtl: TRect; childArea: IGMUiArea; edgeAlign: TEdgesAlign; begin Result := 0; if AContainedAreas = nil then Exit; // // If both vertical edges are aligned the control cannot dictate it's width! // for i:=0 to AContainedAreas.Count-1 do if GMGetInterface(AContainedAreas[i], IGMUiArea, childArea) and childArea.Visible then begin edgeAlign := childArea.AreaAlign.EdgeAlign; if ((edgeAlign[edgLeft] <> ealAligned) or ((edgeAlign[edgRight] <> ealAligned))) then begin rCtl := childArea.LayoutBounds; if (edgeAlign[edgRight] <> ealAligned) then Result := Max(Result, rCtl.Right) else Result := Max(Result, rCtl.Right - rCtl.Left); // <- rCtl.Left may be negative! end; end; end; function GMCalcBoundingHeight(const AContainingArea: TGMUiAreaBase; const ANewSize: TPoint; const ARelayout: Boolean): LongInt; begin if AContainingArea = nil then Exit(0); if ARelayout then begin //AContainingArea.FLayoutBounds.Left := 0; // Layouting is always relative to parent AContainingArea client rect if AContainingArea.FLayoutBounds.Right <> AContainingArea.FLayoutBounds.Left + ANewSize.x then begin AContainingArea.FLastLayoutSize.x := cInvalidLayoutVal; AContainingArea.FLayoutBounds.Right := AContainingArea.FLayoutBounds.Left + ANewSize.x; end; AContainingArea.LayoutContainedAreasIfNeeded(False); end; // Layouting offset already includes top frame Result := GMCalcBoundingChildHeight(AContainingArea.ContainedAreas) + GMFrameExtent(AContainingArea.Frame, [edgTop, edgBottom]).y; end; function GMCalcBoundingWidth(const AContainingArea: TGMUiAreaBase; const ANewSize: TPoint; const ARelayout: Boolean): LongInt; begin if AContainingArea = nil then Exit(0); if ARelayout then begin //AContainingArea.FLayoutBounds.Top := 0; // Layouting is always relative to parent AContainingArea client rect if AContainingArea.FLayoutBounds.Bottom <> AContainingArea.FLayoutBounds.Top + ANewSize.y then begin AContainingArea.FLastLayoutSize.y := cInvalidLayoutVal; AContainingArea.FLayoutBounds.Bottom := AContainingArea.FLayoutBounds.Top + ANewSize.y; end; AContainingArea.LayoutContainedAreasIfNeeded(False); end; // Layouting offset already includes left frame Result := GMCalcBoundingChildWidth(AContainingArea.ContainedAreas) + GMFrameExtent(AContainingArea.Frame, [edgLeft, edgRight]).x; end; { ---------------------------- } { ---- Standard Layouting ---- } { ---------------------------- } function GMAdjustRestRect(const AreaAlign: TGMAreaAlignRec; const RCtl, RRest, RSpace: TRect): TRect; begin Result := RRest; with AreaAlign do begin if (EdgeAlign[edgTop] = ealAligned) and ((EdgeAlign[edgBottom] <> ealAligned) or (RSpace.Bottom >= cQAlign)) and AreaAlign.ShrinkRestY then Result.Top := Max(Result.Top, RCtl.Bottom); if (EdgeAlign[edgBottom] = ealAligned) and ((EdgeAlign[edgTop] <> ealAligned) or (RSpace.Top >= cQAlign)) and AreaAlign.ShrinkRestY then Result.Bottom := Min(Result.Bottom, RCtl.Top); if (EdgeAlign[edgLeft] = ealAligned) and ((EdgeAlign[edgRight] <> ealAligned) or (RSpace.Right >= cQAlign)) and AreaAlign.ShrinkRestX then Result.Left := Max(Result.Left, RCtl.Right); if (EdgeAlign[edgRight] = ealAligned) and ((EdgeAlign[edgLeft] <> ealAligned) or (RSpace.Left >= cQAlign)) and AreaAlign.ShrinkRestX then Result.Right := Min(Result.Right, RCtl.Left); end; end; procedure GMLayoutContainedAreas(const Area: IGMUiArea; const ARepaint: Boolean; const ALayoutEdgeOrderMap: TGMLayoutEdgeOrderMap); //: TPoint; const cFixedOrAligned: array [Boolean] of TEdgeAlign = (ealFixed, ealAligned); var i: LongInt; childArea: IGMUiArea; rRest, rBounds, rSpace: TRect; Edge: TEdge; childAreaAlign: TGMAreaAlignRec; clientAreas: array of IGMUiArea; usedQAlignX, UsedQAlignY: Double; isWrapAlgnX: Boolean; function QAlignSize(const RestSize, Quota: LongInt; var UsedQuota: Double): LongInt; function IntAsDouble(const Value: LongInt): Double; begin Result := Value; end; begin if UsedQuota >= 1 then begin Result := 0; Exit; end; Result := MulDiv(Round(IntAsDouble(RestSize) / (1 - UsedQuota)), Min(Quota, cQAlignDivisor), cQAlignDivisor); UsedQuota := UsedQuota + (Min(Quota, cQAlignDivisor) / cQAlignDivisor); end; begin //Result := cNullPoint; if (Area = nil) or Area.ContainedAreas.IsEmpty then Exit; // <- nothing to layout rRest := GMRect(cNullPoint, Area.clientAreaSize); usedQAlignX := 0; UsedQAlignY := 0; for i:=0 to Area.ContainedAreas.Count-1 do if (Area.ContainedAreas[i] <> nil) and Area.ContainedAreas[i].GetInterface(IGMUiArea, childArea) and childArea.ParticipateInLayouting then begin rSpace := childArea.LayoutSpace; childAreaAlign := childArea.AreaAlign; if GMIsEqualAlign(childAreaAlign, cClientAligned) and (rSpace.Left < cQAlign) and (rSpace.Top < cQAlign) and (rSpace.Right < cQAlign) and (rSpace.Bottom < cQAlign) then begin SetLength(clientAreas, Length(clientAreas) + 1); clientAreas[High(clientAreas)] := childArea; end else begin rBounds := childArea.LayoutBounds; isWrapAlgnX := False; // // Change wrap alignment to either fixed or aligned depending on the size // if (childAreaAlign.EdgeAlign[edgRight] = ealWrap) then begin childAreaAlign.EdgeAlign[edgRight] := cFixedOrAligned[rBounds.Left + childArea.CalculateWidth(GMRectSize(rBounds)) > rRest.Right - rSpace.Right]; isWrapAlgnX := childAreaAlign.EdgeAlign[edgRight] = ealAligned; end; if (childAreaAlign.EdgeAlign[edgLeft] = ealWrap) then begin childAreaAlign.EdgeAlign[edgLeft] := cFixedOrAligned[rBounds.Right - childArea.CalculateWidth(GMRectSize(rBounds)) < rRest.Left + rSpace.Left]; isWrapAlgnX := childAreaAlign.EdgeAlign[edgLeft] = ealAligned; end; for Edge:=Low(Edge) to High(Edge) do case childAreaAlign.EdgeAlign[ALayoutEdgeOrderMap[Edge]] of // ealFixed:; <- Nothing! ealCentered: case ALayoutEdgeOrderMap[Edge] of edgLeft: case childAreaAlign.EdgeAlign[edgRight] of ealCentered: rBounds := GMRectCenterX(rBounds, rRest); ealFixed: OffsetRect(rBounds, ((rRest.Left + rRest.Right) div 2) + rSpace.Left - rBounds.Left, 0); else rBounds.Left := ((rRest.Left + rRest.Right) div 2) + rSpace.Left; end; edgRight: case childAreaAlign.EdgeAlign[edgLeft] of ealCentered: rBounds := GMRectCenterX(rBounds, rRest); ealFixed: OffsetRect(rBounds, ((rRest.Left + rRest.Right) div 2) - rSpace.Right - rBounds.Right, 0); else rBounds.Right := ((rRest.Left + rRest.Right) div 2) - rSpace.Right; end; edgTop: case childAreaAlign.EdgeAlign[edgBottom] of ealCentered: rBounds := GMRectCenterY(rBounds, rRest); ealFixed: OffsetRect(rBounds, 0, ((rRest.Top + rRest.Bottom) div 2) + rSpace.Top - rBounds.Top); else rBounds.Top := ((rRest.Top + rRest.Bottom) div 2) + rSpace.Top; end; edgBottom: case childAreaAlign.EdgeAlign[edgTop] of ealCentered: rBounds := GMRectCenterY(rBounds, rRest); ealFixed: OffsetRect(rBounds, 0, ((rRest.Top + rRest.Bottom) div 2) - rSpace.Bottom - rBounds.Bottom); else rBounds.Bottom := ((rRest.Top + rRest.Bottom) div 2) - rSpace.Bottom; end; end; ealAligned: case ALayoutEdgeOrderMap[Edge] of edgLeft: case childAreaAlign.EdgeAlign[edgRight] of ealFixed: OffsetRect(rBounds, rRest.left + rSpace.Left - rBounds.Left, 0); else if rSpace.Left >= cQAlign then rBounds.Left := rRest.Right - QAlignSize(GMRectSize(rRest).x, rSpace.Left, usedQAlignX) else rBounds.Left := rRest.left + rSpace.Left; end; edgTop: case childAreaAlign.EdgeAlign[edgBottom] of ealFixed: OffsetRect(rBounds, 0, rRest.Top + rSpace.Top - rBounds.Top); else if rSpace.Top >= cQAlign then rBounds.Top := rRest.Bottom - QAlignSize(GMRectSize(rRest).y, rSpace.Top, UsedQAlignY) else rBounds.Top := rRest.Top + rSpace.Top; end; edgRight: case childAreaAlign.EdgeAlign[edgLeft] of ealFixed: OffsetRect(rBounds, rRest.Right - rSpace.Right - rBounds.Right, 0); else if rSpace.Right >= cQAlign then rBounds.Right := rRest.Left + QAlignSize(GMRectSize(rRest).x, rSpace.Right, usedQAlignX) else rBounds.Right := rRest.Right - rSpace.Right; end; edgBottom: case childAreaAlign.EdgeAlign[edgTop] of ealFixed: OffsetRect(rBounds, 0, rRest.Bottom - rSpace.Bottom - rBounds.Bottom); else if rSpace.Bottom >= cQAlign then rBounds.Bottom := rRest.Top + QAlignSize(GMRectSize(rRest).y, rSpace.Bottom, UsedQAlignY) else rBounds.Bottom := rRest.Bottom - rSpace.Bottom; end; end; end; // // If the child area does it's calculation itself // if childArea.AutoCalcSize[d2dHorizontal] and not isWrapAlgnX then if childAreaAlign.EdgeAlign[edgRight] in cCalcSizeAlignments then rBounds.Right := rBounds.Left + childArea.CalculateWidth(GMRectSize(rBounds)) else rBounds.Left := rBounds.Right - childArea.CalculateWidth(GMRectSize(rBounds)); if childArea.AutoCalcSize[d2dVertical] then if childAreaAlign.EdgeAlign[edgBottom] in cCalcSizeAlignments then rBounds.Bottom := rBounds.Top + childArea.CalculateHeight(GMRectSize(rBounds)) else rBounds.Top := rBounds.Bottom - childArea.CalculateHeight(GMRectSize(rBounds)); // // If both sides are centered, the complete extent is centered // if (childAreaAlign.EdgeAlign[edgLeft] = ealCentered) and (childAreaAlign.EdgeAlign[edgRight] = ealCentered) then rBounds := GMRectCenterX(rBounds, rRest); if (childAreaAlign.EdgeAlign[edgTop] = ealCentered) and (childAreaAlign.EdgeAlign[edgBottom] = ealCentered) then rBounds := GMRectCenterY(rBounds, rRest); childArea.SetLayoutBounds(rBounds, ARepaint); // <- Setting LayoutBounds will trigger layouting of contained controls if needed! // if rBounds.Right > Result.x then Result.x := rBounds.Right; // if rBounds.Bottom > Result.y then Result.y := rBounds.Bottom; rRest := GMAdjustRestRect(childAreaAlign, rBounds, rRest, rSpace); end; end; // set all client aligned areas to rRest for i:=Low(clientAreas) to High(clientAreas) do begin rSpace := clientAreas[i].LayoutSpace; clientAreas[i].SetLayoutBounds(GMRect(rRest.Left + rSpace.Left, rRest.Top + rSpace.Top, rRest.Right - rSpace.Right, rRest.Bottom - rSpace.Bottom), ARepaint); end; end; procedure GMWrapLayoutContainedAreas(const Area: IGMUiArea; const ARepaint: Boolean; const AHorzAlign: TGMHorizontalAlignment; const AVLineSpace: LongInt); //: TPoint; var i, x, y, w, h, hline: LongInt; childArea: IGMUiArea; rArea, rSpace: TRect; // rChild procedure ResetLine; begin hline := 0; if AHorzAlign = haLeft then x := rArea.Left else x := rArea.Right; end; begin //Result := cNullPoint; if (Area = nil) or Area.ContainedAreas.IsEmpty then Exit; // <- nothing to layout rArea := GMRect(cNullPoint, Area.clientAreaSize); y := rArea.Top; ResetLine; for i:=0 to Area.ContainedAreas.Count-1 do if (Area.ContainedAreas[i] <> nil) and Area.ContainedAreas[i].GetInterface(IGMUiArea, childArea) and childArea.ParticipateInLayouting then begin //rChild := childArea.GetLayoutBounds; rSpace := childArea.LayoutSpace; w := childArea.CalculateWidth(GMPoint(1, 1)); // GMRectSize(rChild) h := childArea.CalculateHeight(GMPoint(1, 1)); if AHorzAlign = haLeft then x := x + w + rSpace.Right else x := x - w - rSpace.Left; hline := Max(hLine, h); if (i > 0) and (x < rArea.Left) or (x > rArea.Right) then // <- i > 0: dont insert new line before first area! begin Inc(y, hLine + AVLineSpace); ResetLine; if AHorzAlign = haLeft then x := x + w + rSpace.Right else x := x - w - rSpace.Left; end; childArea.SetLayoutBounds(GMRect(x, y, x + w, y + h), ARepaint); // <- Setting LayoutBounds will trigger layouting of contained controls if needed! end; end; { -------------------- } { ---- TGMWinMenu ---- } { -------------------- } constructor TGMWinMenu.CreateMenu(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FHandle := {$IFDEF JEDIAPI}jwaWinUser.{$ELSE}Windows.{$ENDIF}CreateMenu; GMApiCheckObj('CreateMenu', '', GetLastError, FHandle <> 0, Self); //CreateEntries; end; constructor TGMWinMenu.CreatePopupMenu(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FHandle := {$IFDEF JEDIAPI}jwaWinUser.{$ELSE}Windows.{$ENDIF}CreatePopupMenu; GMApiCheckObj('CreatePopupMenu', '', GetLastError, FHandle <> 0, Self); //CreateEntries; end; destructor TGMWinMenu.Destroy; begin if FHandle <> 0 then begin DestroyMenu(FHandle); FHandle := 0; end; inherited Destroy; end; function TGMWinMenu.GetHandle: THandle; begin Result := FHandle; end; {procedure TGMWinMenu.CreateEntries; begin end;} { -------------------------- } { ---- TGMWndMessageObj ---- } { -------------------------- } //constructor TGMWndMessageObj.Create(const AWndMessage: TGMWndMsg; const ARefLifeTime: Boolean); //begin // inherited Create(ARefLifeTime); // FWndMessage := AWndMessage; //end; // //function TGMWndMessageObj.GetWndMessage: TGMWndMsg; //begin // Result := FWndMessage; //end; // //function TGMWndMessageObj.HashCode: TGMHashCode; //begin // Result := FWndMessage; //end; { ------------------------ } { ---- TGMWindowClass ---- } { ------------------------ } constructor TGMWindowClass.Create(const AWndClassName: TGMString; const AClassStyle: DWORD; const AIcon: HICON; const ACursor: HCURSOR; const ABkgndBrush: HBRUSH; const AMenuName: TGMString; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FWndClassName := AWndClassName; FMenuName := AMenuName; if Length(FWndClassName) > 0 then FWndClass.lpszClassName := PGMChar(FWndClassName); if Length(FMenuName) > 0 then FWndClass.lpszMenuName := PGMChar(FMenuName); FWndClass.cbSize := SizeOf(FWndClass); FWndClass.Style := AClassStyle; FWndClass.hIcon := AIcon; FWndClass.hCursor := ACursor; FWndClass.hbrBackground := ABkgndBrush; FWndClass.hInstance := {$IFDEF JEDIAPI}{$IFDEF FPC}System.{$ELSE}SysInit.{$ENDIF}{$ENDIF}HInstance; FWndClass.lpfnWndProc := {$IFNDEF JEDIAPI}@{$ENDIF}DefWindowProc; // GMStdWndProc; <- does not work FRegisteredClass := {$IFDEF JEDIAPI}jwaWinUser.{$ELSE}Windows.{$ENDIF}RegisterClassEx(FWndClass); GMAPICheckObj('RegisterClassEx', '', GetLastError, FRegisteredClass <> 0, Self); end; destructor TGMWindowClass.Destroy; begin if ClassIsRegistered then begin {$IFDEF JEDIAPI}jwaWinUser.{$ELSE}Windows.{$ENDIF}UnregisterClass(PGMChar(FWndClassName), {$IFDEF JEDIAPI}{$IFDEF FPC}System.{$ELSE}SysInit.{$ENDIF}{$ENDIF}HInstance); FRegisteredClass := 0; end; inherited Destroy; end; function TGMWindowClass.ClassIsRegistered: Boolean; begin Result := FRegisteredClass <> 0; end; function TGMWindowClass.GetName: TGMString; begin Result := FWndClassName; end; { --------------------------- } { ---- TGMAreaMultiFrame ---- } { --------------------------- } constructor TGMAreaMultiFrame.Create(const AReflifeTime: Boolean); begin inherited Create(AReflifeTime); FFrameKind := frkNone; FInnerFrame := frsNone; FOuterFrame := frsLowered; FFramedEdges := CAllEdges; FOuterSpace := 0; FFrameLook3D := True; end; //function TGMAreaMultiFrame.QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; //var PIUnkOwner: IUnknown; //begin //Result := inherited QueryInterface(IID, Intf); //if (Result <> S_OK) and (FOwner <> nil) and FOwner.GetInterface(IUnknown, PIUnkOwner) then // Result := PIUnkOwner.QueryInterface(IID, Intf); //end; // //function TGMAreaMultiFrame._AddRef: LongInt; //var PIUnkOwner: IUnknown; //begin //if (FOwner <> nil) and FOwner.GetInterface(IUnknown, PIUnkOwner) then // Result := PIUnkOwner._AddRef //else // Result := inherited _AddRef; //end; // //function TGMAreaMultiFrame._Release: LongInt; //var PIUnkOwner: IUnknown; //begin //if (FOwner <> nil) and FOwner.GetInterface(IUnknown, PIUnkOwner) then // Result := PIUnkOwner._Release //else // Result := inherited _Release; //end; function TGMAreaMultiFrame.EdgeWidth: LongInt; begin Result := CFrameLines[InnerFrame] + CFrameLines[OuterFrame]; end; function TGMAreaMultiFrame.CalculateClientRect(const ABoundsRect: TRect; const AScale: TFrameScale): TRect; var EdgeSize: LongInt; begin Result := GMInflateRect(ABoundsRect, -OuterSpace * AScale, -OuterSpace * AScale); if FFrameKind = frkNone then Exit; EdgeSize := EdgeWidth * AScale; if edgLeft in FFramedEdges then Inc(Result.Left, EdgeSize); if edgTop in FFramedEdges then Inc(Result.Top, EdgeSize); if edgRight in FFramedEdges then Dec(Result.Right, EdgeSize); if edgBottom in FFramedEdges then Dec(Result.Bottom, EdgeSize); end; {function TGMAreaMultiFrame.Extend(const AEdges: TEdges): TPoint; var EdgeW: LongInt; Edge: TEdge; EdgesX, EdgesY: TEdges; begin Result := GMPoint(OuterSpace shl 1, OuterSpace shl 1); if FFrameKind = frkNone then Exit; EdgeW := EdgeWidth; // + OuterSpace EdgesX := cEdgesX * AEdges * FFramedEdges; EdgesY := cEdgesY * AEdges * FFramedEdges; for Edge := Low(Edge) to High(Edge) do begin if (Edge in EdgesX) then Inc(Result.x, EdgeW); if (Edge in EdgesY) then Inc(Result.y, EdgeW); end; end;} procedure TGMAreaMultiFrame.DrawFrame(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const AColor: COLORREF); const cInnerStyles: array [TFrameShape] of LongInt = (0, BDR_SUNKENINNER, BDR_RAISEDINNER, 0); cOuterStyles: array [TFrameShape] of LongInt = (0, BDR_SUNKENOUTER, BDR_RAISEDOUTER, 0); cEdgeStyles: array [TFrameKind] of LongInt = (0, 0, BF_SOFT, BF_FLAT); cCtl3DStyles: array [Boolean] of LongInt = (BF_MONO, 0); var RFrame: TRect; Brush, RgnOuter, RgnInner: IGMGetHandle; RBounds: TRect; begin // // Outerspace needs to be drawn even if (FrameKind = frkNone) or (FramedEdges = []) // if (ADC = 0) or (ARegion = 0) or (GetRgnBox(ARegion, RBounds) in [ERROR, NULLREGION]) then Exit; RFrame := GMInflateRect(RBounds, -OuterSpace, -OuterSpace); if (FrameKind <> frkNone) and (FramedEdges <> []) then {$IFDEF FPC} DrawEdge(ADC, RFrame, cInnerStyles[InnerFrame] or cOuterStyles[OuterFrame], LPByte(@FFramedEdges)^ or cEdgeStyles[FrameKind] or cCtl3DStyles[FrameLook3D]); {$ELSE} DrawEdge(ADC, RFrame, CInnerStyles[InnerFrame] or COuterStyles[OuterFrame], Byte(FramedEdges) or CEdgeStyles[FrameKind] or CCtl3DStyles[FrameLook3D]); {$ENDIF} // Fill space not covered by frame if OuterSpace = 0 then Exit; RgnOuter := TGMGdiRegion.CreateRect(0, RBounds); RgnInner := TGMGdiRegion.CreateRect(0, RFrame); if CombineRgn(RgnOuter.Handle, RgnOuter.Handle, RgnInner.Handle, RGN_DIFF) in [ERROR, NULLREGION] then Exit; Brush := TGMGdiBrush.Create(0, AColor); FillRgn(ADC, RgnOuter.Handle, Brush.Handle); end; function TGMAreaMultiFrame.GetFrameKind: TFrameKind; begin Result := FFrameKind; end; function TGMAreaMultiFrame.GetInnerFrame: TFrameShape; begin Result := FInnerFrame; end; function TGMAreaMultiFrame.GetOuterFrame: TFrameShape; begin Result := FOuterFrame; end; function TGMAreaMultiFrame.GetFramedEdges: TEdges; begin Result := FFramedEdges; end; function TGMAreaMultiFrame.GetOuterSpace: LongInt; begin Result := FOuterSpace; end; function TGMAreaMultiFrame.GetFrameLook3D: Boolean; begin Result := FFrameLook3D; end; procedure TGMAreaMultiFrame.SetFrameKind(const Value: TFrameKind); begin FFrameKind := Value; end; procedure TGMAreaMultiFrame.SetInnerFrame(const Value: TFrameShape); begin FInnerFrame := Value; end; procedure TGMAreaMultiFrame.SetOuterFrame(const Value: TFrameShape); begin FOuterFrame := Value; end; procedure TGMAreaMultiFrame.SetFramedEdges(const Value: TEdges); begin FFramedEdges := Value; end; procedure TGMAreaMultiFrame.SetOuterSpace(const Value: LongInt); begin FOuterSpace := Value; end; procedure TGMAreaMultiFrame.SetFrameLook3D(const Value: Boolean); begin FFrameLook3D := Value; end; { ---------------------------- } { ---- TGMAreaSimpleFrame ---- } { ---------------------------- } constructor TGMAreaSimpleFrame.Create(const AEdgeWidth: LongInt; const AFramedEdges: TEdges; const AReflifeTime: Boolean); begin inherited Create(AReflifeTime); FFramedEdges := AFramedEdges; FEdgeWidth := AEdgeWidth; end; function TGMAreaSimpleFrame.CalculateClientRect(const ABoundsRect: TRect; const AScale: TFrameScale): TRect; begin //Result := GMInflateRect(ABoundsRect, FEdgeWidth * -AScale, FEdgeWidth * -AScale); Result := ABoundsRect; if edgLeft in FFramedEdges then Inc(Result.Left, FEdgeWidth); if edgTop in FFramedEdges then Inc(Result.Top, FEdgeWidth); if edgRight in FFramedEdges then Dec(Result.Right, FEdgeWidth); if edgBottom in FFramedEdges then Dec(Result.Bottom, FEdgeWidth); end; procedure TGMAreaSimpleFrame.DrawFrame(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const AColor: COLORREF); var brush, rgnInner: IGMGetHandle; rBounds: TRect; calcRegion: IGMCalcAreaRegion; // FrmCol: COLORREF; begin if (ADC = 0) or (ARegion = 0) or (GetRgnBox(ARegion, rBounds) in [ERROR, NULLREGION]) then Exit; //RgnOuter := TGMGdiRegion.CreateRect(0, rBounds); if GMGetInterface(AArea, IGMCalcAreaRegion, calcRegion) then rgnInner := calcRegion.CreateAreaRegion(CalculateClientRect(rBounds), arkClient) else rgnInner := TGMGdiRegion.CreateRect(0, CalculateClientRect(rBounds)); if CombineRgn(rgnInner.Handle, ARegion, rgnInner.Handle, RGN_DIFF) in [ERROR, NULLREGION] then Exit; //if FFrameColor = CLR_INVALID then FrmCol := AColor else FrmCol := FFrameColor; brush := TGMGdiBrush.Create(0, AColor); FillRgn(ADC, rgnInner.Handle, brush.Handle); end; { -------------------------- } { ---- TGMAreaFakeFrame ---- } { -------------------------- } procedure TGMAreaFakeFrame.DrawFrame(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const AColor: COLORREF); begin // Nothing! end; { ---------------------------- } { ---- TGMAreaRegionFrame ---- } { ---------------------------- } constructor TGMAreaRegionFrame.Create(const AFrameWidth, AFrameHeight: LongInt; const AReflifeTime: Boolean); begin inherited Create(AReflifeTime); FFrameWidth := AFrameWidth; FFrameHeight := AFrameHeight; end; function TGMAreaRegionFrame.CalculateClientRect(const ABoundsRect: TRect; const AScale: TFrameScale): TRect; begin Result := GMInflateRect(ABoundsRect, -FFrameWidth, -FFrameHeight); end; procedure TGMAreaRegionFrame.DrawFrame(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const AColor: COLORREF); var Brush: IGMGetHandle; begin Brush := TGMGdiBrush.Create(0, AColor); FrameRgn(ADC, ARegion, Brush.Handle, FFrameWidth, FFrameHeight); end; { ------------------------- } { ---- TGMAreaLayouter ---- } { ------------------------- } {constructor TGMAreaLayouter.Create(const AOwner: TObject; const AReflifeTime: Boolean); begin inherited Create(AReflifeTime); FChildList := TGMObjArrayCollection.Create; FOwner := AOwner; end; destructor TGMAreaLayouter.Destroy; begin GMFreeAndNil(FChildList); inherited Destroy; end; function TGMAreaLayouter.SubtractContainedAreas(const HFillRgn: HRGN): Boolean; var i: LongInt; PIArea: IGMUiArea; RgnChild: IGMGetHandle; begin Result := True; if HFillRgn = 0 then Exit; for i:=0 to ContainedAreas.Count-1 do if (ContainedAreas[i] <> nil) and ContainedAreas[i].GetInterface(IGMUiArea, PIArea) and PIArea.Visible and (PIArea.PaintsComplete or PIArea.FillsComplete) then begin RgnChild := TGMGdiRegion.CreateRect(0, PIArea.CalculateSurfaceRect(PIArea.LayoutBounds)); if CombineRgn(HFillRgn, HFillRgn, RgnChild.Handle, RGN_DIFF) = NULLREGION then begin Result := False; Break; end; end; end; procedure TGMAreaLayouter.PaintContainedAreas(const ADC: HDC); var i: LongInt; PIPaint: IGMPaint; PIArea: IGMUiArea; begin if ADC = 0 then Exit; for i:=0 to ContainedAreas.Count-1 do // Paint only windowless controls here, windows will receive their own WM_PAINT from the system if (ContainedAreas[i] <> nil) and ContainedAreas[i].GetInterface(IGMUiArea, PIArea) and PIArea.Visible and not GMAreaHasWndHandle(ContainedAreas[i]) and ContainedAreas[i].GetInterface(IGMPaint, PIPaint) then PIPaint.Paint(ADC); end; function TGMAreaLayouter.AreaContainingPoint(const APoint: TPoint): TObject; var i: LongInt; PIArea: IGMUiArea; begin Result := nil; for i:=0 to ContainedAreas.Count-1 do if (ContainedAreas[i] <> nil) and not GMAreaHasWndHandle(ContainedAreas[i]) and ContainedAreas[i].GetInterface(IGMUiArea, PIArea) and PIArea.Visible and PIArea.PointInsideArea(APoint) then begin Result := PIArea.AreaContainingPoint(APoint); Break; end; end;} { ----------------------------- } { ---- TGMAreaRegionFiller ---- } { ----------------------------- } procedure TGMAreaRegionFiller.Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); begin FillRgn(ADC, ARegion, ABrush); end; { --------------------------- } { ---- TGMAreaRectFiller ---- } { --------------------------- } procedure TGMAreaRectFiller.Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); var RegionBounds: TRect; begin if (ARegion <> 0) and not (GetRgnBox(ARegion, RegionBounds) in [ERROR, NULLREGION]) then FillRect(ADC, RegionBounds, ABrush); end; { ---------------------------- } { ---- TGMGlassLookFiller ---- } { ---------------------------- } constructor TGMGlassLookFiller.Create(const AColors: array of COLORREF; const ARefLifeTime: Boolean); var i: LongInt; begin inherited Create(ARefLifeTime); SetLength(FColors, Length(AColors)); for i:=Low(AColors) to High(AColors) do FColors[i] := GMRGBColor(AColors[i]); end; procedure TGMGlassLookFiller.Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); var RegionBounds: TRect; begin if (ARegion <> 0) and not (GetRgnBox(ARegion, RegionBounds) in [ERROR, NULLREGION]) then GMGlassFillRect(ADC, RegionBounds, FColors); end; { ---------------------------------- } { ---- TGMSimpleGlassLookFiller ---- } { ---------------------------------- } constructor TGMSimpleGlassLookFiller.Create(const ARefLifeTime: Boolean); // const AColor: COLORREF; begin inherited Create(ARefLifeTime); //FColor := GMRGBColor(AColor); end; procedure TGMSimpleGlassLookFiller.Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); var RegionBounds: TRect; color: COLORREF; begin if AArea is TGMUiAreaBase then color := TGMUiAreaBase(AArea).BkgndColor else color := clrGlassBlue; // cDfltColor; if (ARegion <> 0) and not (GetRgnBox(ARegion, RegionBounds) in [ERROR, NULLREGION]) then GMGlassFillRectSimple(ADC, RegionBounds, color); // FColor end; { ------------------------------- } { ---- TGMAreaGradientFiller ---- } { ------------------------------- } constructor TGMAreaGradientFiller.Create(const ADirection: TGM2DDirection; const AColors: array of COLORREF; const ARefLifeTime: Boolean); //var i: LongInt; begin inherited Create(AColors, ARefLifeTime); //SetLength(FColors, Length(AColors)); //for i:=Low(AColors) to High(AColors) do FColors[i] := GMRGBColor(AColors[i]); FDirection := ADirection; end; procedure TGMAreaGradientFiller.Paint(const AArea: TObject; const ADC: HDC; const ARegion: HRGN; const ABrush: HBRUSH); var RegionBounds: TRect; begin if (ARegion <> 0) and not (GetRgnBox(ARegion, RegionBounds) in [ERROR, NULLREGION]) then GMGradientFillRect(ADC, FColors[0], FColors[1], RegionBounds, FDirection); end; { ----------------------- } { ---- TGMUiAreaBase ---- } { ----------------------- } constructor TGMUiAreaBase.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); // // Sorting OwnedAreas for faster pointer lookup would change deletion order. // TGMUiAreaBase seems to be safe against this but it dont feels like a good idea. // AcceptDuplicates should be false since this area would be freed twice -> invlid pointer operation. // But with AcceptDuplicates=false a duplicate addition would be freed immediately which will propably // lead to an acces violation too. Not very much better .. // FOwnedAreas := TGMObjArrayCollection.Create(True, True, False, nil, True); // GMCompareByInstance // // Dont sort contained ares for faster pointer lookup, because insertion order matters in layouting! // AcceptDuplicates should be false but this will be slower because pointer lookup is needed then. // FContainedAreas := TGMObjArrayCollection.Create(False, True, False, nil, True); // GMCompareByInstance InvalidateCachedLayoutValues; end; constructor TGMUiAreaBase.Create(const AParent: TObject; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const ABkgndColor: COLORREF; const AVisible: Boolean; const ARefLifeTime: Boolean); var Edge: TEdge; procedure SetupEdgeSpace(const Edge: TEdge); begin case Edge of edgLeft: begin FLayoutSpace.Left := APosition.Left; FLayoutBounds.Left := 0; end; edgTop: begin FLayoutSpace.Top := APosition.Top; FLayoutBounds.Top := 0; end; edgRight: begin FLayoutSpace.Right := APosition.Right; FLayoutBounds.Right := 0; end; edgBottom: begin FLayoutSpace.Bottom := APosition.Bottom; FLayoutBounds.Bottom := 0; end; end; end; begin {inherited} Create(ARefLifeTime); // <- No "inherited" here => route through virtual call hirarchy FVisible := AVisible; FParent := AParent; FBkgndColor := ABkgndColor; FAreaAlign := AAreaAlign; FLayoutBounds := APosition; for Edge:=Low(Edge) to High(Edge) do case AAreaAlign.EdgeAlign[Edge] of {if AAreaAlign.EdgeAlign[Edge] = ealAligned then} ealAligned, ealWrap: SetupEdgeSpace(Edge); ealCentered: case Edge of edgLeft: if (AAreaAlign.EdgeAlign[edgRight] <> ealCentered) then SetupEdgeSpace(Edge); edgTop: if (AAreaAlign.EdgeAlign[edgBottom] <> ealCentered) then SetupEdgeSpace(Edge); edgRight: if (AAreaAlign.EdgeAlign[edgLeft] <> ealCentered) then SetupEdgeSpace(Edge); edgBottom: if (AAreaAlign.EdgeAlign[edgTop] <> ealCentered) then SetupEdgeSpace(Edge); end; end; FAutoCalcSize[d2dHorizontal] := GMIsAutoCalcWidth(FAreaAlign.EdgeAlign, FLayoutBounds); FAutoCalcSize[d2dVertical] := GMIsAutoCalcHeight(FAreaAlign.EdgeAlign, FLayoutBounds); if (Parent is TGMUiAreaBase) and IsLayoutChild then TGMUiAreaBase(Parent).ContainedAreas.Add(Self); end; destructor TGMUiAreaBase.Destroy; //var clssName: TGMString; //var Dlg: TGMDlgWindow; procedure ResetActiveControl; // Dont use interfaces here when Walking Parents -> destructor stack overflow! // Another solution would be to add an artificial reference during destructor call var prnt: TObject; begin prnt := Parent; while prnt is TGMUiAreaBase do begin if not TGMUiAreaBase(prnt).IsLayoutChild and (prnt is TGMDlgWindow) and (TGMDlgWindow(prnt).ActiveControl = Self) then TGMDlgWindow(prnt).ActiveControl := nil; prnt := TGMUiAreaBase(prnt).Parent; end; end; begin // // Walking Parents by getting interfaces here may lead to stack overflow! // //if GMFindParentObj(Self, TGMDlgWindow, Dlg) and (Dlg.ActiveControl = Self) then Dlg.ActiveControl := nil; ResetActiveControl; // always try to remove, even if not IsLayoutChild! if vGMDropTargetArea = Self then vGMDropTargetArea := nil; if vGMKeyboardFocusArea = Self then vGMKeyboardFocusArea := nil; if vGMMouseInsideArea = Self then vGMMouseInsideArea := nil; if vGMPopupArea = Self then vGMPopupArea := nil; if vGMMouseCaptureArea = Self then GMReleaseMouseCapture; // <- sets vGMMouseCaptureArea := nil //clssName := ClassName; if (Parent is TGMUiAreaBase) and (TGMUiAreaBase(Parent).ContainedAreas <> nil) then TGMUiAreaBase(Parent).ContainedAreas.RemoveByKey(Self); //SetParent(nil, False); if FOwnedAreas <> nil then FOwnedAreas.Clear(False); // <- FOwnedAreas may be nil if there is an exception in the constructor of a derived calss before our constructor has been called via "inherited Carete(...)" FOwnedAreas := nil; // <- Area destructors will remove itself from our ContainedAreas list! inherited Destroy; end; //function TGMUiAreaBase.QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; //var Frm: IGMAreaFrameDrawer; //begin //if GMEqualGuids(IID, IGMMultiFrameProperties) or GMEqualGuids(IID, IGMAreaFrameDrawer) then // // NOTE: Use FFrame member directly here! // begin Frm := FFrame; if Frm = nil then Result := E_NOINTERFACE else Result := Frm.QueryInterface(IID, Intf); end //else Result := inherited QueryInterface(IID, Intf); //end; //function TGMUiAreaBase.GetAutoCalcHeight: Boolean; //begin //Result := FAutoCalcHeight; //end; // //function TGMUiAreaBase.GetAutoCalcWidth: Boolean; //begin //Result := FAutoCalcWidth; //end; function TGMUiAreaBase.GetAutoCalcSize(const ADirection: TGM2DDirection): Boolean; begin Result := FAutoCalcSize[ADirection]; end; procedure TGMUiAreaBase.SetAutoCalcSize(const ADirection: TGM2DDirection; const AValue: Boolean); begin FAutoCalcSize[ADirection] := AValue; end; function TGMUiAreaBase.GetContainedAreas: IGMObjArrayCollection; begin Result := FContainedAreas; end; function TGMUiAreaBase.GetOwnedAreas: IGMObjArrayCollection; begin Result := FOwnedAreas; end; function TGMUiAreaBase.OwnArea(const AArea: TObject): TObject; begin if AArea <> nil then Result := OwnedAreas.Add(AArea) else Result := nil; end; function TGMUiAreaBase.GetSizeContraints: TGMSizeConstraintsRec; begin Result := FSizeConstraints; end; procedure TGMUiAreaBase.SetSizeContraints(const AValue: TGMSizeConstraintsRec); begin FSizeConstraints := AValue; end; function TGMUiAreaBase.GetEdgePosition(const AEdge: TEdge): LongInt; begin Result := PEdgeRectValue(@FLayoutBounds)[AEdge]; end; procedure TGMUiAreaBase.SetEdgePosition(const AEdge: TEdge; const AValue: LongInt); begin PEdgeRectValue(@FLayoutBounds)[AEdge] := AValue; end; function TGMUiAreaBase.GetEdgeSpace(const AEdge: TEdge): LongInt; begin Result := PEdgeRectValue(@FLayoutSpace)[AEdge]; end; procedure TGMUiAreaBase.SetEdgeSpace(const AEdge: TEdge; const AValue: LongInt); begin PEdgeRectValue(@FLayoutSpace)[AEdge] := AValue; end; function TGMUiAreaBase.GetFrame: IGMAreaFrameDrawer; begin Result := FFrame; end; procedure TGMUiAreaBase.SetFrame(const AFrame: IGMAreaFrameDrawer); begin FFrame := AFrame; end; function TGMUiAreaBase.GetEnabled: Boolean; stdcall; begin Result := True; end; function TGMUiAreaBase.ProcessHelp(var AHelpInfo: THelpInfo): Boolean; begin Result := False; end; function TGMUiAreaBase.ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown): Boolean; stdcall; begin Result := True; case Operation of Ord(goShow): SetVisible(True); Ord(goHide): SetVisible(False); end; end; procedure TGMUiAreaBase.ScheduleRepaint; var wnd: HWnd; rInvalidate: Trect; begin if not Visible or not GMFindAllocatedParentHandle(Parent, wnd) then Exit; rInvalidate := PaintingRect; InvalidateRect(wnd, @rInvalidate, False); end; procedure TGMUiAreaBase.CreateHandle; var i: LongInt; PIArea: IGMUiArea; begin // Recursive! => Create handles of invisible areas too! for i:=0 to ContainedAreas.Count-1 do if (ContainedAreas[i] <> nil) and ContainedAreas[i].GetInterface(IGMUiArea, PIArea) then PIArea.CreateHandle; end; function TGMUiAreaBase.RootForRelayout: TObject; begin Result := Self; end; procedure TGMUiAreaBase.AssignCtrlColorValues(var Msg: TMessage); begin case Msg.Msg of WM_CTLCOLOR, WM_CTLCOLORMSGBOX .. WM_CTLCOLORSTATIC, WM_CTLCOLOR + WM_APP, WM_CTLCOLORMSGBOX + WM_APP .. WM_CTLCOLORSTATIC + WM_APP: begin SetTextColor(HDC(Msg.WParam), GMRGBColor(FontColor)); if FontBkgndColor = clrTransparent then SetBkMode(HDC(Msg.WParam), TRANSPARENT) else SetBkMode(HDC(Msg.WParam), OPAQUE); if BkgndColor = clrTransparent then Msg.Result := LRESULT(GetStockObject(NULL_BRUSH)) else begin SetBkColor(HDC(Msg.WParam), GMRGBColor(BkgndColor)); Msg.Result := LRESULT(HBkgndBrush); end; end; end; end; procedure TGMUiAreaBase.DispatchMsg(var Msg: TMessage); begin Dispatch(Msg); end; function TGMUiAreaBase.IsDialogKeyMsg(const Msg: TMessage): Boolean; begin Result := ((Msg.Msg = WM_SYSKEYDOWN) or (Msg.Msg = WM_SYSKEYUP) or (Msg.Msg = WM_SYSCHAR) or (Msg.Msg = WM_SYSDEADCHAR)) or (((Msg.Msg = WM_KEYDOWN) or (Msg.Msg = WM_KEYUP) or (Msg.Msg = WM_CHAR)) and (((Msg.WParamLo in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) and (GMCallObjWindowProc(Self, WM_GETDLGCODE) and DLGC_WANTARROWS = 0)) or ((Msg.WParamLo = VK_TAB) and (GMCallObjWindowProc(Self, WM_GETDLGCODE) and DLGC_WANTTAB = 0)) or ((Msg.WParamLo = VK_RETURN) and (GMCallObjWindowProc(Self, WM_GETDLGCODE) and DLGC_WANTALLKEYS = 0)) or ((Msg.WParamLo = VK_ESCAPE) and not IsPopupWindow))); end; procedure TGMUiAreaBase.WindowProc(var Msg: TMessage); var targetArea, Dlg: TObject; MousePos: TPoint; // TmpCur: HCursor; //PIArea: IGMUiArea; // Wnd: HWnd; //function DlgTempCursor: HCursor; //var Dlg: TObject; //begin // if GMFindParentDlg(Self, Dlg) and (Dlg is TGMDlgWindow) then // Result := (Dlg as TGMDlgWindow).TempCursor // else // Result := 0; //end; begin case Msg.Msg of //WM_CTLCOLOR, WM_CTLCOLORMSGBOX .. WM_CTLCOLORSTATIC: AssignCtrlColorValues(Msg); // Send WM_CTLCOLORXXXX GMMessages back to the original control to be handled there WM_CTLCOLOR, WM_CTLCOLORMSGBOX .. WM_CTLCOLORSTATIC: with Msg do Result := SendMessage(LParam, Msg + WM_APP, WParam, LParam); WM_CTLCOLOR + WM_APP, WM_CTLCOLORMSGBOX + WM_APP .. WM_CTLCOLORSTATIC + WM_APP: AssignCtrlColorValues(Msg); // WM_SETCURSOR: // begin // TmpCur := DlgTempCursor; // if TmpCur <> 0 then begin SetCursor(TmpCur); Msg.Result := 1; end // else // begin // // NOTE: WM_SETCURSOR GMMessages do not contain mouse position information! // MousePos := GMScreenToClient(Self, GMMousePosition); // targetArea := AreaContainingPoint(MousePos); // if (targetArea <> nil) and (targetArea <> Self) then GMCallObjWindowProc(targetArea, Msg); // if Msg.Result = 0 then DispatchMsg(Msg); // end; // end; WM_NCLBUTTONDOWN, WM_NCRBUTTONDOWN, WM_NCMBUTTONDOWN: begin if vGMPopupArea <> nil then GMCancelPopup; DispatchMsg(Msg); end; WM_MOUSEFIRST .. WM_MOUSELAST: // NOTE: WM_MOUSEWHEEL redirection to the window beneeth the mouse is done in overridden WindowProc of TGMWindow. begin if vGMMouseCaptureArea <> nil then targetArea := vGMMouseCaptureArea else begin MousePos := SmallPointToPoint(TWMMouse(Msg).Pos); if Msg.Msg = WM_MOUSEWHEEL then MousePos := GMScreenToClient(Self, MousePos); targetArea := AreaContainingPoint(MousePos); if targetArea = nil then targetArea := Self; end; case Msg.Msg of WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN: if (vGMPopupArea <> nil) and not GMIsParentObj(vGMPopupArea, targetArea, True) then GMCancelPopup; end; if {(targetArea = nil) or} (targetArea = Self) then DispatchMsg(Msg) else GMCallObjWindowProc(targetArea, Msg); end; UM_DRAG_QUERYDROP, UM_DRAG_DROPPED: // UM_DRAG_CONTROL begin MousePos := GMPoint(PGMDragMessageRec(@Msg).XPos, PGMDragMessageRec(@Msg).YPos); targetArea := AreaContainingPoint(MousePos); if (targetArea = nil) or (targetArea = Self) then DispatchMsg(Msg) else GMDispatchObjMsg(targetArea, Msg); end; // Scrollbars send WM_CANCELMODE to themself when getting fullsize. // Overriden TGMScrollBar.WindowProc prevents redirection of those GMMessages! WM_KEYFIRST .. WM_KEYLAST: // , WM_SETFOCUS, WM_KILLFOCUS: // , WM_CANCELMODE // if vGMMouseCaptureArea = Self then DispatchMsg(Msg) // else // if vGMMouseCaptureArea <> nil then GMCallObjWindowProc(vGMMouseCaptureArea, Msg) // else if //GMIsInRange(Msg.Msg, WM_KEYFIRST, WM_KEYLAST) and (vGMKeyboardFocusArea <> nil) and (vGMKeyboardFocusArea <> Self) then GMCallObjWindowProc(vGMKeyboardFocusArea, Msg) else // Dont redirect to dialog here via GMCallObjWindowProc -> use GMDispatchObjMsg instead! if IsDialogKeyMsg(Msg) then begin if GMFindParentDlg(Self, Dlg) then GMDispatchObjMsg(Dlg, Msg); end else DispatchMsg(Msg); else DispatchMsg(Msg); end; end; procedure TGMUiAreaBase.UMDragQueryDrop(var Msg: TMessage); begin // if we receive a UM_DRAG_QUERYDROP message any other area must have been left! if (vGMDropTargetArea <> nil) and (vGMDropTargetArea <> Self) then GMCallObjWindowProc(vGMDropTargetArea, UM_DRAG_CONTROL, Ord(drgLeave)); vGMDropTargetArea := Self; end; procedure TGMUiAreaBase.WMSetFocus(var Msg: TWMSetFocus); begin //inherited; vGMKeyboardFocusArea := Self; end; procedure TGMUiAreaBase.WMKillFocus(var Msg: TWMKillFocus); begin //inherited; if vGMKeyboardFocusArea = Self then vGMKeyboardFocusArea := nil; // <- needed if send from other application end; procedure TGMUiAreaBase.WMLButtonDown(var Msg: TWMLButtonDown); begin inherited; if IsTabStop then GMSetFocus(Self); end; procedure TGMUiAreaBase.WMMouseMove(var Msg: TWMMouseMove); var leaveArea: TObject; wnd: HWnd; mouseIsOverUs: Boolean; begin // Mouse Move is relative to Client area -> use PaintingRect here! // Selection of AreaContainingPoint has been done in TGMwindow.WindowProc! // Mouse may have been captured, so consider mouse outside too! mouseIsOverUs := PtInRect(PaintingRect, GMPoint(Msg.XPos, Msg.YPos)); if mouseIsOverUs then // (Msg.XPos, Msg.YPos) begin if not MouseInside then begin leaveArea := vGMMouseInsideArea; vGMMouseInsideArea := Self; // <- make leaveArea.MouseInside return False if leaveArea <> nil then GMCallObjWindowProc(leaveArea, UM_MOUSELEAVE, TMessage(Msg).WParam, TMessage(Msg).LParam); GMCallObjWindowProc(Self, UM_MOUSEENTER, TMessage(Msg).WParam, TMessage(Msg).LParam); if GMFindAllocatedParentHandle(Self, wnd) then SendMessage(wnd, UM_STARTMOUSETRACK, 0, 0); end; end else begin if MouseInside then begin vGMMouseInsideArea := nil; GMCallObjWindowProc(Self, UM_MOUSELEAVE, TMessage(Msg).WParam, TMessage(Msg).LParam); end; end; inherited; end; procedure TGMUiAreaBase.SurfaceOriginChanged; var i: LongInt; //PIOriginChange: IGMSurfaceOriginChanged; begin for i:=0 to ContainedAreas.Count-1 do if ContainedAreas[i] is TGMUiAreaBase then TGMUiAreaBase(ContainedAreas[i]).SurfaceOriginChanged; //if (ContainedAreas[i] <> nil) and ContainedAreas[i].GetInterface(IGMSurfaceOriginChanged, PIOriginChange) then //PIOriginChange.SurfaceOriginChanged; end; procedure TGMUiAreaBase.AfterParentChanged; var i: LongInt; begin for i:=0 to ContainedAreas.Count-1 do if ContainedAreas[i] is TGMUiAreaBase then TGMUiAreaBase(ContainedAreas[i]).AfterParentChanged; end; function TGMUiAreaBase.MouseInside: Boolean; begin Result := vGMMouseInsideArea = Self; end; function TGMUiAreaBase.HasFocus: Boolean; var prntWnd: HWnd; begin Result := (vGMKeyboardFocusArea = Self) and GMFindAllocatedParentHandle(Self, prntWnd) and (prntWnd = GetFocus); end; function TGMUiAreaBase.IsTabStop: Boolean; begin Result := False; end; procedure TGMUiAreaBase.InvalidateCachedLayoutValues; var i: LongInt; //PIOriginChange: IGMSurfaceOriginChanged; begin FLastLayoutSize := GMPoint(cInvalidLayoutVal, cInvalidLayoutVal); FLastLayoutOrigin := GMPoint(cInvalidLayoutVal, cInvalidLayoutVal); for i:=0 to ContainedAreas.Count-1 do if ContainedAreas[i] is TGMUiAreaBase then TGMUiAreaBase(ContainedAreas[i]).InvalidateCachedLayoutValues; end; function TGMUiAreaBase.FontHandle: THandle; begin Result := GetStockObject(DEFAULT_GUI_FONT); // <- Stock objects dont need to be deleted end; function TGMUiAreaBase.FontColor: COLORREF; stdcall; begin if Assigned(OnGetFontColor) then Result := OnGetFontColor else Result := clrWindowText; end; function TGMUiAreaBase.FontBkgndColor: COLORREF; begin Result := BkgndColor; end; function TGMUiAreaBase.GetVisible: Boolean; begin Result := FVisible; end; function TGMUiAreaBase.AreaFiller: IGMAreaFiller; begin Result := GMAreaRegionFiller; end; function TGMUiAreaBase.FrameColor: COLORREF; begin Result := clSilver; // clDkGray; // $e19e82; // cDfltColor; // BKgndColor ? end; function TGMUiAreaBase.IsLayoutChild: Boolean; begin Result := True; end; function TGMUiAreaBase.ParticipateInLayouting: Boolean; begin Result := Visible; end; //function TGMUiAreaBase.ClippedPainting: Boolean; //begin // Result := False; //end; function TGMUiAreaBase.IsPopupWindow: Boolean; begin Result := False; end; function TGMUiAreaBase.HBkgndBrush: THandle; begin if Assigned(OnGetHBkgndBrush) then Result := OnGetHBkgndBrush else Result := 0; if Result = 0 then begin if FBkgndBrush = nil then if BkgndColor = clrTransparent then FBkgndBrush := GMGetCachedBrush(0, BS_NULL) // TGMGdiBrush.Create(0, 0, BS_NULL) else FBkgndBrush := GMGetCachedBrush(BkgndColor); // TGMGdiBrush.Create(0, BkgndColor); Result := FBkgndBrush.Handle; end; end; function TGMUiAreaBase.BkgndColor: COLORREF; stdcall; begin if Assigned(OnGetBkgndColor) then Result := OnGetBkgndColor else Result := FBkgndColor; end; procedure TGMUiAreaBase.SetBkgndColor(const AValue: COLORREF; const ARepaint: Boolean); stdcall; begin if AValue = BkgndColor then Exit; FBkgndColor := AValue; FBkgndBrush := nil; if ARepaint then ScheduleRepaint; end; function TGMUiAreaBase.InternalCalcHeight(const ANewSize: TPoint): LongInt; begin Result := ANewSize.y; end; procedure TGMUiAreaBase.Clear(const ANotify: Boolean); begin // Nothing end; function TGMUiAreaBase.InternalCalcWidth(const ANewSize: TPoint): LongInt; begin Result := ANewSize.x; end; function TGMUiAreaBase.CalculateWidth(const ANewSize: TPoint): LongInt; //var y: LongInt; begin //if FAutoCalcSize[d2dHorizontal] then Result := InternalCalcWidth(GMPoint(ANewSize.x, Max(1, ANewSize.y))) else Result := ANewSize.x; Result := InternalCalcWidth(GMPoint(ANewSize.x, Max(1, ANewSize.y))); //y := Max(1, ANewSize.y); //if y = FCachedCalcWidth.Y then Result := FCachedCalcWidth.x else // begin // Result := InternalCalcWidth(GMPoint(ANewSize.x, y)); // FCachedCalcWidth := GMPoint(Result, y); // end; end; function TGMUiAreaBase.CalculateHeight(const ANewSize: TPoint): LongInt; //var x: LongInt; begin //if FAutoCalcSize[d2dVertical] then Result := InternalCalcHeight(GMPoint(Max(1, ANewSize.x), ANewSize.y)) else Result := ANewSize.y; Result := InternalCalcHeight(GMPoint(Max(1, ANewSize.x), ANewSize.y)); //x := Max(1, ANewSize.x); //if x = FCachedCalcHeight.x then Result := FCachedCalcHeight.y else // begin // Result := InternalCalcHeight(GMPoint(x, ANewSize.y)); // FCachedCalcHeight := GMPoint(x, Result); // end; end; procedure TGMUiAreaBase.SetShowing(const Value: Boolean); begin // Nothing! end; procedure TGMUiAreaBase.InternalSetVisible(const Value: Boolean); // Relayout begin // Nothing! end; procedure TGMUiAreaBase.SetVisible(const AValue: Boolean; const ARelayout: Boolean); begin if AValue = FVisible then Exit; FVisible := AValue; if ARelayout then GMReLayoutContainedAreas(Parent); InternalSetVisible(AValue); if not AValue and IsTabStop and (vGMKeyboardFocusArea = Self) then GMPostSeletNextDlgTabAreaMsg(Self); end; procedure TGMUiAreaBase.SetParentObj(const AValue: TObject; const ARelayout: Boolean); var PIArea: IGMUiArea; begin if FParent = AValue then Exit; if (FParent <> nil) and FParent.GetInterface(IGMUiArea, PIArea) then begin PIArea.ContainedAreas.RemoveByKey(Self); if ARelayout then GMReLayoutContainedAreas(FParent); end; FParent := AValue; if IsLayoutChild and GMGetInterface(AValue, IGMUiArea, PIArea) then begin PIArea.ContainedAreas.Add(Self); if ARelayout then GMReLayoutContainedAreas(AValue); end; AfterParentChanged; //if (Parent is TGMUiAreaBase) and IsLayoutChild then TGMUiAreaBase(Parent).ContainedAreas.Add(Self); //if Parent is TGMUiAreaBase then TGMUiAreaBase(Parent).ContainedAreas.Remove(Self); end; function TGMUiAreaBase.GetAreaAlign: TGMAreaAlignRec; begin Result := FAreaAlign; end; procedure TGMUiAreaBase.SetAreaAilgn(const AAreaAlign: TGMAreaAlignRec); begin FAreaAlign := AAreaAlign; end; function TGMUiAreaBase.GetEdgeAlign(const Edge: TEdge): TEdgeAlign; begin Result := FAreaAlign.EdgeAlign[Edge]; end; procedure TGMUiAreaBase.SetEdgeAlign(const Edge: TEdge; const Value: TEdgeAlign); begin FAreaAlign.EdgeAlign[Edge] := Value; end; function TGMUiAreaBase.GetLayoutSpace: TRect; begin Result := FLayoutSpace; end; procedure TGMUiAreaBase.SetLayoutSpace(const AValue: TRect); begin FLayoutSpace := AValue; end; function TGMUiAreaBase.GetLayoutBounds: TRect; begin Result := FLayoutBounds; end; procedure TGMUiAreaBase.SetLayoutBounds(const AValue: TRect; const ARepaint: Boolean); begin FLayoutBounds := AValue; end; function TGMUiAreaBase.ClientAreaOrigin: TPoint; var prntArea: IGMUiArea; begin Result := GMAddPoints(ScrollOffset, GMCalculateClientRect(Frame, LayoutBounds).TopLeft); if GMGetInterface(Parent, IGMUiArea, prntArea) and prntArea.IsLayoutChild then Result := GMAddPoints(Result, prntArea.ClientAreaOrigin); // <- Recursive! end; function TGMUiAreaBase.ClientAreaSize: TPoint; begin Result := GMRectSize(GMCalculateClientRect(Frame, LayoutBounds)); end; function TGMUiAreaBase.CalculateSurfaceRect(const ARect: TRect): TRect; var prntArea: IGMUiArea; begin Result := ARect; if IsLayoutChild and GMGetInterface(Parent, IGMUiArea, prntArea) then Result := GMMoveRect(Result, prntArea.ClientAreaOrigin); end; function TGMUiAreaBase.PaintingRect: TRect; begin Result := CalculateSurfaceRect(LayoutBounds); end; function TGMUiAreaBase.IsFramed: Boolean; begin Result := GMFrameExtent(FFrame) <> cNullPoint; // <- If FFrame is nil GMFrameExtent will return cNullPoint end; function TGMUiAreaBase.PointInsideArea(const APoint: TPoint): Boolean; begin Result := PtInRect(CalculateSurfaceRect(LayoutBounds), APoint); end; function TGMUiAreaBase.AreaContainingPoint(const APoint: TPoint): TObject; function ChildAreaContainingPoint(const APoint: TPoint): TObject; var i: LongInt; area: IGMUiArea; begin Result := nil; for i:=0 to ContainedAreas.Count-1 do if (ContainedAreas[i] <> nil) and not GMAreaHasWndHandle(ContainedAreas[i]) and ContainedAreas[i].GetInterface(IGMUiArea, area) and area.Visible and area.PointInsideArea(APoint) then begin Result := area.AreaContainingPoint(APoint); Break; end; end; begin Result := ChildAreaContainingPoint(APoint); if (Result = nil) and Self.PointInsideArea(APoint) then Result := Self; end; function TGMUiAreaBase.GetParentObj: TObject; begin Result := FParent; end; procedure TGMUiAreaBase.LayoutContainedAreas(const ARepaint: Boolean); // : TPoint; begin GMLayoutContainedAreas(Self, ARepaint, vGMLayoutEdgeOrderMap); FLastLayoutSize := GMRectSize(FLayoutBounds); end; procedure TGMUiAreaBase.LayoutContainedAreasIfNeeded(const ARepaint: Boolean); // : TPoint; var areaSize, areaOrigin: TPoint; begin areaSize := GMRectSize(FLayoutBounds); //Result := areaSize; if areaSize <> FLastLayoutSize then LayoutContainedAreas(ARepaint) else begin areaOrigin := ClientAreaOrigin; if areaOrigin <> FLastLayoutOrigin then begin SurfaceOriginChanged; FLastLayoutOrigin := areaOrigin; end; end; FLastLayoutSize := areaSize; end; function TGMUiAreaBase.CreateAreaRegion(const ABoundingRect: TRect; const ARegionKind: TGMAreaRegionKind): IGMGetHandle; //const cRndDiff: array [TGMAreaRegionKind] of LongInt = (0, 1); begin //Result := TGMGdiRegion.CreateRoundRect(0, ABoundingRect, GMPoint(Max(0, CornerRounding.x - cRndDiff[ARegionKind]), Max(0, CornerRounding.y - cRndDiff[ARegionKind]))); Result := TGMGdiRegion.CreateRoundRect(0, ABoundingRect, CornerRounding); end; function TGMUiAreaBase.FillsComplete: Boolean; begin Result := BkgndColor <> clrTransparent; end; function TGMUiAreaBase.PaintsComplete: Boolean; begin // if PaintArea always covers whole area return true Result := False; // <- Fill PaintingRect with HBkgndBrush end; function TGMUiAreaBase.SubtractContainedAreas(const ARect: TRect; const AResultRegion: HRGN): Boolean; var i: LongInt; childArea: IGMUiArea; rgnChild: IGMGetHandle; childRect: TRect; begin Result := False; if AResultRegion = 0 then Exit; for i:=0 to ContainedAreas.Count-1 do if GMGetInterface(ContainedAreas[i], IGMUiArea, childArea) and childArea.Visible then begin // // Child area calculation is done relatve to ARect. So the caller decides if the DC is // is a window DC at LayoutBounds or a Bitmap at origin <0,0> // childRect := GMMoveRect(childArea.LayoutBounds, GMAddPoints(ARect.TopLeft, ScrollOffset)); rgnChild := childArea.CreateAreaRegion(childRect, arkBounds); if childArea.PaintsComplete or childArea.FillsComplete then begin if CombineRgn(AResultRegion, AResultRegion, rgnChild.Handle, RGN_DIFF) = NULLREGION then begin Result := True; Break; end; end else if childArea.SubtractContainedAreas(childRect, AResultRegion) then begin Result := True; Break; end; end; end; procedure TGMUiAreaBase.PaintBackground(const ADC: HDC; const AClientRect: TRect; const ARegion: IGMGetHandle); var bkgndFiller: IGMAreaFiller; // ClipRgnKeeper: IUNknown; begin if not FillsComplete or (ARegion = nil) then Exit; if not SubtractContainedAreas(AClientRect, ARegion.Handle) then begin bkgndFiller := AreaFiller; if bkgndFiller = nil then bkgndFiller := GMAreaRegionFiller; // // When filled with a brush a bkgndFiller may use FillRgn -> then no clipping is needed. // If the bkgndFiller drawas an image it must set the clipping region to ARegion itself. // Since cliiping means overhead we dont always do this here. // //ClipRgnKeeper := TGMGdiClipRgnKeeper.Create(ADC, ARegion.Handle, RGN_AND); bkgndFiller.Paint(Self, ADC, ARegion.Handle, HBkgndBrush); end; end; procedure TGMUiAreaBase.PaintContainedAreas(const ADC: HDC; const AClientRect: TRect); var i: LongInt; area: TGMUiArea; begin if ADC = 0 then Exit; for i:=0 to ContainedAreas.Count-1 do if ContainedAreas[i] is TGMUiArea then begin area := TGMUiArea(ContainedAreas[i]); // // Child area calculation is done relatve to AClientRect. So the caller may decide if the DC is // is a window DC at LayoutBounds or a Bitmap at origin <0, 0> // // Paint only windowless areas here, windowed areas will receive their own WM_PAINT messages from the system // if area.Visible and not GMAreaHasWndHandle(ContainedAreas[i]) then area.PaintToRect(ADC, GMMoveRect(area.LayoutBounds, GMAddPoints(AClientRect.TopLeft, ScrollOffset))); end; end; function TGMUiAreaBase.PaintArea(const ADC: HDC; const ARect: TRect): Boolean; begin Result := True; // <- dont pass WM_PAINT to original handler end; function TGMUiAreaBase.InternalPaintToRect(const ADC: HDC; const ADestRect: TRect): Boolean; var areaRgn, clientRgn: IGMGetHandle; rClient: TRect; frm: IGMAreaFrameDrawer; clipRgn: IUnknown; //bkBrush, font, fontColors, state, clipRgn: IUnknown; begin Result := False; if ADC = 0 then Exit; areaRgn := CreateAreaRegion(ADestRect, arkBounds); if areaRgn = nil then Exit; //State := TGMGdiDCStateKeeper.Create(ADC); SelectObject(ADC, HBkgndBrush); SelectObject(ADC, FontHandle); SetTextColor(ADC, GMRGBColor(FontColor)); if FontBkgndColor = clrTransparent then SetBkMode(ADC, TRANSPARENT) else begin SetBkMode(ADC, OPAQUE); SetBkColor(ADC, GMRGBColor(FontBkgndColor)); end; // Setup temporary DC properites for the duration of this call //bkBrush := TGMGdiObjSelector.Create(ADC, HBkgndBrush); //font := TGMGdiObjSelector.Create(ADC, FontHandle); //fontColors := TGMGdiTextColorSelector.Create(ADC, FontColor, FontBkgndColor); // // Avoid painting outside of our area, useful for containers with many children that may overflow other areas when completely painted // Clipping causes Windows Buttons not being filled with backround anymore .. but not subtracting contained areas makes them fill again // if ClippedPainting then clipRgn := TGMGdiClipRgnKeeper.Create(ADC, areaRgn.Handle, RGN_AND); frm := Frame; if frm = nil then begin clientRgn := areaRgn; rClient := ADestRect; end else begin rClient := frm.CalculateClientRect(ADestRect); if EqualRect(rClient, ADestRect) then clientRgn := areaRgn else clientRgn := CreateAreaRegion(rClient, arkClient); end; if not PaintsComplete then PaintBackground(ADC, rClient, clientRgn); Result := PaintArea(ADC, rClient); PaintContainedAreas(ADC, rClient); if frm <> nil then frm.DrawFrame(Self, ADC, areaRgn.Handle, GMRGBColor(FrameColor)); // <- do this last! end; function TGMUiAreaBase.PaintToRect(const ADC: HDC; const ADestRect: TRect): Boolean; var paintDC, paintBmp: IGMGetHandle; paintSz: TPoint; begin //GetclipBox(ADC, RClip); //if not IntersectRect(RClip, RClip, RPaint) then Exit; // <- Exit early if no painting is needed if not RectVisible(ADC, ADestRect) then Exit(True); // <- Checks if RPaint intersects clipping region, Exit early if no painting is needed if not BufferedPainting then Result := InternalPaintToRect(ADC, ADestRect) else begin paintSz := GMRectSize(ADestRect); paintSz.x := Max(paintSz.x, 0); paintSz.y := Max(paintSz.y, 0); paintDC := TGMGdiCompatibleDC.Create(0, ADC); paintBmp := TGMGdiBitmap.CreateCompatibleBmp(paintDC.Handle, ADC, paintSz, True); if not (PaintsComplete or FillsComplete) then BitBlt(paintDC.Handle, 0, 0, paintSz.x, paintSz.y, ADC, ADestRect.Left, ADestRect.Top, SRCCOPY); // <- copy original area content Result := InternalPaintToRect(paintDC.Handle, GMRect(cNullPoint, paintSz)); BitBlt(ADC, ADestRect.Left, ADestRect.Top, paintSz.x, paintSz.y, paintDC.Handle, 0, 0, SRCCOPY); // <- copy drawed contens back to original DC end; end; function TGMUiAreaBase.Paint(const ADC: HDC): Boolean; begin // Painting is relative to window DC area! LayoutBounds is relative to parent Area! if ADC <> 0 then Result := PaintToRect(ADC, PaintingRect) else Result := True; end; { ------------------- } { ---- TGMUiArea ---- } { ------------------- } function CompareWndMsg(const ItemA, ItemB: TGMWndMsg): TGMCompareResult; begin if ItemA < ItemB then Result := crALessThanB else if ItemA > ItemB then Result := crAGreaterThanB else Result := crAEqualToB; end; constructor TGMUiArea.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); //FDispatchToParentMessages := TGMIntfHashTable.Create(False, GMCompareByWndMessage, True); FDispatchToParentMessages := TGMGenericArrayCollection<TGMWndMsg>.Create(False, True, CompareWndMsg, nil, True); //FDispatchToParentMessages := TGMIntfArrayCollection.Create(False, True, GMCompareByWndMessage, True); //FDispatchToParentMessages := TGMAvlIntfTree.Create(False, GMCompareByWndMessage, True); end; procedure TGMUiArea.DispatchMsg(var AMsg: TMessage); //var msgObj: IUnknown; procedure DispatchToSelf; begin inherited DispatchMsg(AMsg); if (AMsg.Msg = WM_MOUSEWHEEL) and (AMsg.Result = 0) then GMDispatchObjMsg(Parent, AMsg); end; begin //if GMIsOneOfIntegers(AMsg.Msg, DispatchToParentMessages) then GMDispatchObjMsg(Parent, AMsg) else if DispatchToParentMessages.IsEmpty then DispatchToSelf else begin //msgObj := TGMWndMessageObj.Create(AMsg.Msg, True); //if GMCollectionContains(DispatchToParentMessages, msgObj) then GMDispatchObjMsg(Parent, AMsg) else DispatchToSelf; if DispatchToParentMessages.Contains(AMsg.Msg) then GMDispatchObjMsg(Parent, AMsg) else DispatchToSelf; end; end; procedure TGMUiArea.InternalSetVisible(const Value: Boolean); begin inherited; SetShowing(Value); end; procedure TGMUiArea.SetShowing(const Value: Boolean); var i: LongInt; PIArea: IGMUiArea; begin inherited; for i:=0 to ContainedAreas.Count-1 do if GMGetInterface(ContainedAreas[i], IGMUiArea, PIArea) and PIArea.Visible then PIArea.SetShowing(Value); end; procedure TGMUiArea.SetLayoutBounds(const AValue: TRect; const ARepaint: Boolean); var ARect: TRect; WndPrnt: HWnd; repaintBounds: TRect; begin UnionRect(repaintBounds, FLayoutBounds, AValue); inherited SetLayoutBounds(AValue, ARepaint); LayoutContainedAreasIfNeeded(ARepaint); if ARepaint and Visible and not IsRectEmpty(AValue) and GMFindAllocatedParentHandle(Parent, WndPrnt) then begin ARect := CalculateSurfaceRect(repaintBounds); if not IsRectEmpty(ARect) then InvalidateRect(WndPrnt, @ARect, False); end; end; { -------------------------------- } { ---- TGMForeignWndContainer ---- } { -------------------------------- } constructor TGMForeignWndContainer.Create(const AParent: TObject; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const AForeignWnd: HWnd; const ABkgndColor: COLORREF; const AVisible: Boolean; const ARefLifeTime: Boolean); begin inherited Create(AParent, APosition, AAreaAlign, ABkgndColor, AVisible, ARefLifeTime); FForeignWnd := AForeignWnd; //if IsWindow(FForeignWnd) then SetWindowLong(FForeignWnd, GWL_STYLE, GetWindowLong(FForeignWnd, GWL_STYLE) or WS_CHILD); end; procedure TGMForeignWndContainer.CreateForeignWnd; begin if FForeignWnd = 0 then FForeignWnd := InternalCreateForeignWnd; end; procedure TGMForeignWndContainer.SetLayoutBounds(const Value: TRect; const ARepaint: Boolean); begin inherited; CreateForeignWnd; if IsWindow(FForeignWnd) then //GMAPICheckObj(... , Self, 'SetWindowPos'); SetWindowPos(FForeignWnd, 0, Value.Left, Value.Top, GMRectSize(Value).x, GMRectSize(Value).y, SWP_NOZORDER or SWP_NOACTIVATE or cWinPosRedraw[ARepaint]); end; function TGMForeignWndContainer.InternalCalcHeight(const ANewSize: TPoint): LongInt; begin CreateForeignWnd; if not IsWindow(FForeignWnd) then Result := inherited InternalCalcHeight(ANewSize) else Result := SendMessage(FForeignWnd, UM_CALCHEIGHT, ANewSize.x, ANewSize.y); end; function TGMForeignWndContainer.InternalCalcWidth(const ANewSize: TPoint): LongInt; begin CreateForeignWnd; if not IsWindow(FForeignWnd) then Result := inherited InternalCalcWidth(ANewSize) else Result := SendMessage(FForeignWnd, UM_CALCWIDTH, ANewSize.x, ANewSize.y); end; procedure TGMForeignWndContainer.InternalSetVisible(const Value: Boolean); // const Relayout: Boolean begin if Value then CreateForeignWnd; inherited; //InternalSetVisible(Value); // Relayout if not IsWindow(FForeignWnd) then Exit; ShowWindow(FForeignWnd, cSWShow[Value]); end; function TGMForeignWndContainer.PaintsComplete: Boolean; begin Result := IsWindow(FForeignWnd); end; { ------------------------------ } { ---- TGMSurroundingUiArea ---- } { ------------------------------ } constructor TGMSurroundingUiArea.Create(const AParent: TObject; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const APaddSpace: TPoint; const ABkgndColor: COLORREF; const AVisible, ARefLifeTime: Boolean); begin {inherited} Create(AParent, APosition, AAreaAlign, ABkgndColor, AVisible, ARefLifeTime); FPaddSpace := APaddSpace; end; function TGMSurroundingUiArea.RootForRelayout: TObject; begin // Child Text change => child size change => relayout parent (us) // since our size depends on child sizes we need to forward re-layout to our parent. Result := GMParentRootForRelayout(Self); end; function TGMSurroundingUiArea.InternalcalcHeight(const ANewSize: TPoint): LongInt; begin // The caller will assign his layoutbounds just after this. // So temporary setting our bounds to be able to correctly layout childs does no harm. Result := GMCalcBoundingHeight(Self, ANewSize) + FPaddSpace.y; end; function TGMSurroundingUiArea.InternalCalcWidth(const ANewSize: TPoint): LongInt; begin // The caller will assign his layoutbounds just after this. // So temporary setting our bounds to be able to correctly layout childs does no harm. Result := GMCalcBoundingWidth(Self, ANewSize) + FPaddSpace.x; end; { -------------------------------- } { ---- TGMWndPaintDisableImpl ---- } { -------------------------------- } //constructor TGMWndPaintDisableImpl.Create(const AOwner: TObject; const ARefLifeTime: Boolean); //begin //inherited Create(ARefLifeTime); //FOwner := AOwner; //end; // //function TGMWndPaintDisableImpl.QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; //var PIUnkOwner: IUnknown; //begin //Result := inherited QueryInterface(IID, Intf); //if (Result <> S_OK) and (FOwner <> nil) and FOwner.GetInterface(IUnknown, PIUnkOwner) then // Result := PIUnkOwner.QueryInterface(IID, Intf); //end; // //function TGMWndPaintDisableImpl._AddRef: LongInt; //var PIUnkOwner: IUnknown; //begin //if (FOwner <> nil) and FOwner.GetInterface(IUnknown, PIUnkOwner) then // Result := PIUnkOwner._AddRef //else // Result := inherited _AddRef; //end; // //function TGMWndPaintDisableImpl._Release: LongInt; //var PIUnkOwner: IUnknown; //begin //if (FOwner <> nil) and FOwner.GetInterface(IUnknown, PIUnkOwner) then // Result := PIUnkOwner._Release //else // Result := inherited _Release; //end; // //function TGMWndPaintDisableImpl.GetPaintDisabledCount: LongInt; //begin //Result := FPaintDisableCount; //end; // //procedure TGMWndPaintDisableImpl.SendEnableMsg(const AEnable: Boolean); //var PIHandle: IGMGetHandle; HAlloc: IGMHandleAllocated; //begin //if (FPaintDisableCount = 0) and (FOwner <> nil) and // (not FOwner.GetInterface(IGMHandleAllocated, HAlloc) or HAlloc.HandleAllocated) and // FOwner.GetInterface(IGMGetHandle, PIHandle) then // begin // SendMessage(PIHandle.Handle, WM_SETREDRAW, Ord(AEnable), 0); // if AEnable then InvalidateRect(PIHandle.Handle, nil, False); // end; //end; // //function TGMWndPaintDisableImpl.DisablePaint: LongInt; //begin //SendEnableMsg(False); //Inc(FPaintDisableCount); //Result := FPaintDisableCount; //end; // //function TGMWndPaintDisableImpl.EnablePaint: LongInt; //begin //FPaintDisableCount := Max(0, FPaintDisableCount-1); //Result := FPaintDisableCount; //SendEnableMsg(True); //end; { ------------------- } { ---- TGMWindow ---- } { ------------------- } constructor TGMWindow.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FRelayedMessages := cDfltRelayedMessages; end; constructor TGMWindow.Create(const AParent: TGMWndObj; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const AWndStyle: DWORD; const AWndExStyle: DWORD; const AText: TGMString; const AMenu: HMENU; const ABkgndColor: COLORREF; const ARefLifeTime: Boolean); var vsbl: Boolean; begin //FPaintDisabler := TGMWndPaintDisableImpl.Create(Self, False); FCreateData.Text := GMResolveTextResData(AText, FTextResData); vsbl := AWndStyle and WS_VISIBLE <> 0; FCreateData.WndStyle := AWndStyle; FCreateData.WndExStyle := AWndExStyle; FCreateData.Menu := AMenu; FCreateData.ParentWnd := GMHWndFromWndObj(AParent); if AParent < 0 then {inherited} Create(TObject(-AParent), APosition, AAreaAlign, ABkgndColor, vsbl, ARefLifeTime) else {inherited} Create(GMObjFromWnd(HWnd(AParent)), APosition, AAreaAlign, ABkgndColor, vsbl, ARefLifeTime); end; destructor TGMWindow.Destroy; begin //GMFreeAndNil(FPaintDisabler); if HandleAllocated then DestroyHandle(False); inherited Destroy; end; function TGMWindow.ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown): Boolean; begin Result := True; case Operation of Ord(goEnable): GMEnableWindow(Self, True); Ord(goDisable): GMEnableWindow(Self, False); else Result := inherited ExecuteOperation(Operation, Parameter); end; end; function TGMWindow.GetHandle: THandle; stdcall; begin if not HandleAllocated then CreateHandle; Result := FHandle; end; function TGMWindow.GetHandleAllocated: Boolean; stdcall; begin Result := FHandle <> 0; end; //function TGMWindow.GetVisible: Boolean; //begin //Result := WndStyle and WS_VISIBLE <> 0; //end; procedure TGMWindow.CreateParentHandle; var handle: IGMGetHandle; begin handle := GMFindWindowedParent(Parent); if handle <> nil then FCreateData.ParentWnd := handle.Handle; // <- accessing the Handle property will create the Handle if it has not yet been created end; function TGMWindow.WndSizeFromClientSize(const AClientSize: TPoint): TPoint; begin Result := GMWndSizeFromClientSize(AClientSize, WndStyle, WndExStyle, FCreateData.Menu <> 0); end; {function TGMWindow.Frame: IGMAreaFrameDrawer; begin // // Windows draw their frames via WM_NCPAINT and get adjusted via WM_NCCALCSIZE. // They dont draw or adjust by frame inside their client area. // Result := nil; // <- In WM_NCPAINT and WM_NCCALCSIZE we use FFrame memeber directly! end;} function TGMWindow.WndClassRegName: TGMString; begin Result := ClassName; end; function TGMWindow.CursorHandle: HCURSOR; begin Result := LoadCursor(0, Pointer(IDC_ARROW)); end; //function TGMWindow.TempCursor: HCURSOR; //begin //Result := 0; //end; function TGMWindow.RegisterWndClass: TGMString; begin Result := GMRegisterWindowClass(WndClassRegName, CursorHandle, CS_DBLCLKS).Name; // <- generates new class if neccessary end; function TGMWindow.WndCreateRect: TRect; begin Result := CalculateSurfaceRect(LayoutBounds); end; function TGMWindow.GetFrame: IGMAreaFrameDrawer; begin // // For windowed areas the NC (non client) messages are using the FFrame member directly. // Everybody else gets this nil pointer! // Note: The Frame can be set! // Result := nil; end; function TGMWindow.HasWindowRegion: Boolean; begin Result := (CornerRounding.x <> 0) and (CornerRounding.y <> 0); end; procedure TGMWindow.InternalCreateHandle; var rWnd: TRect; wndClassName: TGMString; begin //inherited; CreateParentHandle; // <- recursively create all parent handles rWnd := WndCreateRect; if rWnd.Left <> LongInt(CW_USEDEFAULT) then rWnd.Right := GMRectSize(rWnd).x; if rWnd.Top <> LongInt(CW_USEDEFAULT) then rWnd.Bottom := GMRectSize(rWnd).y; wndClassName := RegisterWndClass; with FCreateData do FHandle := CreateWindowEx(WndExStyle, PGMChar(wndClassName), PGMChar(Text), WndStyle, //rWnd.Left, rWnd.Top, GMRectSize(rWnd).x, GMRectSize(rWnd).y, rWnd.Left, rWnd.Top, rWnd.Right, rWnd.Bottom, ParentWnd, Menu, {$IFDEF JEDIAPI}{$IFDEF FPC}System.{$ELSE}SysInit.{$ENDIF}{$ENDIF}HInstance, nil); GMAPICheckObj('CreateWindowEx', '', GetLastError, FHandle <> 0, Self); if not IsLayoutChild then GetWindowRect(FHandle, FLayoutBounds); // <- CW_USEDEFAULT may have been used! FOrgWndPtrData := SetWindowLongPtr(FHandle, cWndObjPtrData, PtrInt(Self)); {ToDO: Use window extra memory to store self pointer?} FOrgWndProc := Pointer(SetWindowLongPtr(FHandle, GWL_WNDPROC, PtrInt(@GMStdWndProc))); if FontHandle <> 0 then GMCallObjWindowProc(Self, WM_SETFONT, PtrInt(FontHandle), 0); // SendMessage(FHandle, WM_SETFONT, FontHandle, 0); // SetWindowPos generates WM_SIZE, size delta will be (0, 0) if not framed if HasWindowRegion then // // Note: rWnd.Right and rWnd.Bottom contain Width and Height here // SetWindowRgn(FHandle, CreateRoundRectRgn(0, 0, rWnd.Right+1, rWnd.Bottom+1, CornerRounding.x, CornerRounding.y), False); //GMAPICheck(SetWindowRgn(FHandle, CreateRoundRectRgn(0, 0, rWnd.Right, rWnd.Bottom, CornerRounding.x, CornerRounding.y), False) <> 0, 'SetWindowRgn'); // Needed for framed OEM controls if FCreateData.WndStyle and (WS_VISIBLE or WS_CHILD) = (WS_VISIBLE or WS_CHILD) then SetWindowPos(FHandle, 0,0,0,0,0, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_FRAMECHANGED); // Layout children before their handles are created to display them in the correct palce right away. LayoutContainedAreasIfNeeded(False); // <- just created invalidated anyway! // In case SetText has been called before the handle was created if Length(FCreateData.Text) > 0 then begin SendMessage(FHandle, WM_SETTEXT, 0, LPARAM(PGMChar(FCreateData.Text))); FCreateData.Text := ''; end; PostMessage(FHandle, UM_HANDLECREATED, 0, 0); // <- useful for operations that need to be done once after creation end; procedure TGMWindow.CreateHandle; begin if not HandleAllocated then InternalCreateHandle; // Call inherited if allocated -> new child windows may have been added inherited; // <- recursively create all child handles end; procedure TGMWindow.WMNCDestroy(var Msg: TWMNCDestroy); begin inherited; //SetWindowLongPtr(FHandle, cWndObjPtrData, FOrgWndPtrData); FHandle := 0; FOrgWndPtrData := 0; FOrgWndProc := nil; //FVisible := False; dont reset, keep FVisible for re-creation end; procedure TGMWindow.DestroyHandle(const ARememberState: Boolean); begin if HandleAllocated then begin if ARememberState then begin FCreateData.Text := GetText; // <- handle is allocated, taken from handle! FCreateData.WndStyle := WndStyle; // <- handle is allocated, taken from handle! FCreateData.WndExStyle := WndExStyle; // <- handle is allocated, taken from handle! // GetWindowRect(FHandle, FLayoutBounds); // FLayoutBounds := GetLayoutBounds; end; DestroyWindow(FHandle); // <- don't check, never raise in destructors! //GMAPICheckObj(Windows.DestroyWindow(FHandle), Self, 'DestroyWindow'); end; end; procedure TGMWindow.DispatchMsg(var Msg: TMessage); begin FPassMessageToOriginalHandler := True; inherited DispatchMsg(Msg); // <- may change FPassMessageToOriginalHandler in derived message handlers if no call to FOrgWndProc is wanted if FPassMessageToOriginalHandler and (FOrgWndProc <> nil) then Msg.Result := CallWindowProc(FOrgWndProc, FHandle, Msg.Msg, Msg.WParam, Msg.LParam); //else //Msg.Result := DefWindowProc(FHandle, Msg.Msg, Msg.WParam, Msg.LParam); end; procedure TGMWindow.WindowProc(var Msg: TMessage); const cForwardedToMousePos = $8000; // <- highest low word bit var mousePos: TPoint; mouseOverWnd: HWnd; begin case Msg.Msg of WM_MOUSEWHEEL: // // Do the forwarding to the window beneath the mouse cursor only once per wheel message! // if Msg.WParam and cForwardedToMousePos <> 0 then inherited WindowProc(Msg) else begin Msg.WParam := Msg.WParam or cForwardedToMousePos; mousePos := SmallPointToPoint(TWMMouse(Msg).Pos); //OutputDebugString(PGMChar(GMFormat('x: %d y: %d', [mousePos.x, mousePos.y]))); mouseOverWnd := WindowFromPoint(mousePos); if (mouseOverWnd = 0) or (mouseOverWnd = FHandle) then inherited WindowProc(Msg) // <- will use the AreaContainingPoint method else with Msg do Result := SendMessage(mouseOverWnd, Msg, WParam, LParam); end; else inherited WindowProc(Msg); end; end; procedure TGMWindow.WMCommand(var Msg: TMessage); begin inherited; if rlmWMCommand in RelayedMessages then //begin //with Msg do Result := SendMessage(LParam, Msg + WM_APP, WParam, LParam); with Msg do Result := GMCallObjWindowProc(GMObjFromWnd(LParam), Msg + WM_APP, WParam, LParam); // FPassMessageToOriginalHandler := False; // <- WM_COMMAND must be passed to ForgWndProc! // otherwise Comboboxes cant dropselect with the mouse //end; end; procedure TGMWindow.WMNotify(var Msg: TMessage); begin inherited; if rlmWMNotify in RelayedMessages then // SendMessage will not reach HintWindow unless subclassing is done by ourself. // This solution seems to be simpler than subclassing. // Should not be a problem since Msg + WM_APP will be understod only by our controls begin //with Msg do Result := SendMessage(PNMHdr(LParam)^.hWndFrom, Msg + WM_APP, WParam, LParam); with Msg do Result := GMCallObjWindowProc(GMObjFromWnd(PNMHdr(LParam)^.hWndFrom), Msg + WM_APP, WParam, LParam); FPassMessageToOriginalHandler := Msg.Result = 0; // dont let ForgWndProc overwrite Msg.Result of TVN_BEGINLABELEDIT and NM_CUSTOMDRAW //FPassMessageToOriginalHandler := (PNMHdr(Msg.LParam)^.code <> -410) and (PNMHdr(Msg.LParam)^.code <> -12) and // (PNMHdr(Msg.LParam)^.code <> -401); end; end; procedure TGMWindow.WMDrawItem(var Msg: TMessage); begin inherited; if rlmWMOwnerDraw in RelayedMessages then begin //with Msg do Result := SendMessage(PDrawItemStruct(LParam)^.hwndItem, Msg + WM_APP, WParam, LParam); with Msg do Result := GMCallObjWindowProc(GMObjFromWnd(PDrawItemStruct(LParam)^.hwndItem), Msg + WM_APP, WParam, LParam); FPassMessageToOriginalHandler := False; // <- dont let ForgWndProc overwrite Msg.Result end; end; procedure TGMWindow.WMHScroll(var Msg: TMessage); begin inherited; if (Msg.LParam <> 0) and (rlmWMScroll in RelayedMessages) then //begin with Msg do Result := GMCallObjWindowProc(GMObjFromWnd(LParam), Msg + WM_APP, WParam, LParam); // FPassMessageToOriginalHandler := False; // <- dont let ForgWndProc overwrite Msg.Result //end; end; procedure TGMWindow.WMVScroll(var Msg: TMessage); begin inherited; if (Msg.LParam <> 0) and (rlmWMScroll in RelayedMessages) then //begin with Msg do Result := GMCallObjWindowProc(GMObjFromWnd(LParam), Msg + WM_APP, WParam, LParam); // FPassMessageToOriginalHandler := False; // <- dont let ForgWndProc overwrite Msg.Result //end; end; procedure TGMWindow.WMNCCalcSize(var Msg: TWMNCCalcSize); begin inherited; // NOTE: Use FFrame member directly here! if (FFrame <> nil) and (Msg.CalcSize_Params <> nil) then with Msg.CalcSize_Params^ do rgrc[0] := FFrame.CalculateClientRect(rgrc[0]); end; procedure TGMWindow.WMHelp(var Msg: TWMHelp); var area: TObject; piArea: IGMUiArea; piParentObj: IGMGetParentObj; begin if Msg.HelpInfo <> nil then try //area := AreaContainingPoint(PPoint(@Msg.HelpInfo.MousePos)^); //if area <> nil then // begin // GMSendObjMessage(area, WM_HELP, 0, PtrInt(Msg.HelpInfo)); // Msg.Result := 1; // end; area := Self; while area <> nil do begin if GMGetInterface(area, IGMUiArea, piArea) and piArea.ProcessHelp(Msg.HelpInfo^) then area := nil; // Break; if GMGetInterface(area, IGMGetParentObj, piParentObj) then area := piParentObj.ParentObj else area := nil; end; except // The WM_HELP message may have been send outside from GMApplicationMassageLoop or GMModalMessageLoop and the // exception handling in GMStdWndProc has been removed because GMModalMessageLoop needs the exceptions to be handled there // so we need exception handling here if the message comes from outside on ex: TObject do vfGMHrExceptionHandler(ex, cDfltPrntWnd); end; FPassMessageToOriginalHandler := False; end; procedure TGMWindow.WMSize(var Msg: TWMSize); begin inherited; case Msg.SizeType of SIZE_RESTORED, SIZE_MAXIMIZED, SIZE_MINIMIZED: begin if not IsLayoutChild then GetWindowRect(FHandle, FLayoutBounds); LayoutContainedAreasIfNeeded(True); end; end; end; procedure TGMWindow.WMMove(var Msg: TWMMove); begin if not IsLayoutChild then GetWindowRect(FHandle, FLayoutBounds); inherited; end; procedure TGMWindow.WMSetCursor(var Msg: TMessage); var Area: TObject; MousePos: TPoint; begin inherited; if WndStyle and WS_DISABLED = 0 then begin // if TempCursor <> 0 then begin SetCursor(TempCursor); Msg.Result := 1; end // else // begin // NOTE: WM_SETCURSOR GMMessages do not contain mouse position information! MousePos := GMScreenToClient(Self, GMMousePosition); Area := AreaContainingPoint(MousePos); if (Area <> nil) and (Area <> Self) then GMCallObjWindowProc(Area, Msg); //if Msg.Result = 0 then DispatchMsg(Msg); FPassMessageToOriginalHandler := Msg.Result = 0; // end; end; end; procedure TGMWindow.UMStartMouseTrack(var Msg: TMessage); var MouseTrack: TTrackMouseEvent; begin // // Mouse entering child windows will cause a WM_MOUSELEAVE in the parent window and stop the parents tracking. // Some window should always be tracked otherwise a mouse leave may be missed. // if not FIsMouseTracking and HandleAllocated then // and not IsLayoutChild begin FillByte(MouseTrack, SizeOf(MouseTrack), 0); MouseTrack.cbSize := SizeOf(MouseTrack); MouseTrack.hwndTrack := Handle; MouseTrack.dwFlags := TME_LEAVE; FIsMouseTracking := TrackMouseEvent(MouseTrack); end; inherited; end; procedure TGMWindow.WMEraseBkgnd(var Msg: TWMEraseBkgnd); begin // Dont pass message to ForgWndProc! And don't fill it with background brush! // Assume that the complete window area will be painted (some of it painted by child areas) // This will reduce drawing flicker Msg.Result := 1; FPassMessageToOriginalHandler := False; end; procedure TGMWindow.WMMouseLeave(var Msg: TMessage); var mouseAreaBefore: TObject; begin FIsMouseTracking := False; inherited; if (vGMMouseInsideArea <> nil) and (vGMMouseInsideArea <> Self) then begin mouseAreaBefore := vGMMouseInsideArea; vGMMouseInsideArea := nil; // <- make mouseAreaBefore.MouseInside return False GMCallObjWindowProc(mouseAreaBefore, UM_MOUSELEAVE, TMessage(Msg).WParam, TMessage(Msg).LParam); end; end; procedure TGMWindow.WMSetFocus(var Msg: TMessage); begin if GMIsParentObj(Self, vGMKeyboardFocusArea, False, TGMWindow) then GMDispatchObjMsg(vGMKeyboardFocusArea, Msg) else inherited; end; procedure TGMWindow.WMKillFocus(var Msg: TMessage); begin if GMIsParentObj(Self, vGMKeyboardFocusArea, False, TGMWindow) then GMDispatchObjMsg(vGMKeyboardFocusArea, Msg) else inherited; end; function TGMWindow.ClientAreaOrigin: TPoint; begin Result := ScrollOffset; // cNullPoint; Result := Windows.GetClientRect.TopLeft; <- ??? end; function TGMWindow.ClientAreaSize: TPoint; var rClient: TRect; begin if not HandleAllocated then Result := inherited ClientAreaSize else begin GetClientRect(Handle, rClient); Result := GMRectSize(rClient); end; end; function TGMWindow.PaintingRect: TRect; begin if not HandleAllocated then begin Result.TopLeft := cNullPoint; Result.BottomRight := ClientAreaSize; end else if not GetClientRect(Handle, Result) then Result := Default(TRect); end; procedure TGMWindow.LanguageChanged(const ANewLanguage: LPARAM); begin Text := GMBuildTextFromResRef(FTextResData, Text); end; function TGMWindow.GetEnabled: Boolean; begin if HandleAllocated then Result := IsWindowEnabled(Handle) else Result := FCreateData.WndStyle and WS_DISABLED = 0; end; procedure TGMWindow.SetEnabled(const AValue: Boolean); stdcall; begin FCreateData.WndStyle := FCreateData.WndStyle and not WS_DISABLED or cWSDisabled[not AValue]; if HandleAllocated then begin EnableWindow(FHandle, AValue); if not AValue and IsTabStop and (vGMKeyboardFocusArea = Self) then GMPostSeletNextDlgTabAreaMsg(Self); end; end; procedure TGMWindow.SetLayoutBounds(const ALayoutBounds: TRect; const ARepaint: Boolean); var rWnd, rWndOld: TRect; hasRgn: Boolean; doRepaint: Boolean; begin //if EqualRect(AValue, FLayoutBounds) then Exit; {ToDo: Skip re-position if not neccessary} // Skipping re-positiovn needs to know if any of the non // windowed parents has changed its surface position. // This cannot be decided by just comparing to old LayoutBounds! //IsRounded := (CornerRounding.x <> 0) and (CornerRounding.y <> 0); // SetWindowPos may generate a WM_SIZE message, re-layouting of contained areas will be done there if HandleAllocated then begin rWnd := CalculateSurfaceRect(ALayoutBounds); if GetWindowRect(FHandle, rWndOld) and EqualRect(rWnd, rWndOld) then Exit; doRepaint := ARepaint and (WndStyle and WS_VISIBLE <> 0); // <- Don't use Visible property here! It may be different to WS_VISIBLE style //GMAPICheckObj(... , Self, 'SetWindowPos'); hasRgn := HasWindowRegion; if hasRgn then SetWindowRgn(Handle, 0, False); SetWindowPos(Handle, 0, rWnd.Left, rWnd.Top, GMRectSize(rWnd).x, GMRectSize(rWnd).y, SWP_NOZORDER or SWP_NOACTIVATE or cWinPosRedraw[doRepaint]); if hasRgn then SetWindowRgn(Handle, CreateRoundRectRgn(0, 0, GMRectSize(rWnd).x+1, GMRectSize(rWnd).y+1, CornerRounding.x, CornerRounding.y), doRepaint); end; if HandleAllocated and not IsLayoutChild then GetWindowRect(FHandle, FLayoutBounds) else FLayoutBounds := ALayoutBounds; end; procedure TGMWindow.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); begin inherited; if not ISLayoutChild then with Msg.MinMaxInfo^, FSizeConstraints do begin if MinWidth > 0 then ptMinTrackSize.x := MinWidth; if MinHeight > 0 then ptMinTrackSize.y := MinHeight; if MaxWidth > 0 then ptMaxTrackSize.x := MaxWidth; if MaxHeight > 0 then ptMaxTrackSize.y := MaxHeight; end; end; procedure TGMWindow.AfterParentChanged; var HWndPrnt: HWnd; begin // // No call to inherited, doesnt need to be propagated in windowed controls // if not HandleAllocated or not GMFindAllocatedParentHandle(Parent, HWndPrnt) then Exit; if HWndPrnt <> GetParent(FHandle) then SetParentWnd(HWndPrnt); end; //procedure TGMWindow.SetParentObj(const AWnd: TObject; const Relayout: Boolean); //var WndPrnt: HWnd; //begin //inherited; //if GMFindAllocatedParentHandle(Parent, WndPrnt) then SetParentWnd(WndPrnt); //end; procedure TGMWindow.SetParentWnd(const AWnd: HWnd); begin if AWnd = ParentWnd then Exit; if HandleAllocated then GMAPICheckObj('Windows.SetParent', '', GetLastError, SetParent(Handle, AWnd) <> 0, Self); FCreateData.ParentWnd := AWnd; end; function TGMWindow.GetWndStyle: DWORD; begin if HandleAllocated then Result := DWORD(GetWindowLong(FHandle, GWL_STYLE)) else Result := FCreateData.WndStyle; end; procedure TGMWindow.SetWndStyle(const AValue: DWORD); const cFrameStyles = WS_CAPTION or WS_BORDER or WS_DLGFRAME or WS_VSCROLL or WS_HSCROLL or WS_THICKFRAME; var oldWndStyle: DWORD; begin oldWndStyle := WndStyle; if AValue = oldWndStyle then Exit; if HandleAllocated then begin SetWindowLong(FHandle, GWL_STYLE, LongInt(AValue)); // If frame styles have been changed windows requires a SetWindowPos call to reflect the changes if AValue and cFrameStyles <> oldWndStyle and cFrameStyles then SetWindowPos(FHandle, 0,0,0,0,0, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_FRAMECHANGED); end; FCreateData.WndStyle := AValue; end; function TGMWindow.GetWndExStyle: DWORD; begin if HandleAllocated then Result := DWORD(GetWindowLong(Handle, GWL_EXSTYLE)) else Result := FCreateData.WndExStyle; end; procedure TGMWindow.SetWndExStyle(const AValue: DWORD); const cFrameExStyles = WS_EX_CLIENTEDGE or WS_EX_DLGMODALFRAME or WS_EX_STATICEDGE or WS_EX_TOOLWINDOW; var OldWndExStyle: DWORD; begin OldWndExStyle := WndExStyle; if AValue = OldWndExStyle then Exit; if HandleAllocated then begin SetWindowLong(FHandle, GWL_EXSTYLE, LongInt(AValue)); // If frame styles have been changed windows requires a SetWindowPos call to reflect the changes if AValue and cFrameExStyles <> OldWndExStyle and cFrameExStyles then SetWindowPos(FHandle, 0,0,0,0,0, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_FRAMECHANGED); end; FCreateData.WndExStyle := AValue; end; function TGMWindow.GetText: TGMString; stdcall; begin if not HandleAllocated then Result := FCreateData.Text else begin SetLength(Result, SendMessage(FHandle, WM_GETTEXTLENGTH, 0, 0)); // length 0 gives access violation on XP when started without manifest if Length(Result) > 0 then SendMessage(FHandle, WM_GETTEXT, Length(Result) + 1, LPARAM(PGMChar(Result))); //Assert(SendMessage(Handle, WM_GETTEXT, Length(Result) + 1, LPARAM(PGMChar(Result))) = Length(Result)); end; end; procedure TGMWindow.SetText(const AValue: TGMString); stdcall; begin if AValue = Text then Exit; if HandleAllocated then SendMessage(FHandle, WM_SETTEXT, 0, LPARAM(PGMChar(AValue))) //; //SetWindowText(Handle, PGMChar(AValue)); else FCreateData.Text := AValue; end; function TGMWindow.IsLayoutChild: Boolean; var _style: DWORD; begin _style := WndStyle; Result := (_style and WS_CHILD <> 0) and (_style and WS_POPUP = 0); end; function TGMWindow.IsTabStop: Boolean; begin Result := WndStyle and WS_TABSTOP <> 0; end; procedure TGMWindow.InternalSetVisible(const AValue: Boolean{; const Relayout: Boolean}); begin if AValue <> (WndStyle and WS_VISIBLE <> 0) then if HandleAllocated then ShowWindow(Handle, cSWShow[AValue]) else if AValue then WndStyle := WndStyle or WS_VISIBLE else WndStyle := WndStyle and not WS_VISIBLE; end; procedure TGMWindow.SetShowing(const AValue: Boolean); begin if Visible then InternalSetVisible(AValue); end; procedure TGMWindow.WMNCPaint(var Msg: TMessage); var dc: HDC; rBounds: TRect; areaRgn: IGMGetHandle; begin inherited; // NOTE: Use FFrame member directly here! //if GMEqualPoints(GMFrameExtent(FFrame), cNullPoint) then Exit; // <- matched if Frame returns nil! if not IsFramed then Exit; if Msg.LParam = 0 then dc := GetWindowDC(FHandle) else dc := HDC(Msg.LParam); if dc = 0 then Exit; try GetWindowRect(FHandle, rBounds); rBounds := GMMoveRect(rBounds, -rBounds.Left, -rBounds.Top); areaRgn := CreateAreaRegion(rBounds, arkBounds); FFrame.DrawFrame(Self, dc, areaRgn.Handle, FrameColor); finally if Msg.LParam = 0 then ReleaseDC(FHandle, dc); end; end; procedure TGMWindow.ScheduleRepaint; begin if HandleAllocated and Visible then InvalidateRect(Handle, nil, False); end; //procedure TGMWindow.PaintFrame(const ADC: HDC; const ARegion: IGMGetHandle); // : IGMGetHandle; //begin // // Nothing, windowed areas paint their frames via WM_NCPaint message // //Result := ARegion; //end; procedure TGMWindow.WMPaint(var Msg: TWMPaint); var dc: HDC; ps: TPaintStruct; begin try // // There will be no painting possible after EndPaint. Whoever gets the ADC first must pass it on. // Handlers must be prepared for ADC = 0. Chained Handlers must be called before EndPaint. // ps := Default(TPaintStruct); dc := Msg.DC; if dc = 0 then begin dc := BeginPaint(Handle, ps); GMAPICheckObj('BeginPaint', '', GetLastError, dc <> 0, Self); end; try //inherited; //if not ps.fErase then if not Paint(dc) and (FOrgWndProc <> nil) then Msg.Result := CallWindowProc(FOrgWndProc, FHandle, Msg.Msg, WPARAM(dc), 0); finally if Msg.DC = 0 then EndPaint(Handle, ps); Msg.Result := 0; // <- we handled it end; except // Never raise exceptions while painting! on ex: TObject do GMTraceException(ex); //GMTraceException(GMExceptObject); end; FPassMessageToOriginalHandler := False; // <- dont call FOrgWndProc in WindowProc after EndPaint end; //procedure TGMWindow.WMPrint(var Msg: TMessage); //var Msg2: TMessage; R: TRect; //begin // inherited; // if Msg.WParam = 0 then Exit; // // if (Msg.LParam and PRF_ERASEBKGND <> 0) and FillsComplete then // begin // GetWindowRect(FHandle, R); // <- ClientRect would not fill frame area! // FillRect(HDC(Msg.WParam), GMMoveRect(R, -R.Left, -R.Top), HBkgndBrush); // end; // // if Msg.LParam and PRF_NONCLIENT <> 0 then // begin // Msg2 := GMMessageRec(0, 0, Msg.WParam, 0); // WMNCPaint(Msg2); // end; //end; procedure TGMWindow.WMPrintClient(var Msg: TMessage); var wndRect: TRect; msg2: TMessage; begin if Msg.WParam = 0 then Exit; if (Msg.LParam and PRF_ERASEBKGND <> 0) then // and FillsComplete begin GetWindowRect(FHandle, wndRect); // <- ClientRect would not fill frame area! FillRect(HDC(Msg.WParam), GMMoveRect(wndRect, -wndRect.Left, -wndRect.Top), HBkgndBrush); FPassMessageToOriginalHandler := False; end; if Msg.LParam and PRF_CLIENT <> 0 then begin Paint(HDC(Msg.WParam)); // // The device context passed by the system does not support clipping by regions and causes some // other artefacts. So we paint to a Bitmap first and then copy the Result onto the original DC. // //ClientSz := ClientAreaSize; // GMRectSize(PaintingRect); // ; //ClientDC := TGMGdiCompatibleDC.Create(0, HDC(Msg.WParam)); //ClientBmp := TGMGdiBitmap.CreateCompatibleBmp(ClientDC.Handle, 0, ClientSz, True); ////ClientBmp := TGMGdiBitmap.CreateFromData(ClientDC.Handle, ClientSz.x, ClientSz.y, 1, 32, nil, True); //Paint(ClientDC.Handle); //BitBlt(HDC(Msg.WParam), 0, 0, ClientSz.x, ClientSz.y, ClientDC.Handle, 0, 0, SRCCOPY); FPassMessageToOriginalHandler := False; end; if Msg.LParam and PRF_NONCLIENT <> 0 then begin msg2 := GMMessageRec(Msg.Msg, 0, Msg.WParam, 0); WMNCPaint(msg2); FPassMessageToOriginalHandler := False; end; end; { ----------------------- } { ---- TGMWinControl ---- } { ----------------------- } constructor TGMWinControl.Create(const AParent: TGMWndObj; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const AText: TGMString; const AWndStyle: DWORD; const AWndExStyle: DWORD; const ABkgndColor: COLORREF; const ARefLifeTime: Boolean); const cWSChild: array [Boolean] of DWORD = (0, WS_CHILD); var CtlId: LongInt; begin // // inherited constructor will set FVisible := AWndStyle and WS_VISIBLE <> 0 // if AWndStyle and WS_POPUP = 0 then CtlId := GMNextCtrlID else CtlId := 0; {inherited} Create(AParent, APosition, AAreaAlign, (AWndStyle and not WS_CHILD) or cWSChild[(AParent <> 0) {and (AWndStyle and WS_POPUP = 0)}] {or WS_CLIPCHILDREN or WS_CLIPSIBLINGS}, AWndExStyle, AText, CtlId, ABkgndColor, ARefLifeTime); end; procedure TGMWinControl.CreateParentHandle; var PIParent: IGMGetParentObj; PrntObj: TObject; PIArea: IGMUiArea; begin inherited CreateParentHandle; // // Remove WS_VISIBLE from our window creation flags if one of our direkt // parents is an invisible windowless Area. // if (FCreateData.WndStyle and WS_VISIBLE <> 0) then begin PrntObj := Parent; while (PrntObj <> nil) and not GMAreaHasWndHandle(PrntObj) and PrntObj.GetInterface(IGMUiArea, PIArea) do begin if not PIArea.Visible then begin FCreateData.WndStyle := FCreateData.WndStyle and not WS_VISIBLE; Break; end; if not PrntObj.GetInterface(IGMGetParentObj, PIParent) then Break; PrntObj := PIParent.ParentObj; end; end; end; function TGMWinControl.IsPopupWindow: Boolean; begin Result := WndStyle and WS_POPUP <> 0; end; function TGMWinControl.ClosePopupState(const RestoreActiveCtrl: Boolean): Boolean; var Dlg: TObject; begin Result := IsPopupWindow; // WndStyle and WS_POPUP <> 0; if not Result then Exit; //GMShowWindowAnimated(FHandle, False); //ShowWindow(Handle, SW_HIDE); GMAnimateWindow(FHandle, vGMPopupAniDuration, AW_BLEND or AW_HIDE); //GMReleaseMouseCapture; vGMPopupArea := nil; if RestoreActiveCtrl and GMFindParentDlg(Parent, Dlg) then SetActiveWindow(GMHWndFromWndObj(-Int64(Dlg))); //GMPostObjMessage(Dlg, WM_ACTIVATE, WA_ACTIVE, 0); end; procedure TGMWinControl.WMKeyDown(var Msg: TWMKeyDown); begin inherited; if (Msg.CharCode = VK_ESCAPE) and (GMKeyDataToKeyState(Msg.KeyData) = []) then FPassMessageToOriginalHandler := not ClosePopupState(True); end; //function TGMWinControl.IsDialogKeyMsg(const Msg: TMessage): Boolean; //begin ////Result := //(((Msg.Msg = WM_SYSKEYDOWN) or (Msg.Msg = WM_SYSKEYUP) or (Msg.Msg = WM_SYSCHAR) or (Msg.Msg = WM_SYSDEADCHAR)) or //// ((Msg.Msg = WM_KEYDOWN) or (Msg.Msg = WM_KEYUP) or (Msg.Msg = WM_CHAR)) and //// (((Msg.WParamLo in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) and (GMCallObjWindowProc(Self, WM_GETDLGCODE) and DLGC_WANTARROWS = 0)) or //// ((Msg.WParamLo = VK_TAB) and (GMCallObjWindowProc(Self, WM_GETDLGCODE) and DLGC_WANTTAB = 0)) or //// ((Msg.WParamLo = VK_RETURN) and (GMCallObjWindowProc(Self, WM_GETDLGCODE) and DLGC_WANTALLKEYS = 0)) or //// ((Msg.WParamLo = VK_ESCAPE) and not IsPopupWindow)); // //Result := //(((Msg.Msg = WM_SYSKEYDOWN) or (Msg.Msg = WM_SYSKEYUP) or (Msg.Msg = WM_SYSCHAR) or (Msg.Msg = WM_SYSDEADCHAR)) or // ((Msg.Msg = WM_KEYDOWN) or (Msg.Msg = WM_KEYUP) or (Msg.Msg = WM_CHAR)) and // (((Msg.WParamLo in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) and (SendMessage(FHandle, WM_GETDLGCODE, 0, 0) and DLGC_WANTARROWS = 0)) or // ((Msg.WParamLo = VK_TAB) and (SendMessage(FHandle, WM_GETDLGCODE, 0, 0) and DLGC_WANTTAB = 0)) or // ((Msg.WParamLo = VK_RETURN) and (SendMessage(FHandle, WM_GETDLGCODE, 0, 0) and DLGC_WANTALLKEYS = 0)) or // ((Msg.WParamLo = VK_ESCAPE) and not IsPopupWindow)); //end; //procedure TGMWinControl.WMMouseActivate(var Msg: TWMMouseActivate); //begin //inherited; ////if IsPopupWindow then begin Msg.Result := MA_NOACTIVATE; FPassMessageToOriginalHandler := False; end; //// //// Controls are supposed to never activate themself //// ////Msg.Result := MA_NOACTIVATE; FPassMessageToOriginalHandler := False; //end; procedure TGMWinControl.WMCancelMode(var Msg: TWMCancelMode); begin // // If a Control becomes disabled then set focus to some other control // inherited; // (FHandle = GetFocus) if not ClosePopupState and (vGMKeyboardFocusArea = Self) then GMPostSeletNextDlgTabAreaMsg(Self); // FFocusNextControl := True; end; procedure TGMWinControl.SurfaceOriginChanged; var R: TRect; begin inherited; // // When a parent window is scrolled using SW_SCROLLCHILDREN only the window bits are scrolled. // But the positions of contained child windows remain unchanged. // if HandleAllocated then begin R := CalculateSurfaceRect(LayoutBounds); with R do SetWindowPos(FHandle, 0, Left, Top, 0, 0, SWP_NOSIZE or SWP_NOZORDER or SWP_NOACTIVATE); //ScheduleRepaint; end; end; //procedure TGMWinControl.WMEnable(var Msg: TWMEnable); ////var dlgWnd: HWnd; //begin //try // if not Msg.Enabled and FFocusNextControl then // <- FFocusNextControl has been set before in WMCancelMode // begin // GMPostSeletNextDlgTabAreaMsg(Self); //// dlgWnd := GMDlgRootWindow(FHandle); //// if GMIsWindow(dlgWnd) then PostMessage(dlgWnd, UM_SELECTNEXTDLGTABAREA, 0, 0); // end; //finally // FFocusNextControl := False; //end; //inherited; //end; { ----------------------- } { ---- TGMOEMControl ---- } { ----------------------- } procedure TGMOEMControl.WindowProc(var Msg: TMessage); begin case Msg.Msg of // Dont delegate this to contained controls, they probably are not // subclassed and wont understand WM_XXX + WM_APP GMMessages! WM_CTLCOLOR, WM_CTLCOLORMSGBOX .. WM_CTLCOLORSTATIC: AssignCtrlColorValues(Msg); //WM_CTLCOLOR + WM_APP, WM_CTLCOLORMSGBOX + WM_APP .. WM_CTLCOLORSTATIC + WM_APP: AssignCtrlColorValues(Msg); else inherited WindowProc(Msg); end; end; procedure TGMOEMControl.UMStartMouseTrack(var Msg: TMessage); begin // Nothing (no call to inherited)! Leaves FPassMessageToOriginalHandler True -> will be handled only by FOrgWndProc end; procedure TGMOEMControl.WMEraseBkgnd(var Msg: TWMEraseBkgnd); begin // Nothing (no call to inherited)! Leaves FPassMessageToOriginalHandler True -> will be handled only by FOrgWndProc //FillRect(Msg.DC, PaintingRect, HBkgndBrush); end; procedure TGMOEMControl.WMMouseLeave(var Msg: TMessage); begin // Nothing (no call to inherited)! Leaves FPassMessageToOriginalHandler True -> will be handled only by FOrgWndProc end; procedure TGMOEMControl.WMLButtonDown(var Msg: TWMLButtonDown); begin // Nothing (no call to inherited)! Leaves FPassMessageToOriginalHandler True -> will be handled only by FOrgWndProc end; //procedure TGMOEMControl.WMMouseActivate(var Msg: TWMMouseActivate); //begin // // Nothing (no call to inherited)! Leaves FPassMessageToOriginalHandler True -> will be handled only by FOrgWndProc //end; procedure TGMOEMControl.WMPaint(var Msg: TWMPaint); begin // Nothing (no call to inherited)! Leaves FPassMessageToOriginalHandler True -> will be handled only by FOrgWndProc end; //procedure TGMOEMControl.WMPrint(var Msg: TMessage); //begin // // Nothing (no call to inherited)! Leaves FPassMessageToOriginalHandler True -> will be handled only by FOrgWndProc //end; procedure TGMOEMControl.WMPrintClient(var Msg: TMessage); begin // Nothing (no call to inherited)! Leaves FPassMessageToOriginalHandler True -> will be handled only by FOrgWndProc end; procedure TGMOEMControl.WMNCCalcSize(var Msg: TWMNCCalcSize); begin // If we assigned a frame of ours we need to handle this! inherited; //if IsFramed then begin inherited; {FPassMessageToOriginalHandler := False;} end; // Otherwise FPassMessageToOriginalHandler stays True -> will be handled only by FOrgWndProc end; procedure TGMOEMControl.WMNCPaint(var Msg: TMessage); begin // If we assigned a frame of ours we need to handle this! inherited; //if IsFramed then begin inherited; {FPassMessageToOriginalHandler := False;} end; // Otherwise FPassMessageToOriginalHandler stays True -> will be handled only by FOrgWndProc end; { ------------------------------- } { ---- TGMForeignWinCtrlImpl ---- } { ------------------------------- } {function TGMForeignWinCtrlImpl.CalculateHeight(const ANewSize: TPoint): LongInt; begin Result := GMCalcBoundingHeight(Self, ANewSize); end; function TGMForeignWinCtrlImpl.CalculateWidth(const ANewSize: TPoint): LongInt; begin Result := GMCalcBoundingWidth(Self, ANewSize); end;} procedure TGMForeignWinCtrlImpl.UMCalcHeight(var Msg: TMessage); begin //Msg.Result := CalculateHeight(Point(Msg.WParam, Msg.LParam)); Msg.Result := GMCalcBoundingHeight(Self, GMPoint(Msg.WParam, Msg.LParam)); FPassMessageToOriginalHandler := False; // <- Default handler would set Result to 0 end; procedure TGMForeignWinCtrlImpl.UMCalcWidth(var Msg: TMessage); begin //Msg.Result := CalculateWidth(Point(Msg.WParam, Msg.LParam)); Msg.Result := GMCalcBoundingWidth(Self, GMPoint(Msg.WParam, Msg.LParam)); FPassMessageToOriginalHandler := False; // <- Default handler would set Result to 0 end; { ------------------------- } { ---- TGMNCWinControl ---- } { ------------------------- } procedure TGMNCWinControl.UMHandleCreated(var Msg: TMessage); var style: DWORD; begin //inherited; style := WndStyle; if (style and WS_VISIBLE <> 0) and ((WndExStyle and WS_EX_CLIENTEDGE <> 0) or (style and (WS_VSCROLL or WS_HSCROLL) <> 0)) then FinalizeShow; FPassMessageToOriginalHandler := False; end; procedure TGMNCWinControl.FinalizeShow; begin GMPaintWndFrame(-Int64(Self)); //GMHideAndShowWnd(-Int64(Self)); ScheduleRepaint; end; { ---------------------- } { ---- TGMDlgWindow ---- } { ---------------------- } constructor TGMDlgWindow.Create(const APosition: TRect; const AWndStyle: DWORD; const AWndExStyle: DWORD; const ATitle: TGMString; const AParent: TGMWndObj; const ADlgData: Pointer; const AMenu: HMENU; const ABkgndColor: COLORREF; const ARefLifeTime: Boolean); var style_: DWORD; // tmp: DWORD; //const cPopup: array [Boolean] of DWORD = (0, WS_POPUP); begin FDlgData := ADlgData; // If a dialog has a parent then WS_POPUP is needed for correct Z-Order handling. // If a dialog has no parent then WS_POPUP prevents dialog from coming to front. //tmp := not (LongInt(WS_CHILD) or LongInt(WS_POPUP)); // xor $ffffffff; //tmp := (WS_CHILD or WS_POPUP) xor $ffffffff; // Clear WS_CHILD and WS_POPUP bits in AWndStyle // use a XOR against $ffffffff instead a NOT to avoid compiler warning! style_ := (AWndStyle and ((WS_CHILD or WS_POPUP) xor $ffffffff)); // or cPopup[AParent <> 0] //style_ := (AWndStyle and not (WS_CHILD or WS_POPUP)) or cPopup[AParent <> 0]; //inherited Create(AParent, APosition, cFixedPlace, style_, AWndExStyle or WS_EX_CONTROLPARENT, ATitle, AMenu, ABkgndColor, ARefLifeTime); end; function TGMDlgWindow.RegisterWndClass: TGMString; var icon: HICON; begin icon := 0; if GMIsWindow(FCreateData.ParentWnd) then icon := GetClassLongPtr(FCreateData.ParentWnd, GCL_HICON); // GCL_HICONSM if icon = 0 then icon := GMFindFirstIcon(GMIconInstance); Result := GMRegisterWindowClass(WndClassRegName, CursorHandle, CS_DBLCLKS, icon, HBkgndBrush).Name; end; //procedure TGMDlgWindow.CreateParentHandle; //const cPopup: array [Boolean] of DWORD = (0, WS_POPUP); //begin //// If a dialog has a parent then WS_POPUP is needed for correct Z-Order handling. //// If a dialog doesnt has a parent then WS_POPUP prevents dialog from coming to front. //inherited CreateParentHandle; //FCreateData.ParentWnd := GMModalDlgParentWnd(FCreateData.ParentWnd); //FCreateData.WndStyle := (FCreateData.WndStyle and not WS_POPUP) or cPopup[FCreateData.ParentWnd <> 0]; //end; procedure TGMDlgWindow.SetBkgndColor(const Value: COLORREF; const ARepaint: Boolean); var BkColor: COLORREF; begin {ToDo: Create Brush for background color that are no system colors} if Value = BkgndColor then Exit; inherited SetBkgndColor(Value, ARepaint); if HandleAllocated then begin if GMIsSysColor(BkgndColor) then BkColor := GMSysColor(BkgndColor) + 1 else BkColor := 0; SetClassLong(Handle, GCL_HBRBACKGROUND, LongInt(BkColor)); end; end; //function TGMDlgWindow.TempCursor: HCURSOR; //begin //Result := FTempCursor; //end; //procedure TGMDlgWindow.WMPrint(var Msg: TMessage); //var R: TRect; CachedDC, DCBmp: IGMGetHandle; DCOrg: WPARAM; BmpSz: TPoint; //begin //if Msg.WParam = 0 then Exit; //GetWindowRect(FHandle, R); // <- ClientRect would not fill frame area! //BmpSz := GMRectSize(R); // //CachedDC := TGMGdiCompatibleDC.Create; // (0, HDC(Msg.WParam)); //DCBmp := TGMGdiBitmap.CreateCompatibleBmp(CachedDC.Handle, 0, BmpSz, True); // //DCOrg := Msg.WParam; //Msg.WParam := WPARAM(CachedDC.Handle); // //inherited; //if FOrgWndProc <> nil then // Msg.Result := CallWindowProc(FOrgWndProc, FHandle, Msg.Msg, Msg.WParam, Msg.LParam); // //Msg.WParam := DCOrg; //BitBlt(HDC(Msg.WParam), 0, 0, BmpSz.x, BmpSz.y, CachedDC.Handle, 0, 0, SRCCOPY); //FPassMessageToOriginalHandler := False; //end; //procedure TGMDlgWindow.WMEraseBkgnd(var Msg: TWMEraseBkgnd); //begin // // Dont pass message to ForgWndProc! // // Assume that the complete dialog area is covered by painted child areas, and don't fill it with background brush // // This will prevent drawing flicker // Msg.Result := 1; // FPassMessageToOriginalHandler := False; //end; function TGMDlgWindow.CanClose(const ASetData: Boolean): Boolean; begin Result := True; end; function TGMDlgWindow.IsDialogKeyMsg(const Msg: TMessage): Boolean; begin Result := False; // <- We are the Dialog, no further redirection! end; function TGMDlgWindow.IsModalDialog: Boolean; begin Result := FHandle = vGMModalWnd; //Result := FIsModalDialog; end; function TGMDlgWindow.CloseOnEscape: Boolean; begin Result := IsModalDialog; end; //procedure TGMDlgWindow.UMSetTempCursor(var Msg: TMessage); //begin //Msg.Result := LongInt(FTempCursor); //if HCursor(Msg.WParam) <> INVALID_HANDLE_VALUE then FTempCursor := HCursor(Msg.WParam); //FPassMessageToOriginalHandler := False; // <- dont let FOrgWndProc overwrite Msg.Result //end; function NotifyAreaLanguageChanged(const AArea: TObject; const AData: Pointer): Boolean; var langChanged: IGMLanguageChanged; begin Result := True; if GMGetInterface(AArea, IGMLanguageChanged, langChanged) then langChanged.LanguageChanged(LPARAM(AData)); end; procedure TGMDlgWindow.UMLanguageChanged(var Msg: TMessage); begin inherited; FPassMessageToOriginalHandler := False; GMVisitAllChildAreas(Self, NotifyAreaLanguageChanged, [], True, Pointer(Msg.LParam)); NotifyAreaLanguageChanged(Self, Pointer(Msg.LParam)); GMReLayoutContainedAreas(Self, True, True); end; procedure TGMDlgWindow.WMSetFocus(var Msg: TWMSetFocus); begin if ActiveControl = nil then inherited else begin if GMIsParentObj(Self, ActiveControl) then GMSetFocus(ActiveControl) else inherited; ActiveControl := nil; // <- use ActiveControl only once end; end; //procedure TGMDlgWindow.WMNCActivate(var Msg: TWMNCActivate); //begin //if not Msg.Active then // begin // if GMIsParentObj(Self, vGMKeyboardFocusArea, True) then begin ActiveControl := vGMKeyboardFocusArea; end; // vGMKeyboardFocusArea := nil; // if vGMPopupArea <> nil then GMCancelPopup; // end; //end; procedure TGMDlgWindow.WMActivate(var Msg: TWMActivate); ///var Wnd: HWnd; begin case Msg.Active of // WA_CLICKACTIVE inerferes when activating a special control after a popup closed //WA_ACTIVE, WA_CLICKACTIVE: GMSetFocus(ActiveControl); // PostMessage(FHandle, UM_SETACTIVECTRL, 0, 0); WA_INACTIVE: begin if GMIsParentObj(Self, vGMKeyboardFocusArea, True) then begin ActiveControl := vGMKeyboardFocusArea; end; // vGMKeyboardFocusArea := nil; if vGMPopupArea <> nil then GMPostObjMessage(vGMPopupArea, WM_CANCELMODE); //GMCancelPopup; end; end; end; //function WindowEnumToArrayFunc(wnd: HWnd; param: LPARAM): BOOL; stdcall; ////var Handles: PGMPtrIntArray; Title: TGMString; //var dlg: TGMDlgWindow; // WndClass, Title: TGMString; //begin // Result := True; // <- continue iteration // if param = 0 then Exit; // //Handles := PGMPtrIntArray(param); // dlg := TGMDlgWindow(param); // wnd := GMDlgRootWindow(wnd); // // //SetLength(WndClass, 255); // //SetLength(WndClass, GetClassName(wnd, PGMChar(WndClass), Length(WndClass))); // //if CompareText(WndClass, 'tooltips_class32') = 0 then Exit; // // //SetLength(Title, 255); // //SetLength(Title, GetWindowText(wnd, PGMChar(Title), Length(Title))); // // if IsWindow(wnd) and IsWindowEnabled(wnd) and (wnd <> dlg.FHandle) and (GetWindowLong(wnd, GWL_STYLE) and WS_VISIBLE <> 0) and // not GMIsOneOfIntegers(PtrInt(wnd), dlg.FModalDisabledWindows) and (wnd <> GetDesktopWindow) then // GMAddIntegersToArray(dlg.FModalDisabledWindows, [PtrInt(wnd)]); //end; // //procedure TGMDlgWindow.UMDisableModalDlgParent(var Msg: TMessage); //var i: LongInt; //begin // //FIsModalDialog := True; // // //if not GMIsWindow(ParentWnd) then Exit; // //FParentWasEnabled := IsWindowEnabled(ParentWnd); // //if {IsModalDialog and} FParentWasEnabled then EnableWindow(ParentWnd, False); // SetLength(FModalDisabledWindows, 0); // EnumThreadWindows(GetCurrentThreadID, {$IFNDEF JEDIAPI}@{$ENDIF}WindowEnumToArrayFunc, LPARAM(Self)); // if GetCurrentThreadID <> gGMMainThreadID then EnumThreadWindows(gGMMainThreadID, {$IFNDEF JEDIAPI}@{$ENDIF}WindowEnumToArrayFunc, LPARAM(Self)); // for i:=Low(FModalDisabledWindows) to High(FModalDisabledWindows) do EnableWindow(HWnd(FModalDisabledWindows[i]), False); //end; // //procedure TGMDlgWindow.ReEnableOtherWindows; //var wnd: PtrInt; //begin // for wnd in FModalDisabledWindows do EnableWindow(HWnd(wnd), True); // SetLength(FModalDisabledWindows, 0); //end; //procedure TGMDlgWindow.InternalCreateHandle; //begin // inherited InternalCreateHandle; // SetParent(FHandle, 0); //end; //procedure TGMDlgWindow.WMDestroy(var Msg: TMessage); //begin // // // // If we are a modal window that is directly destroyed by other means than closing it normally, we must re-enable the // // windows we disabled before and realease the modal message loop! // // // ReEnableOtherWindows; // //if IsModalDialog then PostMessage(0, UM_DONEMODAL, IDCANCEL, FHandle); // <- Release (Exit) the modal message loop // //end; // inherited; //end; procedure TGMDlgWindow.WMClose(var Msg: TMessage); var doClose: Boolean; begin inherited; // // Don't call CanClose for modal dialogs, it will have been already called by the ModalMessageLoop! // CanClose may raise an exception to prevent from closing! // doClose := IsModalDialog or CanClose(Msg.WParam = IDOK); // // Delegating WM_CLOSE to UM_CLOSE offers the opportunity to simply disable // the close button and wait for something else to finish before closing. // // Better use SendMessage here. If changed to PostMessage check // GMWndStackCloseAll and GMCloseAllThreadWindows for semantic changes // //Msg.Result := SendMessage(FHandle, UM_CLOSE, Msg.WParam, Msg.LParam); try if (vGMPopupArea <> nil) and GMIsParentObj(Self, vGMPopupArea) then GMCancelPopup; DoneDialog(Msg.WParam = IDOK); except on ex: TObject do vfGMHrExceptionHandler(ex, FHandle); end; if doClose then GMShowWindowAnimated(FHandle, swHide); FPassMessageToOriginalHandler := doClose; // <- FOrgWndProc will destroy the window! end; //procedure TGMDlgWindow.UMClose(var Msg: TMessage); //begin // inherited; // FPassMessageToOriginalHandler := False; // <- default handler would set Msg.Result to 0 // if not CanClose(Msg.WParam = IDOK) then begin Msg.Result := cCannotClose; Exit; end; // <- NOTE: May Exit here! // try // // TGMMainWindow: Terminate procs have been called in CanClose! Always quit application now! // try // if (vGMPopupArea <> nil) and GMIsParentObj(Self, vGMPopupArea) then GMCancelPopup; // DoneDialog(Msg.WParam = IDOK); // except // on ex: TObject do vfGMHrExceptionHandler(ex, cDfltPrntWnd); // //vfGMHrExceptionHandler(GMExceptObject, FHandle); // end; // finally // // Re-enable parent before destroying our handle, otherwise parent will miss becoming active window again // // See remarks of EnableWindow in MSDN! // //ReEnableOtherWindows; // GMShowWindowAnimated(FHandle, swHide); // //if IsModalDialog then PostMessage(0, UM_DONEMODAL, Msg.WParam, FHandle); // <- Release (Exit) the modal message loop, and Post closing reason // //Msg.Result := Msg.WParam; // <- tell closing reason as message Result too // DestroyHandle(True); // end; //end; procedure TGMDlgWindow.UMSelectNextDlgTabArea(var Msg: TMessage); var nextArea: TObject; begin //if not GMIsParentObj(Self, vGMKeyboardFocusArea) then Exit; nextArea := GMFindNextDlgTabAreaByUIPosition(Self, vGMKeyboardFocusArea, Msg.LParam = cTrueInt); if nextArea <> nil then GMSetFocus(nextArea); end; procedure TGMDlgWindow.WMSysKeyDown(var Msg: TWMSysKeyDown); begin inherited; GMSendObjMessage(self, WM_CHANGEUISTATE, MakeLong(UIS_CLEAR, UISF_HIDEACCEL)); // <- show underlines for button shortcuts end; procedure TGMDlgWindow.WMKeyDown(var Msg: TWMKeyDown); var keyState: SGMKeyStates; reverse: Boolean; defaultCtrl: IGMIsDefaultDlgBtn; // Ctl: HWnd; CtlClassName: TGMString; begin // Cannot use DefDlgProc, it is designed for the very limited MS CreateDialog things. // Anyway there is not very much magic about dialog behaviour. inherited; keyState := GMKeyDataToKeyState(Msg.KeyData); case Msg.CharCode of VK_TAB, VK_LEFT, VK_UP, VK_RIGHT, VK_DOWN: if (keyState = []) or (keyState = [ksShift]) then begin case Msg.CharCode of VK_TAB: reverse := GetKeyState(VK_SHIFT) < 0; VK_LEFT, VK_UP: reverse := True; else reverse := False; end; GMSendObjMessage(Self, WM_CHANGEUISTATE, MakeLong(UIS_CLEAR, UISF_HIDEFOCUS)); // <- show focus rectangle SendMessage(FHandle, UM_SELECTNEXTDLGTABAREA, 0, cBoolInt[reverse]); end; VK_ESCAPE: if (keyState = []) and CloseOnEscape and CanClose(False) then GMPostObjMessage(Self, WM_CLOSE, IDCANCEL); VK_RETURN: if (keyState = []) and GMFindDfltDlgCtrl(Self, defaultCtrl) then defaultCtrl.Click; end; end; procedure TGMDlgWindow.CreateHandle; begin // // Overriding InternalCreateHandle for this would not allocate child windows first. // Could be solved by placing a inherited CreateHandle Call in TGMWindow.InternalCreateHandle but // mixing Create and InernalCreate probably is not a good idea (-> hard to understand). // if HandleAllocated then inherited CreateHandle else begin inherited CreateHandle; InitControls; GetDlgData; SetupControls; end; end; procedure TGMDlgWindow.InitControls; begin // Nothing! end; procedure TGMDlgWindow.GetDlgData; begin // Nothing! end; procedure TGMDlgWindow.SetupControls; begin // Nothing! end; procedure TGMDlgWindow.DoneDialog(const ASetData: Boolean); begin // Nothing! end; { ----------------------------- } { ---- TGMStackedDlgWindow ---- } { ----------------------------- } procedure TGMStackedDlgWindow.InternalCreateHandle; begin inherited; GMPushModalDlgWnd(Handle); end; procedure TGMStackedDlgWindow.WMNCDestroy(var Msg: TWMNCDestroy); begin inherited; GMPopModalDlgWnd; end; //procedure TGMStackedDlgWindow.WMNCDestroy(var Msg: TWMNCDestroy); //begin // //end; // //procedure TGMStackedDlgWindow.InternalCreateHandle; //begin // inherited InternalCreateHandle; //end; { ----------------------- } { ---- TGMMainWindow ---- } { ----------------------- } constructor TGMMainWindow.Create(const APosition: TRect; const AWndStyle: DWORD; const AWndExStyle: DWORD; const ATitle: TGMString; const AParent: TGMWndObj; const ADlgData: Pointer; const AMenu: HMENU; const ABkgndColor: COLORREF; const ARefLifeTime: Boolean); begin // WS_EX_APPWINDOW style makes an owned window appear on the task bar (by default only unowned windows appear on the task bar) inherited Create(APosition, AWndStyle, AWndExStyle or WS_EX_APPWINDOW, ATitle, AParent, ADlgData, AMenu, ABkgndColor, ARefLifeTime); end; function TGMMainWindow.CanClose(const ASetData: Boolean): Boolean; begin {ToDo: Ask other opened dialog windows via for canclose here} // (GMWinCoreMsgBox('Close?', svConfirmation, FHandle, mb_YesNo) = IDYes) and Result := inherited CanClose(ASetData) and CallTerminateProcs; if Result then GMCloseAllThreadWindows(FHandle); // <- close non-modal windows end; procedure TGMMainWindow.WMNCDestroy(var Msg: TWMNCDestroy); begin inherited; // terminate procs have been called before! PostQuitMessage(0); // <- closing main window terminates application message loop end; procedure TGMMainWindow.WMQueryEndSession(var Msg: TMessage); //const cExit: array [Boolean] of LongInt = (0, 1); begin inherited; ExitCode := GMWndStackCloseAll(0, IDABORT); // <- closes our window too //Msg.Result := cExit[ExitCode <> cCannotClose]; //FPassMessageToOriginalHandler := False; // <- default handler would set Msg.Result to 1 end; { -------------------------- } { ---- TGMMsgHookWindow ---- } { -------------------------- } {constructor TGMMsgHookWindow.Create(const AHookWnd: HWnd; const AParent: TGMWndObj; const ARefLifeTime: Boolean); const cStrMsgHookWndName = 'GMMessageHookWindow'; begin inherited Create(AParent, cNullRect, cFixedPlace, 0, 0, cStrMsgHookWndName, 0, 0, ARefLifeTime); FHookWnd := AHookWnd; end;} { --------------------------- } { ---- TGMWindowDisabler ---- } { --------------------------- } constructor TGMWindowDisabler.Create(const AWnd: HWnd; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); if GMIsWindow(AWnd) then FWnd := AWnd; if FWnd <> 0 then FWasEnabled := not EnableWindow(FWnd, False); end; destructor TGMWindowDisabler.Destroy; begin if (FWnd <> 0) and FWasEnabled then EnableWindow(FWnd, True); inherited Destroy; end; { ------------------------ } { ---- TGMDragPainter ---- } { ------------------------ } constructor TGMDragPainter.Create(const AParent: TObject; // const ADragOffs: TPoint; const ADragData: IUnknown; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FParent := AParent; FDragData := ADragData; GMCaptureMouseInput(Self); FOldKeyboardFocusArea := vGMKeyboardFocusArea; vGMKeyboardFocusArea := Self; end; procedure TGMDragPainter.DispatchMsg(var Msg: TMessage); begin Dispatch(Msg); end; procedure TGMDragPainter.WindowProc(var Msg: TMessage); begin DispatchMsg(Msg); end; function TGMDragPainter.GetParentObj: TObject; begin Result := FParent; end; function TGMDragPainter.FindWindowFromScreenPoint(const AScreenPos: TPoint): HWnd; begin Result := WindowFromPoint(AScreenPos); end; procedure TGMDragPainter.WMMouseMove(var Msg: TWMMouseMove); begin //inherited; DragAndQueryDropTarget(GMMousePosition); end; procedure TGMDragPainter.WMKeyDown(var Msg: TWMKey); begin //inherited; if Msg.CharCode = VK_ESCAPE then CancelDrag else DragAndQueryDropTarget(GMMousePosition); end; procedure TGMDragPainter.WMKeyUp(var Msg: TWMKey); begin inherited; DragAndQueryDropTarget(GMMousePosition); end; procedure TGMDragPainter.WMMouseWheel(var Msg: TMessage); var MousePos: TPoint; MouseOverWnd: HWnd; begin inherited; MousePos := SmallPointToPoint(TWMMouse(Msg).Pos); MouseOverWnd := WindowFromPoint(MousePos); if (MouseOverWnd <> 0) and (vGMMouseCaptureArea = Self) then begin vGMMouseCaptureArea := nil; try With Msg do Result := SendMessage(MouseOverWnd, Msg, WParam, LParam); UpdateWindow(MouseOverWnd); finally vGMMouseCaptureArea := Self; end; DragAndQueryDropTarget(GMMousePosition); end; end; procedure TGMDragPainter.WMCancelMode(var Msg: TWMCancelMode); begin CancelDrag; end; procedure TGMDragPainter.WMKillFocus(var Msg: TWMKillFocus); begin CancelDrag; end; procedure TGMDragPainter.ExitDragState; begin GMReleaseMouseCapture; vGMKeyboardFocusArea := FOldKeyboardFocusArea; FDragLastWndOver := 0; vGMDropTargetArea := nil; end; procedure TGMDragPainter.CancelDrag; begin try GMCallObjWindowProc(vGMDropTargetArea, UM_DRAG_CONTROL, Ord(drgCancel)); finally ExitDragState; GMCallObjWindowProc(FParent, UM_DRAG_CONTROL, Ord(drgFinished), cBoolInt[False]); vGMDragPainter := nil; // <- may free us! end; end; function TGMDragPainter.DragAndQueryDropTarget(AScreenPos: TPoint): Boolean; var WndOver: HWnd; NewCursor: HCursor; OldDropTarget: TObject; OldWndOver: HWnd; begin DragToScreenPos(AScreenPos); OldDropTarget := vGMDropTargetArea; OldWndOver := FDragLastWndOver; WndOver := FindWindowFromScreenPoint(AScreenPos); FDragLastWndOver := WndOver; NewCursor := 0; if GMIsWindow(WndOver) then begin ScreenToClient(WndOver, AScreenPos); NewCursor := HCursor(SendMessage(WndOver, UM_DRAG_QUERYDROP, MakeLongInt(AScreenPos.x, AScreenPos.y), LPARAM(FDragData))); end; if NewCursor = 0 then NewCursor := LoadCursor(0, Pointer(IDC_NO)); if NewCursor <> GetCursor then SetCursor(NewCursor); Result := NewCursor <> LoadCursor(0, Pointer(IDC_NO)); if (vGMDropTargetArea <> nil) and (WndOver <> OldWndOver) and (vGMDropTargetArea = OldDropTarget) then begin GMCallObjWindowProc(vGMDropTargetArea, UM_DRAG_CONTROL, Ord(drgLeave)); vGMDropTargetArea := nil; end; end; procedure TGMDragPainter.WMLButtonUp(var Msg: TWMLButtonUp); var mousePos: TPoint; wndOver: HWnd; canDrop: Boolean; begin try mousePos := GMClientToScreen(Self, SmallPointToPoint(Msg.Pos)); ExitDragState; canDrop := DragAndQueryDropTarget(mousePos); GMCallObjWindowProc(FParent, UM_DRAG_CONTROL, Ord(drgFinished), cBoolInt[canDrop]); if not canDrop then GMCallObjWindowProc(vGMDropTargetArea, UM_DRAG_CONTROL, Ord(drgCancel)) else begin wndOver := FindWindowFromScreenPoint(mousePos); if IsWindow(wndOver) then begin ScreenToClient(wndOver, mousePos); SendMessage(wndOver, UM_DRAG_DROPPED, MakeLongInt(mousePos.x, mousePos.y), LPARAM(FDragData)); end; end; finally vGMDragPainter := nil; // <- may free us! end; end; { ----------------------- } { ---- TGMDragWindow ---- } { ----------------------- } constructor TGMDragWindow.Create(const AParent: TGMWndObj; const APosition: TRect; const AAreaAlign: TGMAreaAlignRec; const ABitmap: IGMGetHandle; const AWndStyle, AWndExStyle: DWORD; const AMenu: HMENU; const ABkgndColor: COLORREF; const ARefLifeTime: Boolean); begin inherited Create(AParent, APosition, AAreaAlign, AWndStyle, AWndExStyle, '', AMenu, ABkgndColor, ARefLifeTime); if ABitmap <> nil then begin FBitmap := ABitmap; FBmpDC := TGMGdiCompatibleDC.Create(FBitmap.Handle); FImageSize := GMBitmapSize(FBitmap); end; end; function TGMDragWindow.PaintToRect(const ADC: HDC; const ARect: TRect): Boolean; var sz: TPoint; begin Result := True; if FBitmap = nil then Exit; sz := GMRectSize(ARect); StretchBlt(ADC, ARect.Left, ARect.Top, sz.x, sz.y, FBmpDC.Handle, 0, 0, FImageSize.x, FImageSize.y, SRCCOPY); end; //procedure TGMDragWindow.WMEraseBkgnd(var Msg: TWMEraseBkgnd); //begin // Msg.Result := 1; // FPassMessageToOriginalHandler := False; //end; { ----------------------------------- } { ---- TGMTransparentDragPainter ---- } { ----------------------------------- } constructor TGMTransparentDragPainter.Create(const AParent: TObject; const ABitmap: IGMGetHandle; const ATransparentColor: COLORREF; const ADragOffs: TPoint; const ADragData: IUnknown; const ARefLifeTime: Boolean); var rWnd: TRect; rgnHole: IGMGetHandle; rgnWnd: THandle; imgSize: TPoint; begin inherited Create(APArent, ADragData, ARefLifeTime); FDragOffs := ADragOffs; if ABitmap <> nil then begin imgSize := GMBitmapSize(ABitmap); rWnd := GMMoveRect(GMRect(cNullPoint, imgSize), GMAddPoints(GMMousePosition, ADragOffs, -1)); FDragWindow := TGMDragWindow.Create(0, rWnd, cFixedPlace, ABitmap, WS_POPUP, cLayeredWndFlag[GMCanUseLayeredWindows], 0, clWhite, True); // WS_VISIBLE or WS_CHILD rgnWnd := CreateRectRgn(0, 0, imgSize.x, imgSize.y); // <- will be owned by the system if successfully set try // Drill a hole in the window at mouse cursor hotspot so WindowFromPoint can be used to find out who is beneath the drag window rgnHole := TGMGdiRegion.CreateRect(0, GMRect(FDragOffs, GMPoint(FDragOffs.x+1, FDragOffs.y+1))); CombineRgn(rgnWnd, rgnWnd, rgnHole.Handle, RGN_DIFF); SetWindowRgn(FDragWindow.Handle, rgnWnd, False); except DeleteObject(rgnWnd); end; GMSetLayeredWindowAttributes(FDragWindow.Handle, ATransparentColor, 150, LWA_ALPHA or LWA_COLORKEY); GMCaptureMouseInput(Self); end; end; procedure TGMTransparentDragPainter.DragToScreenPos(const AScreenPos: TPoint); begin if FDragWindow = nil then Exit; SetWindowPos(FDragWindow.Handle, 0, AScreenPos.x - FDragOffs.x, AScreenPos.y - FDragOffs.y, 0, 0, SWP_NOSIZE or SWP_NOOWNERZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW); end; procedure TGMTransparentDragPainter.ExitDragState; begin FDragWindow := nil; inherited; end; { --------------------- } { ---- TGMTimerWnd ---- } { --------------------- } constructor TGMTimerWnd.Create(const AOwner: TObject; const ARefLifeTime: Boolean); begin inherited Create(0, cNullRect, cFixedPlace, 0, 0, 'GMTimerWnd', 0, 0, ARefLifeTime); FOwner := AOwner; end; procedure TGMTimerWnd.WMTimer(var Msg: TMessage); begin if (FOwner is TGMWndTimerWithHandle) and Assigned(TGMWndTimerWithHandle(FOwner).FOnTimerProc) then TGMWndTimerWithHandle(FOwner).FOnTimerProc(TGMWndTimerWithHandle(FOwner).Caller); end; { ------------------------------- } { ---- TGMWndTimerWithHandle ---- } { ------------------------------- } constructor TGMWndTimerWithHandle.Create(const AOnTimerProc: TGMObjNotifyProc; const ACaller: TObject; const AMilliSeconds: Integer; const AAutoStart, ARefLifeTime: Boolean); begin inherited Create(0, 0, AMilliSeconds, AAutoStart, ARefLifeTime); FOnTimerProc := AOnTimerProc; Caller := ACaller; end; function TGMWndTimerWithHandle.GetHandle: THandle; begin if FWindow = nil then FWindow := TGMTimerWnd.Create(Self, True); // -Int64(Self), cNullRect, cFixedPlace, 0, 0, 'GMTimerWnd', 0, 0, True); Result := FWindow.Handle; end; { ---------------------------- } { ---- TGMHideDragPainter ---- } { ---------------------------- } constructor TGMHideDragPainter.Create(const ADragPainter: IUnknown; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); if ADragPainter <> nil then ADragPainter.QueryInterface(IGMSetVisible, FDragPainter); if FDragPainter <> nil then FDragPainter.SetVisible(False); end; destructor TGMHideDragPainter.Destroy; begin if FDragPainter <> nil then FDragPainter.SetVisible(True); inherited; end; { ----------------------------- } { ---- TGMWndPaintDisabler ---- } { ----------------------------- } constructor TGMWndPaintDisabler.Create(const AWnd: HWnd; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); if GMIsWindow(AWnd) then FWnd := AWnd; if FWnd <> 0 then SendMessage(FWnd, WM_SETREDRAW, cFalseInt, 0); end; destructor TGMWndPaintDisabler.Destroy; begin if FWnd <> 0 then begin SendMessage(FWnd, WM_SETREDRAW, cTrueInt, 0); InvalidateRect(FWnd, nil, False); end; inherited Destroy; end; { -------------------------- } { ---- TGMWndTempCursor ---- } { -------------------------- } //constructor TGMWndTempCursor.Create(const ATempCursor: TGMCursor; AWnd: HWnd; const ARefLifeTime: Boolean); //var NewCursor: HCursor; //begin //inherited Create(ARefLifeTime); //AWnd := GMDlgRootWindow(AWnd); //if AWnd = 0 then AWnd := GMModalDlgParentWnd; //if not GMIsWindow(AWnd) then Exit; // //FDlgWnd := AWnd; //NewCursor := LoadCursor(0, cWinCursorRes[ATempCursor]); //FOldCursor := SendMessage(FDlgWnd, UM_SETTEMPCURSOR, WPARAM(INVALID_HANDLE_VALUE), 0); // //if NewCursor = FOldCursor then FDlgWnd := 0 else // <- Prevent re-setting the cursor in destructor if we did not change it // begin // //FOldCursor := // SendMessage(FDlgWnd, UM_SETTEMPCURSOR, WPARAM(NewCursor), 0); // SendMessage(FDlgWnd, WM_SETCURSOR, FDlgWnd, 0); // end; //end; // //destructor TGMWndTempCursor.Destroy; //begin //if GMIsWindow(FDlgWnd) and (FOldCursor <> INVALID_HANDLE_VALUE) then // begin // SendMessage(FDlgWnd, UM_SETTEMPCURSOR, WPARAM(FOldCursor), 0); // SendMessage(FDlgWnd, WM_SETCURSOR, FDlgWnd, 0); // end; //inherited Destroy; //end; { -------------------------- } { ---- TGMAppTempCursor ---- } { -------------------------- } //constructor TGMAppTempCursor.Create(const ATempCursor: TGMCursor; const ARefLifeTime: Boolean); //var NewCursor: HCursor; //begin // inherited Create(ARefLifeTime); // NewCursor := LoadCursor(0, cWinCursorRes[ATempCursor]); // FOldCursor := vAppTempCursor; // if NewCursor = FOldCursor then Exit; // vAppTempCursor := NewCursor; GMNotifyCursorChange; //end; // //destructor TGMAppTempCursor.Destroy; //begin // if FOldCursor <> vAppTempCursor then begin vAppTempCursor := FOldCursor; GMNotifyCursorChange; end; // inherited Destroy; //end; initialization vLightGray := GMChangeColorLightness(cDfltColor, 100); end.