{ XPMenu for Delphi Author: Khaled Shagrouni URL: http://www.shagrouni.com/english/software/xpmenu.html e-mail: khaled@shagrouni.com shagrouni@hotmail.com Version 3.0 - 08.04.2003 XPMenu is a Delphi component to mimic Office XP menu and toolbar style. Copyright (C) 2001, 2003 Khaled Shagrouni. This component is FREEWARE with source code. I still hold the copyright, but you can use it for whatever you like: freeware, shareware or commercial software. If you have any ideas for improvement or bug reports, don't hesitate to e-mail me (Please state the XPMenu version and OS information). } {$IFDEF VER130} {$DEFINE VER5U} {$ENDIF} {$IFDEF VER140} {$DEFINE VER5U} {$DEFINE VER6U} {$ENDIF} {$IFDEF VER150} {$DEFINE VER5U} {$DEFINE VER6U} {$DEFINE VER7U} {$ENDIF} unit XPMenu; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, ComCtrls, Forms, Menus, Commctrl, ExtCtrls, StdCtrls, Buttons; type TXPContainer = (xccForm, xccFrame, xccToolbar, xccCoolbar, xccControlbar, xccPanel, xccScrollBox, xccGroupBox, xccTabSheet, xccPageScroller); TXPContainers = set of TXPContainer; TXPControl = (xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcCombo, xcListBox, xcEdit, xcMaskEdit, xcMemo, xcRichEdit, xcMiscEdit, xcCheckBox, xcRadioButton, xcButton, xcBitBtn, xcSpeedButton, xcUpDown, xcPanel, xcGroupBox, xcTreeView, xcListView, xcProgressBar, xcHotKey); {xcStringGrid, xcDrawGrid, xcDBGrid);} TXPControls = set of TXPControl; TXPMenu = class; TControlSubClass = class(TComponent) //: "Fabian Jakubowski" private Control: TControl; FBuilding: boolean; FMouseInControl: boolean; FLButtonBressed: boolean; FBressed: boolean; FIsKeyDown: boolean; FIsFocused: boolean; orgWindowProc: TWndMethod; XPMenu: TXPMenu; FCtl3D: boolean; FBorderStyle: TBorderStyle; {FOnDrawCell: TDrawCellEvent;} FDefaultDrawing: boolean; FSelCol, FSelRow: integer; FMsg: Cardinal; procedure ControlSubClass(var Message: TMessage); procedure PaintControlXP; procedure PaintCombo; procedure PaintDBLookupCombo; procedure PaintEdit; procedure PaintRichEdit; procedure PaintCheckBox; procedure PaintRadio; procedure PaintButton; procedure PaintBitButn; procedure PaintUpDownButton; procedure PaintSpeedButton; procedure PaintPanel; procedure PaintGroupBox; procedure PaintNCWinControl; procedure PaintProgressBar; procedure PaintHotKey; end; TXPMenu = class(TComponent) private FActive: boolean; {Changes MMK FForm to TScrollingWinControl} FForm: TScrollingWinControl; FFont: TFont; FColor: TColor; FIconBackColor: TColor; FMenuBarColor: TColor; FCheckedColor: TColor; FSeparatorColor: TColor; FSelectBorderColor: TColor; FSelectColor: TColor; FDisabledColor: TColor; FSelectFontColor: TColor; FIconWidth: integer; FDrawSelect: boolean; FUseSystemColors: boolean; FColorsChanged: boolean; // +jt FFColor, FFIconBackColor, FFSelectColor, FFSelectBorderColor, FFSelectFontColor, FCheckedAreaColor, FCheckedAreaSelectColor, FFCheckedColor, FFMenuBarColor, FFDisabledColor, FFSeparatorColor, FMenuBorderColor, FMenuShadowColor: TColor; Is16Bit: boolean; FOverrideOwnerDraw: boolean; FGradient: boolean; FFlatMenu: boolean; FAutoDetect: boolean; FXPContainers: TXPContainers; FXPControls: TXPControls; FGrayLevel: byte; FDimLevel: byte; FDrawMenuBar: boolean; FUseDimColor: boolean; FDimParentColor, FDimParentColorSelect: integer; // FUseParentClor: boolean; // +jt FSettingWindowRng: boolean; FIsW2k: boolean; FIsWXP: boolean; FIsWNT: boolean; FTransparentColor: TColor; // +jt // Do not allow the component to be used for subclassing FDisableSubclassing: boolean; procedure SetDisableSubclassing(const Value: boolean); procedure SetActive(const Value: boolean); procedure SetAutoDetect(const Value: boolean); procedure SetForm(const Value: TScrollingWinControl); procedure SetFont(const Value: TFont); procedure SetColor(const Value: TColor); procedure SetIconBackColor(const Value: TColor); procedure SetMenuBarColor(const Value: TColor); procedure SetCheckedColor(const Value: TColor); procedure SetDisabledColor(const Value: TColor); procedure SetSelectColor(const Value: TColor); procedure SetSelectBorderColor(const Value: TColor); procedure SetSeparatorColor(const Value: TColor); procedure SetSelectFontColor(const Value: TColor); procedure SetIconWidth(const Value: integer); procedure SetDrawSelect(const Value: boolean); procedure SetUseSystemColors(const Value: boolean); procedure SetOverrideOwnerDraw(const Value: boolean); procedure SetGradient(const Value: boolean); procedure SetFlatMenu(const Value: boolean); procedure SetXPContainers(const Value: TXPContainers); procedure SetXPControls(const Value: TXPControls); procedure SetDrawMenuBar(const Value: boolean); procedure SetUseDimColor(const Value: boolean); protected procedure Loaded; override; //add by Cunha, liyang. procedure InitItems(wForm: TWinControl; Enable, Update: boolean); procedure InitItem(Comp: TComponent; Enable, Update: boolean); // Tom: "Thomas Knoblauch" 27.08 procedure DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); {$IFDEF VER5U} procedure ToolBarDrawButton(Sender: TToolBar; Button: TToolButton; State: TCustomDrawState; var DefaultDraw: Boolean); {$ENDIF} procedure ControlBarPaint(Sender: TObject; Control: TControl; Canvas: TCanvas; var ARect: TRect; var Options: TBandPaintOptions); procedure SetGlobalColor(ACanvas: TCanvas); procedure DrawTopMenuItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; BckColor:Tcolor; IsRightToLeft: boolean); procedure DrawCheckedItem(FMenuItem: TMenuItem; Selected, Enabled, HasImgLstBitmap: boolean; ACanvas: TCanvas; CheckedRect: TRect); procedure DrawTheText(Sender: TObject; txt, ShortCuttext: string; ACanvas: TCanvas; TextRect: TRect; Selected, Enabled, Default, TopMenu, IsRightToLeft: boolean; var TxtFont: TFont; TextFormat: integer); procedure DrawIcon(Sender: TObject; ACanvas: TCanvas; B: TBitmap; IconRect: Trect; Hot, Selected, Enabled, Checked, FTopMenu, IsRightToLeft: boolean); procedure MeasureItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer); //function GetImageExtent(MenuItem: TMenuItem): TPoint; function GetImageExtent(MenuItem: TMenuItem; FTopMenu: TMenu): TPoint; // +jt function TopMenuFontColor(ACanvas: TCanvas; Color: TColor): TColor; procedure DrawGradient(ACanvas: TCanvas; ARect: TRect; IsRightToLeft: boolean); procedure DrawWindowBorder(hWnd: HWND; IsRightToLeft: boolean); procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure InitComponent(Comp: TComponent); // Tom: Added for usage by the main program ."Thomas Knoblauch" 27.08 procedure ActivateMenuItem(MenuItem: TMenuItem; SubMenus: boolean); // +jt property Form: TScrollingWinControl read FForm write SetForm; // +jt property IsWXP: boolean read FIsWXP; property IsW2k: boolean read FIsW2k; property IsWNT: boolean read FIsWNT; property TransparentColor: TColor read FTransparentColor write FTransparentColor; // +jt published property DimLevel: Byte read FDimLevel write FDimLevel; property GrayLevel: Byte read FGrayLevel write FGrayLevel; property Font: TFont read FFont write SetFont; property Color: TColor read FColor write SetColor; property DrawMenuBar: boolean read FDrawMenuBar write SetDrawMenuBar; property IconBackColor: TColor read FIconBackColor write SetIconBackColor; property MenuBarColor: TColor read FMenuBarColor write SetMenuBarColor; property SelectColor: TColor read FSelectColor write SetSelectColor; property SelectBorderColor: TColor read FSelectBorderColor write SetSelectBorderColor; property SelectFontColor: TColor read FSelectFontColor write SetSelectFontColor; property DisabledColor: TColor read FDisabledColor write SetDisabledColor; property SeparatorColor: TColor read FSeparatorColor write SetSeparatorColor; property CheckedColor: TColor read FCheckedColor write SetCheckedColor; property IconWidth: integer read FIconWidth write SetIconWidth; property DrawSelect: boolean read FDrawSelect write SetDrawSelect; property UseSystemColors: boolean read FUseSystemColors write SetUseSystemColors; property UseDimColor: boolean read FUseDimColor write SetUseDimColor; property OverrideOwnerDraw: boolean read FOverrideOwnerDraw write SetOverrideOwnerDraw; property Gradient: boolean read FGradient write SetGradient; property FlatMenu: boolean read FFlatMenu write SetFlatMenu; property AutoDetect: boolean read FAutoDetect write SetAutoDetect; property XPContainers: TXPContainers read FXPContainers write SetXPContainers default [xccForm, xccFrame, xccToolbar, xccCoolbar, xccControlbar, xccPanel, xccScrollBox, xccGroupBox, xccTabSheet, xccPageScroller]; property XPControls :TXPControls read FXPControls write SetXPControls default [xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcCombo, xcListBox, xcEdit, xcMaskEdit, xcMemo, xcRichEdit, xcMiscEdit, xcCheckBox, xcRadioButton, xcButton, xcBitBtn, xcSpeedButton, xcUpDown, xcPanel, xcGroupBox, xcTreeView, xcListView, xcProgressBar, xcHotKey]; {xcStringGrid, xcDrawGrid, xcDBGrid];} property Active: boolean read FActive write SetActive; property DisableSubclassing: boolean read FDisableSubclassing write SetDisablesubclassing default false; end; TXPMenuManager = class(TPersistent) private FXPMenuList: TList; FPendingFormsList: TList; FFormList: TList; FActiveXPMenu: TXPMenu; FDisableSubclassing: boolean; function MainWindowHook(var Message: TMessage): boolean; procedure CollectForms; procedure RemoveChildSubclassing(AForm: TCustomForm); procedure SetDisableSubclassing(AValue: boolean); function FindSubclassingXPMenu(Exclude: TXPMenu): TXPMenu; protected procedure Notification(AComponent: TComponent; Operation: TOperation); public constructor Create; destructor Destroy; override; procedure Add(AXPMenu: TXPMenu); procedure Delete(AXPMenu: TXPMenu); procedure UpdateActiveXPMenu(AXPMenu: TXPMenu); procedure AddForm(AForm: TCustomForm); procedure RemoveForm(AForm: TCustomForm); function IsFormSubclassed(AForm: TCustomForm): boolean; function IsComponentSubclassed(AComponent: TComponent): boolean; property ActiveXPMenu: TXPMenu read FActiveXPMenu; property DisableSubclassing: boolean read FDisableSubclassing write SetDisableSubclassing default false; end; function GetShadeColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor; function MergColor(Colors: Array of TColor): TColor; function NewColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor; procedure DimBitmap(ABitmap: TBitmap; Value: integer); procedure DrawArrow(ACanvas: TCanvas; X, Y: integer); overload; procedure DrawArrow(ACanvas: TCanvas; X, Y, Orientation: integer); overload; function GrayColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor; function GetInverseColor(AColor: TColor): TColor; procedure GrayBitmap(ABitmap: TBitmap; Value: integer); procedure DrawBitmapShadow(B: TBitmap; ACanvas: TCanvas; X, Y: integer; ShadowColor: TColor); procedure DrawCheckMark(ACanvas: TCanvas; X, Y: integer); procedure GetSystemMenuFont(Font: TFont); procedure Register; const WM_DRAWMENUBORDER = CN_NOTIFY + 101; // +jt WM_DRAWMENUBORDER2 = CN_NOTIFY + 102; // +jt // Gloabal access to the XPMenuManager var XPMenuManager: TXPMenuManager; implementation procedure Register; begin RegisterComponents('XP', [TXPMenu]); end; // Set up the global variable that represents the XPMenuManager procedure InitControls; begin if XPMenuManager = nil then XPMenuManager := TXPMenuManager.Create; end; // Delete the global variable that represents the XPMenuManager procedure DoneControls; begin if (XPMenuManager <> nil) then begin XPMenuManager.Free; XPMenuManager := nil; end; end; // Test if mouse cursor is in the given rect of the application's main form function IsMouseInRect(TheForm: TScrollingWinControl; DestRect: TRect): boolean; var p: TPoint; begin if Assigned(TheForm) then begin p := Mouse.CursorPos; p.x := p.x - TheForm.Left; p.y := p.y - TheForm.Top; Dec(DestRect.Right); Dec(DestRect.Bottom, 2); Result := (p.x >= DestRect.Left) and (p.x <= DestRect.Right) and (p.y >= DestRect.Top) and (p.y <= DestRect.Bottom); end else Result := false; end; { TXPMenue } constructor TXPMenu.Create(AOwner: TComponent); var OSVersionInfo: TOSVersionInfo; // +jt begin inherited Create(AOwner); FFont := TFont.Create; FDisableSubclassing := false; // enable XPMenu to be used for global subclassing {$IFDEF VER5U} FFont.Assign(Screen.MenuFont); {$ELSE} GetSystemMenuFont(FFont); {$ENDIF} FForm := Owner as TScrollingWinControl; FUseSystemColors := true; FColor := clBtnFace; FIconBackColor := clBtnFace; FSelectColor := clHighlight; FSelectBorderColor := clHighlight; FMenuBarColor := clBtnFace; FDisabledColor := clInactiveCaption; FSeparatorColor := clBtnFace; FCheckedColor := clHighlight; FSelectFontColor := FFont.Color; FGrayLevel := 10; FDimLevel := 30; FIconWidth := 24; FDrawSelect := true; XPContainers := [xccForm, xccFrame, xccToolbar, xccCoolbar, xccControlbar, xccPanel, xccScrollBox, xccGroupBox, xccTabSheet, xccPageScroller]; XPControls := [xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcCombo, xcListBox, xcEdit, xcMaskEdit, xcMemo, xcRichEdit, xcMiscEdit, xcCheckBox, xcRadioButton, xcButton, xcBitBtn, xcSpeedButton, xcUpDown, xcPanel, xcGroupBox, xcTreeView, xcListView, xcProgressBar, xcHotKey]; {xcStringGrid, xcDrawGrid, xcDBGrid];} if Assigned(FForm) then SetGlobalColor(TForm(FForm).Canvas); // +jt FTransparentColor := clFuchsia; FColorsChanged := false; OSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo); GetVersionEx(OSVersionInfo); FIsWXP:=false; FIsW2k:=false; FIsWNT:=false; if OSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then begin FIsWNT:=true; if (OSVersionInfo.dwMajorVersion = 5) and (OSVersionInfo.dwMinorVersion = 0) then FIsW2k:=true; if (OSVersionInfo.dwMajorVersion = 5) and (OSVersionInfo.dwMinorVersion = 1) then FIsWXP:=true; end; // +jt if not(csDesigning in ComponentState) then InitControls; end; destructor TXPMenu.Destroy; begin if Assigned(FForm) then //oleg oleg@vdv-s.ru Mon Oct 7 InitItems(FForm, false, false); // Remove XPMenu from XPMenuManager if Assigned(XPMenuManager) and not(csDesigning in ComponentState) then begin XPMenuManager.Delete(Self); FForm.Update; if XPMenuManager.FXPMenuList.Count = 0 then DoneControls; end; FFont.Free; inherited; end; //add by: //liyang ,2002-07-19 //Pedro Miguel Cunha - 02 Apr 2002 procedure TXPMenu.Loaded; begin inherited Loaded; // Add the XPMenu to the XPMenuManager if Assigned(XPMenuManager) and not(csDesigning in ComponentState) then XPMenuManager.Add(Self); end; {to check for new sub items} procedure TXPMenu.ActivateMenuItem(MenuItem: TMenuItem; SubMenus: boolean); // +jt procedure Activate(MenuItem: TMenuItem); begin if (MenuItem.Tag <> 999) then if addr(MenuItem.OnDrawItem) <> addr(TXPMenu.DrawItem) then begin if (not assigned(MenuItem.OnDrawItem)) or (FOverrideOwnerDraw) then MenuItem.OnDrawItem := DrawItem; if (not assigned(MenuItem.OnMeasureItem)) or (FOverrideOwnerDraw) then MenuItem.OnMeasureItem := MeasureItem; end end; var i{, j}: integer; begin Activate(MenuItem); if (SubMenus=true) then // +jt begin for i := 0 to MenuItem.Count -1 do begin ActivateMenuItem(MenuItem.Items[i],true); end; end; end; procedure TXPMenu.InitItems(wForm: TWinControl; Enable, Update: boolean ); var i: integer; Comp: TComponent; begin for i := 0 to wForm.ComponentCount - 1 do begin Comp := wForm.Components[i]; InitItem(Comp, Enable, Update); // Tom: "Thomas Knoblauch" 27.08 end; end; procedure TXPMenu.InitComponent(Comp: TComponent); // Tom: for external (by the main program) use without parameters. "Thomas Knoblauch" 27.08 begin if FActive then InitItem(Comp, true, true); end; // Tom: "Thomas Knoblauch" 27.08 procedure TXPMenu.InitItem(Comp: TComponent; Enable, Update: boolean ); procedure Activate(MenuItem: TMenuItem); begin if Enable then begin if (MenuItem.Tag <> 999) then begin if (not assigned(MenuItem.OnDrawItem)) or (FOverrideOwnerDraw) then MenuItem.OnDrawItem := DrawItem; if (not assigned(MenuItem.OnMeasureItem)) or (FOverrideOwnerDraw) then MenuItem.OnMeasureItem := MeasureItem; end; end else begin if addr(MenuItem.OnDrawItem) = addr(TXPMenu.DrawItem) then MenuItem.OnDrawItem := nil; if addr(MenuItem.OnMeasureItem) = addr(TXPMenu.MeasureItem) then MenuItem.OnMeasureItem := nil; end; end; procedure ItrateMenu(MenuItem: TMenuItem); var i: integer; begin Activate(MenuItem); for i := 0 to MenuItem.Count - 1 do begin ItrateMenu(MenuItem.Items[i]); end; end; var x: integer; s: string; begin if (Comp is TMainMenu) and (xcMainMenu in XPControls) and (TMainMenu(Comp).Tag <> 999)then begin for x := 0 to TMainMenu(Comp).Items.Count - 1 do begin TMainMenu(Comp).OwnerDraw := Enable; //Activate(TMainMenu(Comp).Items[x]); ItrateMenu(TMainMenu(Comp).Items[x]); end; // Selly way to force top menu in other forms to repaint S := TMainMenu(Comp).Items[0].Caption; TMainMenu(Comp).Items[0].Caption := ''; TMainMenu(Comp).Items[0].Caption := S; end; if (Comp is TPopupMenu) and (xcPopupMenu in XPControls) then begin for x := 0 to TPopupMenu(Comp).Items.Count - 1 do begin TPopupMenu(Comp).OwnerDraw := Enable; ItrateMenu(TPopupMenu(Comp).Items[x]); end; end; {$IFDEF VER5U} if (Comp is TToolBar) and (xcToolBar in FXPControls) then if not (csDesigning in ComponentState) then begin if not TToolBar(Comp).Flat then TToolBar(Comp).Flat := true; if Enable then begin for x := 0 to TToolBar(Comp).ButtonCount - 1 do if (not assigned(TToolBar(Comp).OnCustomDrawButton)) or (FOverrideOwnerDraw) then begin TToolBar(Comp).OnCustomDrawButton := ToolBarDrawButton; end; end else begin if addr(TToolBar(Comp).OnCustomDrawButton) = addr(TXPMenu.ToolBarDrawButton) then TToolBar(Comp).OnCustomDrawButton := nil; end; if Update then TToolBar(Comp).Invalidate; end; {$ENDIF} if (Comp is TControlBar) and (xcControlBar in FXPControls) then if not (csDesigning in ComponentState) then begin if Enable then begin if (not assigned(TControlBar(Comp).OnBandPaint)) or (FOverrideOwnerDraw) then begin TControlBar(Comp).OnBandPaint := ControlBarPaint; end; end else begin if addr(TControlBar(Comp).OnBandPaint) = addr(TXPMenu.ControlBarPaint) then TControlBar(Comp).OnBandPaint := nil; end; if Update then TControlBar(Comp).Invalidate; end; if not (csDesigning in ComponentState) then if {$IFDEF VER6U} ((Comp is TCustomCombo) and (xcCombo in FXPControls)) or ((Comp is TCustomLabeledEdit) and (xcEdit in FXPControls)) or {$ELSE} ((Comp is TCustomComboBox) and (xcCombo in FXPControls)) or {$ENDIF} ((Comp is TEdit) and (xcEdit in FXPControls)) or ((Comp.ClassName = 'TMaskEdit') and (xcMaskEdit in FXPControls)) or ((Comp.ClassName = 'TDBEdit') and (xcMaskEdit in FXPControls)) or ((Comp is TCustomMemo) and (xcMemo in FXPControls)) or ((Comp is TCustomRichEdit) and (xcRichEdit in FXPControls)) or ((Comp is TCustomCheckBox) and (xcCheckBox in FXPControls)) or ((Comp is TRadioButton) and (xcRadioButton in FXPControls)) or ((Comp.ClassName = 'TBitBtn') and (xcBitBtn in FXPControls)) or ((Comp.ClassName = 'TButton') and (xcButton in FXPControls)) or ((Comp.ClassName = 'TUpDown') and (xcUpDown in FXPControls)) or ((Comp is TSpeedButton) and (xcSpeedButton in FXPControls)) or ((Comp is TCustomPanel) and (xcPanel in FXPControls)) or ((Comp.ClassName = 'TDBNavigator') and (xcButton in FXPControls)) or ((Comp.ClassName = 'TDBLookupComboBox') and (xcButton in FXPControls)) or ((Comp is TCustomGroupBox) and (xcGroupBox in FXPControls)) or ((Comp is TCustomListBox) and (xcListBox in FXPControls)) or ((Comp is TCustomTreeView) and (xcTreeView in FXPControls)) or ((Comp is TCustomListView) and (xcListView in FXPControls)) or ((Comp is TProgressBar) and (xcProgressBar in FXPControls)) or ((Comp is TCustomHotKey) and (xcHotKey in FXPControls)) then if ((TControl(Comp).Parent is TToolbar) and (xccToolBar in FXPContainers))or ((TControl(Comp).Parent is TCoolbar) and (xccCoolbar in FXPContainers)) or ((TControl(Comp).Parent is TCustomPanel) and (xccPanel in FXPContainers)) or ((TControl(Comp).Parent is TControlbar) and (xccControlbar in FXPContainers)) or ((TControl(Comp).Parent is TScrollBox) and (xccScrollBox in FXPContainers)) or ((TControl(Comp).Parent is TCustomGroupBox) and (xccGroupBox in FXPContainers)) or ((TControl(Comp).Parent is TTabSheet) and (xccTabSheet in FXPContainers)) or ((TControl(Comp).Parent is TTabControl) and (xccTabSheet in FXPContainers)) or ((TControl(Comp).Parent.ClassName = 'TdxTabSheet') and (xccTabSheet in FXPContainers)) or //DeveloperExpress ((TControl(Comp).Parent is TPageScroller) and (xccPageScroller in FXPContainers)) or {$IFDEF VER5U} ((TControl(Comp).Parent is TCustomFrame) and (xccFrame in FXPContainers)) or {$ENDIF} ((TControl(Comp).Parent.ClassName = 'TDBCtrlPanel') and (xccFrame in FXPContainers)) or ((TControl(Comp).Parent is TCustomForm) and (xccForm in FXPContainers)) then begin if (Enable) and (Comp.Tag <> 999) and (TControl(Comp).Parent.Tag <> 999) then {skip if Control/Control.parent.tag = 999} with TControlSubClass.Create(Self) do begin Control := TControl(Comp); if Addr(Control.WindowProc) <> Addr(TControlSubClass.ControlSubClass) then begin orgWindowProc := Control.WindowProc; Control.WindowProc := ControlSubClass; end; XPMenu := self; if (Control is TCustomEdit) then begin FCtl3D := TEdit(Control).Ctl3D; FBorderStyle := TRichEdit(Control).BorderStyle; end; if Control.ClassName = 'TDBLookupComboBox' then begin FCtl3D := TComboBox(Control).Ctl3D; end; if (Control is TCustomListBox) then begin FCtl3D := TListBox(Control).Ctl3D; FBorderStyle := TListBox(Control).BorderStyle; end; if (Control is TCustomListView) then begin FCtl3D := TListView(Control).Ctl3D; FBorderStyle := TListView(Control).BorderStyle; end; if (Control is TCustomTreeView) then begin FCtl3D := TTreeView(Control).Ctl3D; FBorderStyle := TTreeView(Control).BorderStyle; end; end; if Update then begin TControl(Comp).invalidate //in TControlSubClass.ControlSubClass end; end; // Recursive call for possible containers. // Do recursive call for RadioGroups if (((Comp is TCustomRadioGroup)) and (xccGroupBox in FXPContainers)) then self.InitItems(Comp as TWinControl, Enable, Update); if {$IFDEF VER5U}((Comp is TCustomFrame) and (xccFrame in FXPContainers)) or {$ENDIF}(Comp.ClassName = 'TDBNavigator') or (Comp is TCustomForm) then //By Geir Wikran self.InitItems(Comp as TWinControl, Enable, Update); end; procedure TXPMenu.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); begin if FActive then MenueDrawItem(Sender, ACanvas, ARect, Selected); end; function TXPMenu.GetImageExtent(MenuItem: TMenuItem; FTopMenu: TMenu): TPoint; var HasImgLstBitmap: boolean; B: TBitmap; begin B := TBitmap.Create; try B.Width := 0; B.Height := 0; Result.x := 0; Result.Y := 0; HasImgLstBitmap := false; // +jt if Assigned(FTopMenu) then begin if FTopMenu.Images <> nil then if MenuItem.ImageIndex <> -1 then HasImgLstBitmap := true; end; if (MenuItem.Parent.GetParentMenu.Images <> nil) {$IFDEF VER5U} or (MenuItem.Parent.SubMenuImages <> nil) {$ENDIF} then begin if MenuItem.ImageIndex <> -1 then HasImgLstBitmap := true else HasImgLstBitmap := false; end; if HasImgLstBitmap then begin {$IFDEF VER5U} if MenuItem.Parent.SubMenuImages <> nil then MenuItem.Parent.SubMenuImages.GetBitmap(MenuItem.ImageIndex, B) else {$ENDIF} MenuItem.Parent.GetParentMenu.Images.GetBitmap(MenuItem.ImageIndex, B) end else if MenuItem.Bitmap.Width > 0 then B.Assign(TBitmap(MenuItem.Bitmap)); Result.x := B.Width; Result.Y := B.Height; if not Assigned(FTopMenu) then // +jt if Result.x < FIconWidth then Result.x := FIconWidth; finally B.Free; end; end; procedure TXPMenu.MeasureItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer); var s: string; W, H: integer; P: TPoint; IsLine: boolean; FTopMenu: boolean; // +jt FMenu: TMenu; // +jt i: integer; // +jt begin FTopMenu:=false; //+jt if FActive then begin S := TMenuItem(Sender).Caption; if S = '-' then IsLine := true else IsLine := false; if IsLine then S := ''; if Trim(ShortCutToText(TMenuItem(Sender).ShortCut)) <> '' then S := S + ShortCutToText(TMenuItem(Sender).ShortCut) + 'WWW'; ACanvas.Font.Assign(FFont); W := ACanvas.TextWidth(s); Inc(W, 5); if pos('&', s) > 0 then W := W - ACanvas.TextWidth('&'); // +jt FMenu := TMenuItem(Sender).Parent.GetParentMenu; if FMenu is TMainMenu then begin for i := 0 to TMenuItem(Sender).GetParentMenu.Items.Count - 1 do if TMenuItem(Sender).GetParentMenu.Items[i] = TMenuItem(Sender) then begin FTopMenu := True; break; end end; if not FTopMenu then FMenu := nil; if(not FTopMenu) and (TMenuItem(Sender).Count>0) then Inc(W,6); // +jt // +jt P := GetImageExtent(TMenuItem(Sender), FMenu); // +jt W := W + P.x ; if Width < W then Width := W; if IsLine then Height := 4 else begin H := ACanvas.TextHeight(s) + Round(ACanvas.TextHeight(s) * 0.75); if P.y + 6 > H then H := P.y + 6; if Height < H then Height := H; end; end; end; procedure TXPMenu.MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); var txt: string; B: TBitmap; IconRect, TextRect, CheckedRect: TRect; FillRect: TRect; // +jt i, X1, X2: integer; TextFormat: integer; HasImgLstBitmap: boolean; HasBitmap: boolean; FMenuItem: TMenuItem; FMenu: TMenu; FTopMenu: boolean; IsLine: boolean; ImgListHandle: HImageList; {Commctrl.pas} ImgIndex: integer; hWndM: HWND; hDcM: HDC; DrawTopMenuBorder: boolean; msg: TMSG; // +jt buff: TBitmap; // +jt OrigRect: TRect; // +jt OrigCanvas: TCanvas; // +jt begin OrigCanvas:= nil; FTopMenu := false; FMenuItem := TMenuItem(Sender); // +jt B := TBitmap.Create; buff := TBitmap.Create; try origrect:= ARect; Dec(origrect.Left,4); origcanvas:=ACanvas; ARect.Right:=(ARect.Right-ARect.Left)+4; ARect.Bottom:=ARect.Bottom-ARect.Top; ARect.Left:=4; ARect.Top:=0; buff.Width := ARect.Right; buff.Height := ARect.Bottom; ACanvas:=buff.Canvas; // +jt //SetGlobalColor(ACanvas); if FMenuItem.Caption = '-' then IsLine := true else IsLine := false; FMenu := FMenuItem.Parent.GetParentMenu; if FMenu is TMainMenu then for i := 0 to FMenuItem.GetParentMenu.Items.Count - 1 do if FMenuItem.GetParentMenu.Items[i] = FMenuItem then begin FTopMenu := True; // +jt ARect.Left:=0; Inc(origrect.Left,4); Dec(ARect.Right,4); buff.Width:=ARect.Right; Dec(ARect.Bottom,1); // +jt break; end; if(FColorsChanged) then SetGlobalColor(ACanvas); // +jt ACanvas.Font.Assign(FFont); Inc(ARect.Bottom, 1); TextRect := ARect; txt := ' ' + FMenuItem.Caption; B := TBitmap.Create; HasBitmap := false; HasImgLstBitmap := false; if (FMenuItem.Parent.GetParentMenu.Images <> nil) {$IFDEF VER5U} or (FMenuItem.Parent.SubMenuImages <> nil) {$ENDIF} then begin if FMenuItem.ImageIndex <> -1 then HasImgLstBitmap := true else HasImgLstBitmap := false; end; if FMenuItem.Bitmap.Width > 0 then HasBitmap := true; //------- if HasBitmap then begin B.Width := FMenuItem.Bitmap.Width; B.Height := FMenuItem.Bitmap.Height; // +jt B.Canvas.Brush.Color := FTransparentColor; // ACanvas.Brush.Color; B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height)); FMenuItem.Bitmap.Transparent := true; FMenuItem.Bitmap.TransparentMode := tmAuto; B.Canvas.Draw(0,0,FMenuItem.Bitmap); // +jt end; if HasImgLstBitmap then begin {$IFDEF VER5U} if FMenuItem.Parent.SubMenuImages <> nil then begin ImgListHandle := FMenuItem.Parent.SubMenuImages.Handle; ImgIndex := FMenuItem.ImageIndex; B.Width := FMenuItem.Parent.SubMenuImages.Width; B.Height := FMenuItem.Parent.SubMenuImages.Height; B.Canvas.Brush.Color := FTransparentColor; // ACanvas.Brush.Color; // +jt B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height)); ImageList_DrawEx(ImgListHandle, ImgIndex, B.Canvas.Handle, 0, 0, 0, 0, clNone, clNone, ILD_Transparent); end else {$ENDIF} if FMenuItem.Parent.GetParentMenu.Images <> nil then begin ImgListHandle := FMenuItem.Parent.GetParentMenu.Images.Handle; ImgIndex := FMenuItem.ImageIndex; B.Width := FMenuItem.Parent.GetParentMenu.Images.Width; B.Height := FMenuItem.Parent.GetParentMenu.Images.Height; B.Canvas.Brush.Color := FTransparentColor; //ACanvas.Pixels[2,2]; // +jt B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height)); ImageList_DrawEx(ImgListHandle, ImgIndex, B.Canvas.Handle, 0, 0, 0, 0, clNone, clNone, ILD_Transparent); end; end; //----- if FMenu.IsRightToLeft then begin X1 := ARect.Right - FIconWidth; X2 := ARect.Right; end else begin X1 := ARect.Left; X2 := ARect.Left + FIconWidth; end; IconRect := Rect(X1, ARect.Top, X2, ARect.Bottom); if HasImgLstBitmap or HasBitmap then begin CheckedRect := IconRect; Inc(CheckedRect.Left, 1); Inc(CheckedRect.Top, 2); Dec(CheckedRect.Right, 3); Dec(CheckedRect.Bottom, 2); end else begin CheckedRect.Left := IconRect.Left + (IConRect.Right - IconRect.Left - 10) div 2; CheckedRect.Top := IconRect.Top + (IConRect.Bottom - IconRect.Top - 10) div 2; CheckedRect.Right := CheckedRect.Left + 10; CheckedRect.Bottom := CheckedRect.Top + 10; end; if B.Width > FIconWidth then if FMenu.IsRightToLeft then CheckedRect.Left := CheckedRect.Right - B.Width else CheckedRect.Right := CheckedRect.Left + B.Width; if FTopMenu then Dec(CheckedRect.Top, 1); if FMenu.IsRightToLeft then begin X1 := ARect.Left; if not FTopMenu then Dec(X2, FIconWidth) else Dec(X2, 4); if (ARect.Right - B.Width) < X2 then X2 := ARect.Right - B.Width - 8; end else begin X1 := ARect.Left ; if not FTopMenu then Inc(X1, FIconWidth) else Inc(X1, 4); if (ARect.Left + B.Width) > X1 then X1 := ARect.Left + B.Width + 4; X2 := ARect.Right; end; TextRect := Rect(X1, ARect.Top, X2, ARect.Bottom); // +jt FillRect := ARect; Dec(FillRect.Left,4); // +jt if FTopMenu then begin if not (HasImgLstBitmap or HasBitmap) then begin TextRect := ARect; end else begin if FMenu.IsRightToLeft then TextRect.Right := TextRect.Right + 5 else TextRect.Left := TextRect.Left - 5; end end; if FTopMenu then begin if FDrawMenuBar then FFMenuBarColor := FMenuBarColor; ACanvas.brush.color := FFMenuBarColor; ACanvas.Pen.Color := FFMenuBarColor; // Inc(ARect.Bottom, 2); ACanvas.FillRect(ARect); //-- if FDrawMenuBar then begin if FMenuItem.GetParentMenu.Items[FMenuItem.GetParentMenu.Items.Count-1] = FMenuItem then begin if FMenu.IsRightToLeft then ACanvas.Rectangle(3, ARect.Top, ARect.Right, ARect.Bottom) else ACanvas.Rectangle(ARect.Left, ARect.Top, TScrollingWinControl(FMenu.Owner).ClientWidth+5{FForm.ClientWidth+5}, ARect.Bottom); end else if FMenu.IsRightToLeft then ACanvas.Rectangle(ARect.Left, ARect.Top, ARect.Right+7, ARect.Bottom); end; //-- end else begin if (Is16Bit and FGradient) then begin inc(ARect.Right,2); //needed for RightToLeft DrawGradient(ACanvas, ARect, FMenu.IsRightToLeft); Dec(ARect.Right,2); end else begin ACanvas.brush.color := FFColor; ACanvas.FillRect(FillRect); // +jt ACanvas.brush.color := FFIconBackColor; ACanvas.FillRect(IconRect); end; //------------ end; if FMenuItem.Enabled then ACanvas.Font.Color := FFont.Color else ACanvas.Font.Color := FDisabledColor; DrawTopMenuBorder := false; if Selected and FDrawSelect then begin ACanvas.brush.Style := bsSolid; if FTopMenu then begin DrawTopMenuItem(FMenuItem, ACanvas, ARect, FMenuBarColor, FMenu.IsRightToLeft); end else if FMenuItem.Enabled then begin Inc(ARect.Top, 1); Dec(ARect.Bottom, 1); if FFlatMenu then Dec(ARect.Right, 1); ACanvas.brush.color := FFSelectColor; ACanvas.FillRect(ARect); ACanvas.Pen.color := FFSelectBorderColor; ACanvas.Brush.Style := bsClear; ACanvas.RoundRect(Arect.Left, Arect.top, Arect.Right, Arect.Bottom, 0, 0); Dec(ARect.Top, 1); Inc(ARect.Bottom, 1); if FFlatMenu then Inc(ARect.Right, 1); end; DrawTopMenuBorder := true; end // Draw the menubar in XP Style when hovering over an main menu item else begin //if FMenuItem.Enabled and FTopMenu and IsMouseInRect( TScrollingWinControl(FMenu.Owner), ARect) then if FMenuItem.Enabled and FTopMenu and IsWNT and IsMouseInRect( TScrollingWinControl(FMenu.Owner), origrect) then // +jt begin ACanvas.brush.Style := bsSolid; ACanvas.brush.color := FFSelectColor; DrawTopMenuBorder := true; ACanvas.Pen.color := FFSelectBorderColor; ACanvas.Rectangle(ARect.Left, ARect.Top, ARect.Right - 7, ARect.Bottom); end; end; if (FMenuItem.Checked) or (FMenuItem.RadioItem ) then //x DrawCheckedItem(FMenuItem, Selected, FMenuItem.Enabled, HasImgLstBitmap or HasBitmap, ACanvas, CheckedRect); if (B <> nil) and (B.Width > 0) then // X DrawIcon(FMenuItem, ACanvas, B, IconRect, Selected or DrawTopMenuBorder, False, FMenuItem.Enabled, FMenuItem.Checked, FTopMenu, FMenu.IsRightToLeft); if not IsLine then begin if FMenu.IsRightToLeft then begin TextFormat := DT_RIGHT + DT_RTLREADING; Dec(TextRect.Right, 3); end else begin TextFormat := 0; Inc(TextRect.Left, 3); end; TextRect.Top := TextRect.Top + ((TextRect.Bottom - TextRect.Top) - ACanvas.TextHeight('W')) div 2; DrawTheText(FMenuItem, txt, ShortCutToText(FMenuItem.ShortCut), ACanvas, TextRect, Selected, FMenuItem.Enabled, FMenuItem.Default, FTopMenu, FMenu.IsRightToLeft, FFont, TextFormat); end else begin if FMenu.IsRightToLeft then begin X1 := TextRect.Left; X2 := TextRect.Right - 7; end else begin X1 := TextRect.Left + 7; X2 := TextRect.Right; end; ACanvas.Pen.Color := FFSeparatorColor; ACanvas.MoveTo(X1, TextRect.Top + Round((TextRect.Bottom - TextRect.Top) / 2)); ACanvas.LineTo(X2, TextRect.Top + Round((TextRect.Bottom - TextRect.Top) / 2)) end; // +jt BitBlt(origcanvas.Handle,origrect.Left,origrect.Top,buff.Width,buff.Height,ACanvas.Handle,0,0,SRCCOPY); finally B.free; buff.free; ACanvas := OrigCanvas; ARect:=origrect; end; // +jt if not (csDesigning in ComponentState) then begin if (FFlatMenu) and (not FTopMenu) then begin hDcM := ACanvas.Handle; hWndM := WindowFromDC(hDcM); // +jt if (hWndM=0) and (Application.Handle<>0) then begin if not PeekMessage(msg,Application.Handle,WM_DRAWMENUBORDER,WM_DRAWMENUBORDER2,PM_NOREMOVE) then PostMessage(Application.Handle,WM_DRAWMENUBORDER,0,Integer(FMenuItem)); end else if hWndM <> FForm.Handle then begin if not PeekMessage(msg,Application.Handle,WM_DRAWMENUBORDER,WM_DRAWMENUBORDER2,PM_NOREMOVE) then PostMessage(Application.Handle,WM_DRAWMENUBORDER2,integer(FMenu.IsRightToLeft),Integer(hWndM)); end; end; end; //----- end; {$IFDEF VER5U} procedure TXPMenu.ToolBarDrawButton(Sender: TToolBar; Button: TToolButton; State: TCustomDrawState; var DefaultDraw: Boolean); var ACanvas: TCanvas; ARect, HoldRect: TRect; B: TBitmap; HasBitmap: boolean; {Sylvain ...} HasHotBitMap : Boolean; HasDisBitMap : Boolean; ImglstHand : THandle; CanDraw : Boolean; {... Sylvain} BitmapWidth: integer; TextFormat: integer; XButton: TToolButton; HasBorder: boolean; HasBkg: boolean; IsTransparent: boolean; FBSelectColor: TColor; procedure DrawBorder; var BRect, WRect: TRect; procedure DrawRect; begin ACanvas.Pen.color := FFSelectBorderColor; ACanvas.MoveTo(WRect.Left, WRect.Top); ACanvas.LineTo(WRect.Right, WRect.Top); ACanvas.LineTo(WRect.Right, WRect.Bottom); ACanvas.LineTo(WRect.Left, WRect.Bottom); ACanvas.LineTo(WRect.Left, WRect.Top); end; begin BRect := HoldRect; Dec(BRect.Bottom, 1); Inc(BRect.Top, 1); Dec(BRect.Right, 1); WRect := BRect; if Button.Style = tbsDropDown then begin Dec(WRect.Right, 13); DrawRect; WRect := BRect; Inc(WRect.Left, WRect.Right - WRect.Left - 13); DrawRect; end else begin DrawRect; end; end; begin B := nil; {Added By Sylvain ...} HasHotBitmap := (Sender.HotImages <> nil) and (Button.ImageIndex <> -1) and (Button.ImageIndex <= Sender.HotImages.Count - 1); HasDisBitmap := (Sender.DisabledImages <> nil) and (Button.ImageIndex <> -1) and (Button.ImageIndex <= Sender.DisabledImages.Count - 1); {...Sylvain} HasBitmap := (Sender.Images <> nil) and (Button.ImageIndex <> -1) and (Button.ImageIndex <= Sender.Images.Count - 1); IsTransparent := Sender.Transparent; ACanvas := Sender.Canvas; //SetGlobalColor(ACanvas); if(FColorsChanged) then SetGlobalColor(ACanvas); // +jt if (Is16Bit) and (not UseSystemColors) then FBSelectColor := NewColor(ACanvas, FSelectColor, 68) else FBSelectColor := FFSelectColor; HoldRect := Button.BoundsRect; ARect := HoldRect; if Is16Bit then ACanvas.brush.color := NewColor(ACanvas, Sender.Color, 16) else ACanvas.brush.color := Sender.Color; if not IsTransparent then ACanvas.FillRect(ARect); HasBorder := false; HasBkg := false; if (cdsHot in State) then begin if (cdsChecked in State) or (Button.Down) or (cdsSelected in State) then ACanvas.Brush.Color := FCheckedAreaSelectColor else ACanvas.brush.color := FBSelectColor; HasBorder := true; HasBkg := true; end; if ((cdsChecked in State) and not (cdsHot in State)) then begin ACanvas.Brush.Color := FCheckedAreaColor; HasBorder := true; HasBkg := true; end; if (cdsIndeterminate in State) and not (cdsHot in State) then begin ACanvas.Brush.Color := FBSelectColor; HasBkg := true; end; if (Button.MenuItem <> nil) and (State = []) then begin ACanvas.brush.color := Sender.Color; if not IsTransparent then HasBkg := true; end; Inc(ARect.Top, 1); if HasBkg then ACanvas.FillRect(ARect); if HasBorder then DrawBorder; if ((Button.MenuItem <> nil) or (Button.DropdownMenu <> nil)) and (cdsSelected in State) then begin DrawTopMenuItem(Button, ACanvas, ARect, Sender.Color ,false); DefaultDraw := false; end; ARect := HoldRect; DefaultDraw := false; if Button.Style = tbsDropDown then begin ACanvas.Pen.Color := clBlack; DrawArrow(ACanvas, (ARect.Right - 14) + ((14 - 5) div 2), ARect.Top + ((ARect.Bottom - ARect.Top - 3) div 2) + 1); end; BitmapWidth := 0; { Rem by Sylvain ... if HasBitmap then begin ... Sylvain} try B := TBitmap.Create; CanDraw := False; ImglstHand:=0; if (cdsHot in State) AND HasHotBitmap then begin B.Width := Sender.HotImages.Width; B.Height := Sender.HotImages.Height; ImglstHand := Sender.HotImages.Handle; CanDraw := True; end else if (cdsDisabled in State) and HasDisBitmap then begin B.Width := Sender.DisabledImages.Width; B.Height := Sender.DisabledImages.Height; ImglstHand := Sender.DisabledImages.Handle; CanDraw := True; end else if HasBitMap then begin B.Width := Sender.Images.Width; B.Height := Sender.Images.Height; ImglstHand := Sender.Images.Handle; CanDraw := True; end; if CanDraw then begin {CanDraw} B.Canvas.Brush.Color := TransparentColor; // ACanvas.Brush.Color; // +jt B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height)); ImageList_DrawEx(ImglstHand, Button.ImageIndex, B.Canvas.Handle, 0, 0, 0, 0, clNone, clNone, ILD_Transparent); BitmapWidth := b.Width; if Button.Style = tbsDropDown then Dec(ARect.Right, 12); if TToolBar(Button.Parent).List then begin if Button.BiDiMode = bdRightToLeft then begin Dec(ARect.Right, 3); ARect.Left := ARect.Right - BitmapWidth; end else begin Inc(ARect.Left, 3); ARect.Right := ARect.Left + BitmapWidth end end else ARect.Left := Round(ARect.Left + (ARect.Right - ARect.Left - B.Width)/2); inc(ARect.Top, 2); ARect.Bottom := ARect.Top + B.Height + 6; DrawIcon(Button, ACanvas, B, ARect, (cdsHot in State), (cdsSelected in State), Button.Enabled, (cdsChecked in State), false, false); end; {CanDraw} finally B.Free; end; ARect := HoldRect; DefaultDraw := false; {rem by sylvain ... end; ...Sylvain} //----------- if Sender.ShowCaptions then begin if Button.Style = tbsDropDown then Dec(ARect.Right, 12); if not TToolBar(Button.Parent).List then begin TextFormat := DT_Center; ARect.Top := ARect.Bottom - ACanvas.TextHeight(Button.Caption) - 6; end else begin TextFormat := DT_VCENTER; if Button.BiDiMode = bdRightToLeft then begin TextFormat := TextFormat + DT_Right; Dec(ARect.Right, BitmapWidth + 7); end else begin if BitmapWidth > 0 then //"Dan Downs" if Sender.List then //Michaël Moreno Inc(ARect.Left, BitmapWidth + 6) else Inc(ARect.Left, BitmapWidth); end end; if (Button.MenuItem <> nil) then begin TextFormat := DT_Center; //Inc(ARect.Left, 1); end; if Button.BiDiMode = bdRightToLeft then TextFormat := TextFormat + DT_RTLREADING; if Button.Down and not Button.Enabled then //"felix" 23/5 InflateRect(ARect, -1, -1); DrawTheText(Button, Button.Caption, '', ACanvas, ARect, (cdsSelected in State), Button.Enabled, false, (Button.MenuItem <> nil), (Button.BidiMode = bdRightToLeft), FFont, TextFormat); ARect := HoldRect; DefaultDraw := false; end; if Button.Index > 0 then begin XButton := {TToolBar(Button.Parent)}Sender.Buttons[Button.Index - 1]; if (XButton.Style = tbsDivider) or (XButton.Style = tbsSeparator) then begin ARect := XButton.BoundsRect; if Is16Bit then ACanvas.brush.color := NewColor(ACanvas, Sender.Color, 16) else ACanvas.brush.color := Sender.Color; if not IsTransparent then ACanvas.FillRect(ARect); // if (XButton.Style = tbsDivider) then // Can't get it. if XButton.Tag > 0 then begin Inc(ARect.Top, 2); Dec(ARect.Bottom, 1); ACanvas.Pen.color := GetShadeColor(ACanvas,Sender.Color,30); ARect.Left := ARect.Left + (ARect.Right - ARect.Left) div 2; ACanvas.MoveTo(ARect.Left, ARect.Top); ACanvas.LineTo(ARect.Left, ARect.Bottom); end; ARect := Button.BoundsRect; DefaultDraw := false; end; end; {if Button.MenuItem <> nil then if (xcMainMenu in XPControls) then ActivateMenuItem(Button.MenuItem);} end; {$ENDIF} // Controlbar Paint. Added by Michiel van Oudheusden (27 sep 2001) // Paints the bands of a controlbar like the office XP style procedure TXPMenu.ControlBarPaint(Sender: TObject; Control: TControl; Canvas: TCanvas; var ARect: TRect; var Options: TBandPaintOptions); var i: Integer; intInc: integer; begin if(FColorsChanged) then SetGlobalColor(Canvas); // +jt // No frame and grabber drawing. We do it ourselfes Options := []; // First background if Is16Bit then Canvas.brush.color := NewColor(Canvas, TControlBar(Sender).Color , 6) else Canvas.brush.color := TControlBar(Sender).Color; Canvas.FillRect(ARect); intInc := 30; for i := (ARect.Top + 5) to (ARect.Bottom - 5)do begin Canvas.Pen.Color := GetShadeColor(Canvas, TControlBar(Sender).Color, intInc); if i mod 2 = 0 then begin Canvas.MoveTo(ARect.Left + 3, i); Canvas.LineTo(ARect.Left + 6, i); Inc(intInc, 7); end; end; end; procedure TXPMenu.SetGlobalColor(ACanvas: TCanvas); begin //----- FColorsChanged:=false; // +jt if GetDeviceCaps(ACanvas.Handle, BITSPIXEL) < 16 then Is16Bit := false else Is16Bit := true; FDimParentColor := 16; FDimParentColorSelect := 40; FFColor := FColor; FFIconBackColor := FIconBackColor; if Is16Bit then begin if FUseDimColor then begin FFSelectColor := NewColor(ACanvas, FSelectColor, 68); FCheckedAreaColor := NewColor(ACanvas, FSelectColor, 80); FCheckedAreaSelectColor := NewColor(ACanvas, FSelectColor, 50); end else begin FFSelectColor := FSelectColor; FCheckedAreaColor := FSelectColor; FCheckedAreaSelectColor := FSelectColor; end; FMenuBorderColor := GetShadeColor(ACanvas, clBtnFace, 90); FMenuShadowColor := GetShadeColor(ACanvas, clBtnFace, 76); end else begin FFSelectColor := FSelectColor; FCheckedAreaColor := clWhite; FCheckedAreaSelectColor := clSilver; FMenuBorderColor := clBtnShadow; FMenuShadowColor := clBtnShadow; end; FFSelectBorderColor := FSelectBorderColor; FFSelectFontColor := FSelectFontColor; FFMenuBarColor := FMenuBarColor; FFDisabledColor := FDisabledColor; FFCheckedColor := FCheckedColor; FFSeparatorColor := FSeparatorColor; if FUseSystemColors then begin // GetSystemMenuFont(FFont); FFSelectFontColor := FFont.Color; if not Is16Bit then begin FFColor := clWhite; FFIconBackColor := clBtnFace; FFSelectColor := clWhite; FFSelectBorderColor := clHighlight; FFMenuBarColor := FFIconBackColor; FFDisabledColor := clBtnShadow; FFCheckedColor := clHighlight; FFSeparatorColor := clBtnShadow; FCheckedAreaColor := clWhite; FCheckedAreaSelectColor := clWhite; end else begin FFColor := NewColor(ACanvas, clBtnFace, 86); FFIconBackColor := NewColor(ACanvas, clBtnFace, 16); FFSelectColor := NewColor(ACanvas, clHighlight, 68); FFSelectBorderColor := clHighlight; FFMenuBarColor := clBtnFace; FFDisabledColor := NewColor(ACanvas, clBtnShadow, 10); FFSeparatorColor := NewColor(ACanvas, clBtnShadow, 25); FFCheckedColor := clHighlight; FCheckedAreaColor := NewColor(ACanvas, clHighlight, 80); FCheckedAreaSelectColor := NewColor(ACanvas, clHighlight, 50); end; end; end; procedure TXPMenu.DrawTopMenuItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; BckColor:Tcolor; IsRightToLeft: boolean); var X1, X2: integer; DefColor, HoldColor: TColor; begin X1 := ARect.Left; X2 := ARect.Right; ACanvas.brush.Style := bsSolid; ACanvas.brush.color := FFSelectColor; ACanvas.FillRect(ARect); ACanvas.Pen.Color := FFSelectBorderColor; if (not IsRightToLeft) and (Is16Bit) and (Sender is TMenuItem) then begin ACanvas.MoveTo(X1, ARect.Bottom - 1); ACanvas.LineTo(X1, ARect.Top); ACanvas.LineTo(X2 - 8, ARect.Top); ACanvas.LineTo(X2 - 8, ARect.Bottom); // ACanvas.LineTo(X1, ARect.Bottom); DefColor := FFMenuBarColor; HoldColor := GetShadeColor(ACanvas, DefColor, 10); ACanvas.Brush.Style := bsSolid; ACanvas.Brush.Color := HoldColor; ACanvas.Pen.Color := HoldColor; ACanvas.FillRect(Rect(X2 - 7, ARect.Top, X2, ARect.Bottom)); HoldColor := GetShadeColor(ACanvas, DefColor, 30); ACanvas.Brush.Color := HoldColor; ACanvas.Pen.Color := HoldColor; ACanvas.FillRect(Rect(X2 - 7, ARect.Top + 3, X2 - 2, ARect.Bottom)); HoldColor := GetShadeColor(ACanvas, DefColor, 40 + 20); ACanvas.Brush.Color := HoldColor; ACanvas.Pen.Color := HoldColor; ACanvas.FillRect(Rect(X2 - 7, ARect.Top + 5, X2 - 3, ARect.Bottom)); HoldColor := GetShadeColor(ACanvas, DefColor, 60 + 40); ACanvas.Brush.Color := HoldColor; ACanvas.Pen.Color := HoldColor; ACanvas.FillRect(Rect(X2 - 7, ARect.Top + 6, X2 - 5, ARect.Bottom)); //--- ACanvas.Pen.Color := DefColor; ACanvas.MoveTo(X2 - 5, ARect.Top + 1); ACanvas.LineTo(X2 - 1, ARect.Top + 1); ACanvas.LineTo(X2 - 1, ARect.Top + 6); ACanvas.MoveTo(X2 - 3, ARect.Top + 2); ACanvas.LineTo(X2 - 2, ARect.Top + 2); ACanvas.LineTo(X2 - 2, ARect.Top + 3); ACanvas.LineTo(X2 - 3, ARect.Top + 3); ACanvas.Pen.Color := GetShadeColor(ACanvas, DefColor, 10); ACanvas.MoveTo(X2 - 6, ARect.Top + 3); ACanvas.LineTo(X2 - 3, ARect.Top + 3); ACanvas.LineTo(X2 - 3, ARect.Top + 6); ACanvas.LineTo(X2 - 4, ARect.Top + 6); ACanvas.LineTo(X2 - 4, ARect.Top + 3); ACanvas.Pen.Color := GetShadeColor(ACanvas, DefColor, 30); ACanvas.MoveTo(X2 - 5, ARect.Top + 5); ACanvas.LineTo(X2 - 4, ARect.Top + 5); ACanvas.LineTo(X2 - 4, ARect.Top + 9); ACanvas.Pen.Color := GetShadeColor(ACanvas, DefColor, 40); ACanvas.MoveTo(X2 - 6, ARect.Top + 5); ACanvas.LineTo(X2 - 6, ARect.Top + 7); end else begin ACanvas.Pen.Color := FFSelectBorderColor; ACanvas.Brush.Color := GetShadeColor(ACanvas, BckColor, 70); ACanvas.MoveTo(X1, ARect.Bottom - 1); ACanvas.LineTo(X1, ARect.Top); ACanvas.LineTo(X2 - 3, ARect.Top); ACanvas.LineTo(X2 - 3, ARect.Bottom); ACanvas.Pen.Color := ACanvas.Brush.Color; ACanvas.FillRect(Rect(X2 - 2, ARect.Top + 2, X2, ARect.Bottom)); ACanvas.Brush.Color := BckColor; ACanvas.FillRect(Rect(X2 - 2, ARect.Top , X2, ARect.Top + 2)); end; end; procedure TXPMenu.DrawCheckedItem(FMenuItem: TMenuItem; Selected, Enabled, HasImgLstBitmap: boolean; ACanvas: TCanvas; CheckedRect: TRect); var X1, X2: integer; begin if FMenuItem.RadioItem then begin if FMenuItem.Checked then begin if Enabled then begin ACanvas.Pen.color := FFSelectBorderColor; if selected then ACanvas.Brush.Color := FCheckedAreaSelectColor else ACanvas.Brush.Color := FCheckedAreaColor; end else ACanvas.Pen.color := FFDisabledColor; ACanvas.Brush.Style := bsSolid; if HasImgLstBitmap then begin ACanvas.RoundRect(CheckedRect.Left, CheckedRect.Top, CheckedRect.Right, CheckedRect.Bottom, 6, 6); end else begin ACanvas.Ellipse(CheckedRect.Left, CheckedRect.Top, CheckedRect.Right, CheckedRect.Bottom); // +jt InflateRect(CheckedRect, -2, -2); ACanvas.Brush.color := ACanvas.Pen.Color; ACanvas.Ellipse(CheckedRect.Left, CheckedRect.Top, CheckedRect.Right, CheckedRect.Bottom); // +jt end; end; end else begin if (FMenuItem.Checked) then if (not HasImgLstBitmap) then begin if Enabled then begin ACanvas.Pen.color := FFCheckedColor; if selected then ACanvas.Brush.Color := FCheckedAreaSelectColor else ACanvas.Brush.Color := FCheckedAreaColor; ; end else ACanvas.Pen.color := FFDisabledColor; ACanvas.Brush.Style := bsSolid; ACanvas.Rectangle(CheckedRect.Left, CheckedRect.Top, CheckedRect.Right, CheckedRect.Bottom); if Enabled then ACanvas.Pen.color := clBlack else ACanvas.Pen.color := FFDisabledColor; x1 := CheckedRect.Left + 1; x2 := CheckedRect.Top + 5; ACanvas.MoveTo(x1, x2); x1 := CheckedRect.Left + 4; x2 := CheckedRect.Bottom - 2; ACanvas.LineTo(x1, x2); //-- x1 := CheckedRect.Left + 2; x2 := CheckedRect.Top + 5; ACanvas.MoveTo(x1, x2); x1 := CheckedRect.Left + 4; x2 := CheckedRect.Bottom - 3; ACanvas.LineTo(x1, x2); //-- x1 := CheckedRect.Left + 2; x2 := CheckedRect.Top + 4; ACanvas.MoveTo(x1, x2); x1 := CheckedRect.Left + 5; x2 := CheckedRect.Bottom - 3; ACanvas.LineTo(x1, x2); //----------------- x1 := CheckedRect.Left + 4; x2 := CheckedRect.Bottom - 3; ACanvas.MoveTo(x1, x2); x1 := CheckedRect.Right + 2; x2 := CheckedRect.Top - 1; ACanvas.LineTo(x1, x2); //-- x1 := CheckedRect.Left + 4; x2 := CheckedRect.Bottom - 2; ACanvas.MoveTo(x1, x2); x1 := CheckedRect.Right - 2; x2 := CheckedRect.Top + 3; ACanvas.LineTo(x1, x2); end else begin if Enabled then begin ACanvas.Pen.color := FFSelectBorderColor; if selected then ACanvas.Brush.Color := FCheckedAreaSelectColor else ACanvas.Brush.Color := FCheckedAreaColor; ; end else ACanvas.Pen.color := FFDisabledColor; ACanvas.Brush.Style := bsSolid; ACanvas.Rectangle(CheckedRect.Left, CheckedRect.Top, CheckedRect.Right, CheckedRect.Bottom); end; end; end; procedure TXPMenu.DrawTheText(Sender: TObject; txt, ShortCuttext: string; ACanvas: TCanvas; TextRect: TRect; Selected, Enabled, Default, TopMenu, IsRightToLeft: boolean; var TxtFont: TFont; TextFormat: integer); var DefColor: TColor; B: TBitmap; BRect: TRect; begin TextFormat := TextFormat + DT_EXPANDTABS; DefColor := TxtFont.Color; ACanvas.Font.Assign (TxtFont); if Selected then DefColor := FFSelectFontColor; If not Enabled then begin DefColor := FFDisabledColor; if (Sender is TToolButton) then begin TextRect.Top := TextRect.Top + ((TextRect.Bottom - TextRect.Top) - ACanvas.TextHeight('W')) div 2; B := TBitmap.Create; try B.Width := TextRect.Right - TextRect.Left; B.Height := TextRect.Bottom - TextRect.Top; BRect := Rect(0,0,B.Width, B.Height); B.Canvas.Brush.Color := ACanvas.Brush.Color; B.Canvas.FillRect (BRect); // B.Canvas.Font := FFont; //felix added for resolving font problems in Win98 //27.08 B.Canvas.Font.color := DefColor; DrawtextEx(B.Canvas.Handle, PChar(txt), Length(txt), BRect, TextFormat + DT_VCENTER, nil); ACanvas.CopyRect(TextRect, B.Canvas, BRect); finally B.Free; end; exit; end; end; if (TopMenu and Selected) then if FUseSystemColors then DefColor := TopMenuFontColor(ACanvas, FFIconBackColor); ACanvas.Font.color := DefColor; // will not affect Buttons SetBkMode(ACanvas.Handle, TRANSPARENT); if Default and Enabled then begin Inc(TextRect.Left, 1); ACanvas.Font.color := GetShadeColor(ACanvas, ACanvas.Pixels[TextRect.Left, TextRect.Top], 30); DrawtextEx(ACanvas.Handle, PChar(txt), Length(txt), TextRect, TextFormat, nil); Dec(TextRect.Left, 1); Inc(TextRect.Top, 2); Inc(TextRect.Left, 1); Inc(TextRect.Right, 1); ACanvas.Font.color := GetShadeColor(ACanvas, ACanvas.Pixels[TextRect.Left, TextRect.Top], 30); DrawtextEx(ACanvas.Handle, PChar(txt), Length(txt), TextRect, TextFormat, nil); Dec(TextRect.Top, 1); Dec(TextRect.Left, 1); Dec(TextRect.Right, 1); ACanvas.Font.color := GetShadeColor(ACanvas, ACanvas.Pixels[TextRect.Left, TextRect.Top], 40); DrawtextEx(ACanvas.Handle, PChar(txt), Length(txt), TextRect, TextFormat, nil); Inc(TextRect.Left, 1); Inc(TextRect.Right, 1); ACanvas.Font.color := GetShadeColor(ACanvas, ACanvas.Pixels[TextRect.Left, TextRect.Top], 60); DrawtextEx(ACanvas.Handle, PChar(txt), Length(txt), TextRect, TextFormat, nil); Dec(TextRect.Left, 1); Dec(TextRect.Right, 1); Dec(TextRect.Top, 1); ACanvas.Font.color := DefColor; end; DrawtextEx(ACanvas.Handle, PChar(txt), Length(txt), TextRect, TextFormat, nil); txt := ShortCutText + ' '; { if not Is16Bit then ACanvas.Font.color := DefColor else ACanvas.Font.color := GetShadeColor(ACanvas, DefColor, -40); } if IsRightToLeft then begin Inc(TextRect.Left, 10); TextFormat := DT_LEFT end else begin Dec(TextRect.Right, 10); TextFormat := DT_RIGHT; end; DrawtextEx(ACanvas.Handle, PChar(txt), Length(txt), TextRect, TextFormat, nil); end; procedure TXPMenu.DrawIcon(Sender: TObject; ACanvas: TCanvas; B: TBitmap; IconRect: Trect; Hot, Selected, Enabled, Checked, FTopMenu, IsRightToLeft: boolean); var DefColor: TColor; X, Y: integer; begin if (B <> nil) and (B.Width > 0) then begin X := IconRect.Left; Y := IconRect.Top + 1; if (Sender is TMenuItem) then begin inc(Y, 2); if FIconWidth > B.Width then X := X + ((FIconWidth - B.Width) div 2) - 1 else begin if IsRightToLeft then X := IconRect.Right - b.Width - 2 else X := IconRect.Left + 2; end; end; if FTopMenu then begin if IsRightToLeft then X := IconRect.Right - b.Width - 5 else X := IconRect.Left + 1; end; if (Hot) and (FTopMenu) and (Enabled) then if not Selected then begin dec(X, 1); dec(Y, 2); end; if (Hot) and (not FTopMenu) and (Enabled) and (not Checked) then if not Selected then begin dec(X, 1); dec(Y, 1); end; if (not Hot) and (Enabled) and (not Checked) then if Is16Bit then DimBitmap(B, FDimLevel{30}); if not Enabled then begin GrayBitmap(B, FGrayLevel ); DimBitmap(B, 40); end; if (Hot) and (Enabled) and (not Checked) then begin if (Is16Bit) and (not UseSystemColors) and (Sender is TToolButton) then DefColor := NewColor(ACanvas, FSelectColor, 68) else DefColor := FFSelectColor; DefColor := GetShadeColor(ACanvas, DefColor, 50); DrawBitmapShadow(B, ACanvas, X + 2, Y + 2, DefColor); end; B.Transparent := true; ACanvas.Draw(X, Y, B); end; end; function TXPMenu.TopMenuFontColor(ACanvas: TCanvas; Color: TColor): TColor; var r, g, b, avg: integer; begin Color := ColorToRGB(Color); r := Color and $000000FF; g := (Color and $0000FF00) shr 8; b := (Color and $00FF0000) shr 16; Avg := (r + b) div 2; if (Avg > 150) or (g > 200) then Result := FFont.Color else Result := NewColor(ACanvas, Color, 90); end; procedure TXPMenu.SetDisableSubclassing(const Value: boolean); begin if Value = FDisableSubclassing then Exit; if XPMenuManager.ActiveXPMenu = Self then XPMenuManager.UpdateActiveXPMenu(Self) else if (XPMenuManager.ActiveXPMenu = nil) and not(FDisableSubclassing) then XPMenuManager.UpdateActiveXPMenu(nil); end; procedure TXPMenu.SetActive(const Value: boolean); begin if Value = FActive then exit; FActive := Value; if FActive then InitItems(FForm, true, true) else InitItems(FForm, false, true); if FForm.Handle <> 0 then Windows.DrawMenuBar(FForm.Handle); end; procedure TXPMenu.SetAutoDetect(const Value: boolean); begin FAutoDetect := Value; end; procedure TXPMenu.SetForm(const Value: TScrollingWinControl); var Hold: boolean; begin if Value <> FForm then begin Hold := Active; Active := false; FForm := Value; if Hold then Active := True; end; end; procedure TXPMenu.SetFont(const Value: TFont); begin FFont.Assign(Value); Windows.DrawMenuBar(FForm.Handle); end; procedure TXPMenu.SetColor(const Value: TColor); begin FColor := Value; FColorsChanged := true; // +jt end; procedure TXPMenu.SetIconBackColor(const Value: TColor); begin FIconBackColor := Value; FColorsChanged := true; // +jt end; procedure TXPMenu.SetMenuBarColor(const Value: TColor); begin FMenuBarColor := Value; FColorsChanged := true; // +jt Windows.DrawMenuBar(FForm.Handle); end; procedure TXPMenu.SetCheckedColor(const Value: TColor); begin FCheckedColor := Value; FColorsChanged := true; // +jt end; procedure TXPMenu.SetSeparatorColor(const Value: TColor); begin FSeparatorColor := Value; FColorsChanged := true; // +jt end; procedure TXPMenu.SetSelectBorderColor(const Value: TColor); begin FSelectBorderColor := Value; FColorsChanged := true; // +jt end; procedure TXPMenu.SetSelectColor(const Value: TColor); begin FSelectColor := Value; FColorsChanged := true; // +jt end; procedure TXPMenu.SetDisabledColor(const Value: TColor); begin FDisabledColor := Value; FColorsChanged := true; // +jt end; procedure TXPMenu.SetSelectFontColor(const Value: TColor); begin FSelectFontColor := Value; FColorsChanged := true; // +jt end; procedure TXPMenu.SetIconWidth(const Value: integer); begin FIconWidth := Value; end; procedure TXPMenu.SetDrawSelect(const Value: boolean); begin FDrawSelect := Value; end; procedure TXPMenu.SetOverrideOwnerDraw(const Value: boolean); begin FOverrideOwnerDraw := Value; if FActive then Active := True; end; procedure TXPMenu.SetUseSystemColors(const Value: boolean); begin FUseSystemColors := Value; Windows.DrawMenuBar(FForm.Handle); end; procedure TXPMenu.SetGradient(const Value: boolean); begin FGradient := Value; end; procedure TXPMenu.SetFlatMenu(const Value: boolean); begin FFlatMenu := Value; end; procedure TXPMenu.SetXPContainers(const Value: TXPContainers); begin if Value <> FXPContainers then begin if FActive then begin FActive := false; InitItems(FForm, false, true); FActive := true; FXPContainers := Value; InitItems(FForm, true, true); end; end; FXPContainers := Value; end; procedure TXPMenu.SetXPControls(const Value: TXPControls); begin if Value <> FXPControls then begin if FActive then begin FActive := false; InitItems(FForm, false, true); FActive := true; FXPControls := Value; InitItems(FForm, true, true); end; end; FXPControls := Value; end; procedure TXPMenu.SetDrawMenuBar(const Value: boolean); begin FDrawMenuBar := Value; end; procedure TXPMenu.SetUseDimColor(const Value: boolean); begin FUseDimColor := Value; end; procedure GetSystemMenuFont(Font: TFont); var FNonCLientMetrics: TNonCLientMetrics; begin FNonCLientMetrics.cbSize := Sizeof(TNonCLientMetrics); if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @FNonCLientMetrics,0) then begin Font.Handle := CreateFontIndirect(FNonCLientMetrics.lfMenuFont); Font.Color := clMenuText; end; end; procedure TXPMenu.DrawGradient(ACanvas: TCanvas; ARect: TRect; IsRightToLeft: boolean); var i: integer; v: integer; FRect: TRect; begin fRect := ARect; V := 0; if IsRightToLeft then begin fRect.Left := fRect.Right - 1; for i := ARect.Right Downto ARect.Left do begin if (fRect.Left < ARect.Right) and (fRect.Left > ARect.Right - FIconWidth + 5) then inc(v, 3) else inc(v, 1); if v > 96 then v := 96; ACanvas.Brush.Color := NewColor(ACanvas, FFIconBackColor, v); ACanvas.FillRect(fRect); fRect.Left := fRect.Left - 1; fRect.Right := fRect.Left - 1; end; end else begin fRect.Right := fRect.Left + 1; for i := ARect.Left to ARect.Right do begin if (fRect.Left > ARect.Left) and (fRect.Left < ARect.Left + FIconWidth + 5) then inc(v, 3) else inc(v, 1); if v > 96 then v := 96; ACanvas.Brush.Color := NewColor(ACanvas, FFIconBackColor, v); ACanvas.FillRect(fRect); fRect.Left := fRect.Left + 1; fRect.Right := fRect.Left + 1; end; end; end; function MenuWindowProc(hwnd: HWND; uMsg: integer; WParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; var oldproc: integer; r: TRect; pt: TPoint; begin if(uMsg=WM_ERASEBKGND) then begin Result:=1; exit; end; if((uMsg=WM_SHOWWINDOW) and (not Boolean(WParam))) or (uMsg=WM_CLOSE) or (uMsg=WM_DESTROY) then begin SetWindowRgn(hwnd, 0,false); oldproc:=GetWindowLong(hWnd,GWL_USERDATA); SetWindowLong(hWnd,GWL_WNDPROC,oldproc); SetWindowLong(hWnd,GWL_USERDATA,0); Result:=CallWindowProc(Pointer(oldproc), hwnd, uMsg, wParam, lParam); GetWindowRect(hWnd, r); pt.x:=r.Right+2; pt.y:=r.Top+2; hWnd :=WindowFromPoint(pt); if GetWindowLong(hWnd,GWL_WNDPROC)<>integer(@MenuWindowProc) then begin pt.x:=r.Right+2; pt.y:=r.Bottom-2; hWnd :=WindowFromPoint(pt); if GetWindowLong(hWnd,GWL_WNDPROC)<>integer(@MenuWindowProc) then exit; end; InvalidateRect(hwnd,nil,false); end else Result:=CallWindowProc(Pointer(GetWindowLong(hWnd,GWL_USERDATA)), hwnd, uMsg, wParam, lParam); end; procedure TXPMenu.DrawWindowBorder(hWnd: HWND; IsRightToLeft: boolean); var WRect: TRect; dCanvas: TCanvas; wDC: HDC; // +jt regiontype: integer; // +jt r1,r2,wr,region: HRGN; // +jt rgnr: TRect; // +jt begin if (hWnd <= 0) or (FSettingWindowRng) then begin exit; end; // +jt wDC := GetWindowDC(hWnd); //GetDesktopWindow if wDC=0 then exit; // +jt FSettingWindowRng :=true; // +jt dCanvas := TCanvas.Create; try dCanvas.Handle := wDC; // +jt GetWindowRect(hWnd, WRect); // +jt WRect.Right := WRect.Right-WRect.Left; WRect.Bottom := WRect.Bottom-WRect.Top; WRect.Top:=0; WRect.Left:=0; if GetWindowLong(hWnd,GWL_WNDPROC)<>integer(@MenuWindowProc) then begin SetWindowLong(hWnd,GWL_USERDATA,GetWindowLong(hWnd,GWL_WNDPROC)); SetWindowLong(hWnd,GWL_WNDPROC,integer(@MenuWindowProc)); end; if not IsWXP then begin wr:= CreateRectRgn(0,0,0,0); regiontype := GetWindowRgn(hWnd, wr); GetRgnBox(wr,rgnr); DeleteObject(wr); if (regionType = ERROR) or (abs(rgnr.Right-WRect.Right)>5) or (abs(rgnr.Bottom-WRect.Bottom)>5) then begin region:= CreateRectRgn(0,0,0,0); r1:=CreateRectRgn(WRect.Left,WRect.Top,WRect.Right-2,WRect.Bottom-2); r2:=CreateRectRgn(WRect.Left+2,WRect.Top+2,WRect.Right,WRect.Bottom); CombineRgn(region,r1,r2,RGN_OR); DeleteObject(r1); DeleteObject(r2); SetWindowRgn(hWnd,region,true); end; // +jt Dec(WRect.Right, 2); Dec(WRect.Bottom, 2); end; // +jt dCanvas.Brush.Style := bsClear; dCanvas.Pen.Color := FMenuBorderColor; dCanvas.Rectangle(WRect.Left, WRect.Top, WRect.Right, WRect.Bottom); if IsRightToLeft then begin dCanvas.Pen.Color := FFIconBackColor; dCanvas.MoveTo(WRect.Right - 3, WRect.Top + 2); dCanvas.LineTo(WRect.Right - 2, WRect.Bottom - 1); end else begin dCanvas.Pen.Color := FFIconBackColor; dCanvas.Rectangle(WRect.Left + 1, WRect.Top + 2, WRect.Left + 3, WRect.Bottom - 1); end; // +jt StretchBlt(dCanvas.Handle,WRect.Left + 1,WRect.Top + 1,WRect.Right - WRect.Left-1,2, dCanvas.Handle,WRect.Left + 1,WRect.Top + 3,WRect.Right - WRect.Left-1,1,SRCCOPY); if IsWXP then begin StretchBlt(dCanvas.Handle,WRect.Left + 1,WRect.Bottom - 3,WRect.Right - WRect.Left-1,2, dCanvas.Handle,WRect.Left + 1,WRect.Top + 3,WRect.Right - WRect.Left-1,1, SRCCOPY); dCanvas.Pen.Color := FFColor; dCanvas.Rectangle(WRect.Right - 3, WRect.Top+1, WRect.Right - 1, WRect.Bottom-1); end; // +jt Inc(WRect.Right, 2); Inc(WRect.Bottom, 2); if not IsWXP then // +jt begin // +jt dCanvas.Pen.Color := FMenuShadowColor; dCanvas.Rectangle(WRect.Left + 2, WRect.Bottom, WRect.Right, WRect.Bottom - 2); dCanvas.Rectangle(WRect.Right - 2, WRect.Bottom, WRect.Right, WRect.Top + 2); end; // +jt finally ReleaseDC(hWnd, wDC); // +jt dCanvas.Free; FSettingWindowRng :=false; end; end; procedure TXPMenu.Notification(AComponent: TComponent; Operation: TOperation); begin if not Assigned(XPMenuManager) then Exit; // Pass the notification information to the XPMenuManager if not(csDesigning in ComponentState) then XPMenuManager.Notification(AComponent, Operation); inherited Notification(AComponent, Operation); if not FActive then exit; if not FAutoDetect then exit; if (Operation = opInsert) and ((AComponent is TMenuItem) or (AComponent is TToolButton) or (AComponent is TControlBar)) then begin if not (csDesigning in ComponentState) then InitItem(AComponent, true, true); // Tom: This will process this new component end; end; function GetShadeColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor; var r, g, b: integer; begin clr := ColorToRGB(clr); r := Clr and $000000FF; g := (Clr and $0000FF00) shr 8; b := (Clr and $00FF0000) shr 16; r := (r - value); if r < 0 then r := 0; if r > 255 then r := 255; g := (g - value) + 2; if g < 0 then g := 0; if g > 255 then g := 255; b := (b - value); if b < 0 then b := 0; if b > 255 then b := 255; //Result := Windows.GetNearestColor(ACanvas.Handle, RGB(r, g, b)); Result := RGB(r, g, b); end; function MergColor(Colors: Array of TColor): TColor; var r, g, b, i: integer; clr: TColor; begin r := 0; g:= 0; b:= 0; for i := 0 to High(Colors) do begin clr := ColorToRGB(Colors[i]); r := r + (Clr and $000000FF) div High(Colors); g := g + ((Clr and $0000FF00) shr 8) div High(Colors); b := b + ((Clr and $00FF0000) shr 16) div High(Colors); end; Result := RGB(r, g, b); end; function NewColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor; var r, g, b: integer; begin if Value > 100 then Value := 100; clr := ColorToRGB(clr); r := Clr and $000000FF; g := (Clr and $0000FF00) shr 8; b := (Clr and $00FF0000) shr 16; r := r + Round((255 - r) * (value / 100)); g := g + Round((255 - g) * (value / 100)); b := b + Round((255 - b) * (value / 100)); //Result := Windows.GetNearestColor(ACanvas.Handle, RGB(r, g, b)); Result := RGB(r, g, b); end; function GetInverseColor(AColor: TColor): TColor; begin Result := ColorToRGB(AColor) xor $FFFFFF; end; function GrayColor(ACanvas: TCanvas; Clr: TColor; Value: integer): TColor; var r, g, b, avg: integer; begin clr := ColorToRGB(clr); r := Clr and $000000FF; g := (Clr and $0000FF00) shr 8; b := (Clr and $00FF0000) shr 16; Avg := (r + g + b) div 3; Avg := Avg + Value; if Avg > 240 then Avg := 240; //if ACanvas <> nil then // Result := Windows.GetNearestColor (ACanvas.Handle,RGB(Avg, avg, avg)); Result := RGB(Avg, avg, avg); end; procedure GrayBitmap(ABitmap: TBitmap; Value: integer); var x, y: integer; LastColor1, LastColor2, Color: TColor; begin LastColor1 := 0; LastColor2 := 0; for y := 0 to ABitmap.Height do for x := 0 to ABitmap.Width do begin Color := ABitmap.Canvas.Pixels[x, y]; if Color = LastColor1 then ABitmap.Canvas.Pixels[x, y] := LastColor2 else begin LastColor2 := GrayColor(ABitmap.Canvas , Color, Value); ABitmap.Canvas.Pixels[x, y] := LastColor2; LastColor1 := Color; end; end; end; {Modified by felix@unidreamtech.com} { procedure GrayBitmap(ABitmap: TBitmap; Value: integer); var Pixel: PRGBTriple; w, h: Integer; x, y: Integer; avg: integer; begin ABitmap.PixelFormat := pf24Bit; w := ABitmap.Width; h := ABitmap.Height; for y := 0 to h - 1 do begin Pixel := ABitmap.ScanLine[y]; for x := 0 to w - 1 do begin avg := ((Pixel^.rgbtRed + Pixel^.rgbtGreen + Pixel^.rgbtBlue) div 3) + Value; if avg > 240 then avg := 240; Pixel^.rgbtRed := avg; Pixel^.rgbtGreen := avg; Pixel^.rgbtBlue := avg; Inc(Pixel); end; end; end; } procedure DimBitmap(ABitmap: TBitmap; Value: integer); var x, y: integer; LastColor1, LastColor2, Color: TColor; begin if Value > 100 then Value := 100; LastColor1 := -1; LastColor2 := -1; for y := 0 to ABitmap.Height - 1 do for x := 0 to ABitmap.Width - 1 do begin Color := ABitmap.Canvas.Pixels[x, y]; if Color = LastColor1 then ABitmap.Canvas.Pixels[x, y] := LastColor2 else begin LastColor2 := NewColor(ABitmap.Canvas, Color, Value); ABitmap.Canvas.Pixels[x, y] := LastColor2; LastColor1 := Color; end; end; end; // LIne 2647 {Modified by felix@unidreamtech.com} {works fine for 24 bit color procedure DimBitmap(ABitmap: TBitmap; Value: integer); var Pixel: PRGBTriple; w, h: Integer; x, y, c1, c2: Integer; begin ABitmap.PixelFormat := pf24Bit; w := ABitmap.Width; h := ABitmap.Height; c1 := Value * 255; c2 := 100 - Value; for y := 0 to h - 1 do begin Pixel := ABitmap.ScanLine[y]; for x := 0 to w - 1 do begin Pixel^.rgbtRed := ((c2 * Pixel^.rgbtRed) + c1) div 100; Pixel^.rgbtGreen := ((c2 * Pixel^.rgbtGreen) + c1) div 100; Pixel^.rgbtBlue := ((c2 * Pixel^.rgbtBlue) + c1) div 100; Inc(Pixel); end; end; end; } procedure DrawArrow(ACanvas: TCanvas; X, Y: integer); begin ACanvas.MoveTo(X, Y); ACanvas.LineTo(X + 5, Y); ACanvas.MoveTo(X + 1, Y + 1); ACanvas.LineTo(X + 4, Y); ACanvas.MoveTo(X + 2, Y + 2); ACanvas.LineTo(X + 3, Y); end; procedure DrawArrow(ACanvas: TCanvas; X, Y, Orientation: integer); begin case Orientation of 0: begin ACanvas.MoveTo(X, Y); ACanvas.LineTo(X, Y-1); ACanvas.MoveTo(X + 1, Y + 1); ACanvas.LineTo(X + 4, Y + 4); ACanvas.MoveTo(X, Y + 1); ACanvas.LineTo(X + 3, Y + 4); ACanvas.MoveTo(X, Y + 2); ACanvas.LineTo(X + 2, Y + 4); ACanvas.MoveTo(X - 1, Y + 1); ACanvas.LineTo(X - 4, Y + 4); ACanvas.MoveTo(X, Y + 2); ACanvas.LineTo(X - 3, Y + 4); ACanvas.MoveTo(X, Y + 1); ACanvas.LineTo(X - 2, Y + 4); end; 1: begin ACanvas.MoveTo(X, Y+3); ACanvas.LineTo(X, Y+4); ACanvas.MoveTo(X + 1, Y + 2); ACanvas.LineTo(X + 4, Y - 1); ACanvas.MoveTo(X, Y + 2); ACanvas.LineTo(X + 3, Y - 1); ACanvas.MoveTo(X, Y + 1); ACanvas.LineTo(X + 2, Y + 0); ACanvas.MoveTo(X - 1, Y + 2); ACanvas.LineTo(X - 4, Y - 1); ACanvas.MoveTo(X, Y + 2); ACanvas.LineTo(X - 3, Y - 1); ACanvas.MoveTo(X, Y + 1); ACanvas.LineTo(X - 2, Y + 0); end; end; end; procedure DrawBitmapShadow(B: TBitmap; ACanvas: TCanvas; X, Y: integer; ShadowColor: TColor); var BX, BY: integer; TransparentColor: TColor; begin TransparentColor := B.Canvas.Pixels[0, B.Height - 1]; for BY := 0 to B.Height - 1 do for BX := 0 to B.Width - 1 do begin if B.Canvas.Pixels[BX, BY] <> TransparentColor then ACanvas.Pixels[X + BX, Y + BY] := ShadowColor; end; end; procedure DrawCheckMark(ACanvas: TCanvas; X, Y: integer); begin Inc(X, 2); Dec(Y, 3); ACanvas.MoveTo(X , Y - 2); ACanvas.LineTo(X + 2, Y ); ACanvas.LineTo(X + 7, Y - 5); ACanvas.MoveTo(X , Y - 3); ACanvas.LineTo(X + 2, Y - 1); ACanvas.LineTo(X + 7, Y - 6); ACanvas.MoveTo(X , Y - 4); ACanvas.LineTo(X + 2, Y - 2); ACanvas.LineTo(X + 7, Y - 7); end; { TCustomComboSubClass } //By Heath Provost (Nov 20, 2001) // ComboBox Subclass WndProc. // Message processing to allow control to repond to // messages needed to paint using Office XP style. procedure TControlSubClass.ControlSubClass(var Message: TMessage); begin //Call original WindowProc FIRST. We are trying to emulate inheritance, so //original WindowProc must handle all messages before we do. if ((Message.Msg = WM_PAINT) and ((Control is TGraphicControl))) or ((Control.ClassName = 'TDBLookupComboBox') and (Message.Msg = WM_NCPAINT)) then Message.Result := 1 else //: "Marcus Paulo Tavares" orgWindowProc(Message); if (XPMenu <> nil) and (not XPMenu.FActive) then begin try Message.Result := 1; if Control <> nil then begin Control.WindowProc := orgWindowProc; if Control is TCustomEdit then TEdit(Control).Ctl3D := FCtl3D; if Control is TCustomRichEdit then TRichEdit(Control).BorderStyle := FBorderStyle; if Control.ClassName = 'TDBLookupComboBox' then TComboBox(Control).Ctl3D := FCtl3D; if Control is TCustomListBox then TListBox(Control).BorderStyle := FBorderStyle; if Control is TCustomListView then TListView(Control).BorderStyle := FBorderStyle; if Control is TCustomTreeView then TTreeView(Control).BorderStyle := FBorderStyle; Control := nil; Free; end; exit; except exit; end; end; FMsg := Message.Msg; case Message.Msg of EM_GETMODIFY, // For edit CM_INVALIDATE: begin FBuilding := true end; CM_PARENTCOLORCHANGED: begin PaintControlXP; end; WM_DESTROY: begin if not FBuilding then begin try if Control <> nil then begin Control.WindowProc := orgWindowProc; FBuilding := false; Free; end; except end; //FBuilding := false; end; Exit; end; WM_PAINT: begin FBuilding := false; PaintControlXP; end; CM_MOUSEENTER: if TControl(Control).Enabled then begin // if FmouseInControl then exit; FmouseInControl := true; if Control is TGraphicControl then begin Control.Repaint; exit; end; PaintControlXP; {if Control is TGraphicControl then begin if not FMouseInControl and Control.Enabled and (GetCapture = 0) then begin FMouseInControl := True; Control.Repaint; end; end else begin FmouseInControl := true; PaintControlXP; end;} end; CM_MOUSELEAVE: if TControl(Control).Enabled then begin FmouseInControl := false; if Control is TGraphicControl then begin Control.Invalidate; exit; end; PaintControlXP; {if Control is TGraphicControl then begin if FMouseInControl and Control.Enabled then begin FMouseInControl := False; Control.Invalidate; end; end else begin FmouseInControl := false; PaintControlXP; end;} end; WM_MOUSEMOVE: begin if TControl(Control).Enabled and (Control.ClassName = 'TUpDown') then PaintControlXP; end; WM_LBUTTONDOWN: begin FLButtonBressed := true; PaintControlXP; end; WM_LBUTTONUP: begin FLButtonBressed := false; if Control is TGraphicControl then begin Control.Repaint; exit; end; PaintControlXP; end; WM_KEYDOWN: if Message.WParam = VK_SPACE then begin FBressed := true; if not FIsKeyDown then PaintControlXP; FIsKeyDown := true; end; WM_KEYUP: if Message.WParam = VK_SPACE then begin FBressed := false; FIsKeyDown := false; PaintControlXP; end; WM_SETFOCUS: begin FmouseInControl := true; PaintControlXP; end; WM_KILLFOCUS: begin FmouseInControl := false; PaintControlXP; end; CM_FOCUSCHANGED: //?? PaintControlXP; CM_EXIT: begin FmouseInControl := false; PaintControlXP; end; BM_SETCHECK: begin FmouseInControl := false; PaintControlXP; end; BM_GETCHECK: begin FmouseInControl := false; PaintControlXP; end; CM_ENABLEDCHANGED: begin if (Message.WParam = 0) then FmouseInControl := false;//Dirk Bottcher PaintControlXP; end; CM_TEXTCHANGED: begin PaintControlXP; end; CM_CTL3DCHANGED, CM_PARENTCTL3DCHANGED: begin FBuilding := true; end; WM_LBUTTONDBLCLK: //for button, check begin if (Control is TButton) or (Control is TSpeedButton) or (Control is TCheckBox) then Control.Perform(WM_LBUTTONDOWN, Message.WParam , Longint(Message.LParam)); end; {CN_DRAWITEM,} BM_SETSTATE: begin PaintControlXP; // button end; WM_WINDOWPOSCHANGED, CN_PARENTNOTIFY: // Moving From parent to other begin FBuilding := true end; WM_NCPAINT: begin if (Control is TCustomListBox) or (Control is TCustomTreeView) or (Control is TCustomListBox) then PaintNCWinControl; end; end; end; // changes added by Heath Provost (Nov 20, 2001) { TCustomComboSubClass } // paints an overlay over the control to make it mimic // Office XP style. procedure TControlSubClass.PaintControlXP; begin If Control is TWinControl then FIsFocused := TWinControl(Control).Focused else FIsFocused := false; {$IFDEF VER6U} if (Control is TCustomCombo) then PaintCombo; {$ELSE} if (Control is TCustomComboBox) then PaintCombo; {$ENDIF} if Control.ClassName = 'TDBLookupComboBox' then PaintDBLookupCombo; if Control is TCustomRichEdit then PaintRichEdit else if Control is TCustomEdit then PaintEdit; if Control is TCustomCheckBox then PaintCheckBox; if Control is TRadioButton then PaintRadio; if Control is TBitBtn then PaintBitButn else if Control is TButton then PaintButton; if Control is TUpDown then PaintUpDownButton; if Control is TSpeedButton then if Control.Visible then PaintSpeedButton; if Control is TCustomPanel then PaintPanel; if Control is TCustomGroupBox then PaintGroupBox; if (Control is TCustomListBox) or (Control is TCustomTreeView) or (Control is TCustomListView) then PaintNCWinControl; if Control is TProgressBar then PaintProgressBar; if Control is TCustomHotKey then PaintHotKey; { if Control is TDrawGrid then PaintGrid; } end; procedure TControlSubClass.PaintCombo; var C: TControlCanvas; R: TRect; SelectColor, BorderColor, ArrowColor: TColor; X: integer; begin C := TControlCanvas.Create; try C.Control := Control; // XPMenu.SetGlobalColor(C); if Control.Enabled then ArrowColor := clBlack else ArrowColor := clWhite; if (FmouseinControl) then begin borderColor := XPMenu.FFSelectBorderColor; SelectColor := XPMenu.FFSelectColor; end else begin borderColor := TComboBox(Control).Color; if Control.Tag = 1000 then SelectColor := NewColor(C, TControl(Control).Parent.Brush.Color, xpMenu.FDimParentColor) else selectColor := clBtnFace; end; if (not FmouseinControl) and (FIsFocused) then begin borderColor := NewColor(C, XPMenu.FFSelectBorderColor,60); SelectColor := XPMenu.FCheckedAreaColor; end; R := Control.ClientRect; C.Brush.Color := Control.Parent.Brush.Color; C.FrameRect(R); InflateRect(R, -1, -1); C.Pen.Color := C.Brush.Color; C.MoveTo(R.Left, R.Top); C.LineTo(R.Right, R.Top); InflateRect(R, 0, -1); if ( FmouseinControl or FIsFocused) then InflateRect(R, 1, 1); C.Brush.Color := TComboBox(Control).Color;; C.FrameRect(R); Inc(R.Bottom,1); C.Brush.Color := BorderColor; C.FrameRect(R); {$IFDEF VER6U} if TCustomCombo(Control).DroppedDown then {$ELSE} if TCustomComboBox(Control).DroppedDown then {$ENDIF} begin BorderColor := XPMenu.FFSelectBorderColor; ArrowColor := clWhite; SelectColor := XPMenu.FCheckedAreaSelectColor ; end; if TComboBox(Control).style <> csSimple then begin InflateRect(R, -1, -1); if Control.BiDiMode = bdRightToLeft then R.Right := R.Left + GetSystemMetrics(SM_CXHTHUMB) + 1 else R.Left := R.Right - GetSystemMetrics(SM_CXHTHUMB) - 1; if ( FmouseinControl or FIsFocused) then begin if Control.BiDiMode = bdRightToLeft then Inc(R.Right, 2) else Dec(R.Left, 1); end; C.Brush.Color := SelectColor; C.FillRect(R); if Control.BiDiMode = bdRightToLeft then R.Left := R.Right - 5 else R.Right := R.Left + 5; C.Brush.Color := TComboBox(Control).Color; C.FillRect(R); C.Pen.Color := BorderColor; if Control.BiDiMode = bdRightToLeft then begin C.Moveto(R.Left, R.Top); C.LineTo(R.Left, R.Bottom); end else begin C.Moveto(R.Right, R.Top); C.LineTo(R.Right, R.Bottom); end; C.Pen.Color := arrowColor; R := Control.ClientRect; if Control.BiDiMode = bdRightToLeft then X := R.Left + 5 else X := R.Right - 10; C.Moveto(X + 0, R.Top + 10); C.LineTo(X + 5, R.Top + 10); C.Moveto(X + 1, R.Top + 11); C.LineTo(X + 4, R.Top + 11); C.Moveto(X + 2, R.Top + 12); C.LineTo(X + 3, R.Top + 12); end; finally C.Free; end; end; procedure TControlSubClass.PaintDBLookupCombo; var C: TControlCanvas; R: TRect; FrameColor, SelectColor, BorderColor, ArrowColor: TColor; X: integer; DC: HDC; begin C := TControlCanvas.Create; DC := GetWindowDC(TWinControl(Control).Handle); try C.Control := Control; C.Handle := DC; if TComboBox(Control).Ctl3D then begin FBuilding := true; TComboBox(Control).Ctl3D := false; end; //XPMenu.SetGlobalColor(C); if Control.Enabled then ArrowColor := clBlack else ArrowColor := clWhite; if (FmouseinControl) then begin FrameColor := XPMenu.FFSelectBorderColor; borderColor := XPMenu.FFSelectBorderColor; SelectColor := XPMenu.FFSelectColor; end else begin FrameColor := GetShadeColor(C, Control.Parent.Brush.Color, 60); borderColor := NewColor(C, XPMenu.FFSelectBorderColor,60); selectColor := clBtnFace; end; if (not FmouseinControl) and (FIsFocused) then begin FrameColor := GetShadeColor(C, Control.Parent.Brush.Color, 60); borderColor := NewColor(C, XPMenu.FFSelectBorderColor,60); SelectColor := XPMenu.FCheckedAreaColor; end; R := Rect(0, 0, Control.Width, Control.Height); C.Brush.Color := TComboBox(Control).Color; C.Brush.Color := FrameColor; C.FrameRect(R); R := Control.ClientRect; // Move the thumb one pixel to the right and one pixel down OffsetRect(R, 1, 1); C.Brush.Color := TComboBox(Control).Color; C.FrameRect(R); {$IFDEF VER6U} if TCustomCombo(Control).DroppedDown then {$ELSE} if TCustomComboBox(Control).DroppedDown then {$ENDIF} begin BorderColor := XPMenu.FFSelectBorderColor; ArrowColor := clWhite; SelectColor := XPMenu.FCheckedAreaSelectColor ; end; if TComboBox(Control).style <> csSimple then begin InflateRect(R, -1, -1); if Control.BiDiMode = bdRightToLeft then R.Right := R.Left + GetSystemMetrics(SM_CXHTHUMB) + 1 else R.Left := R.Right - GetSystemMetrics(SM_CXHTHUMB) - 1; if ( FmouseinControl or FIsFocused) then begin if Control.BiDiMode = bdRightToLeft then Inc(R.Right, 1) else Dec(R.Left, 1); end; C.Brush.Color := SelectColor; C.FillRect(R); C.Brush.Color := BorderColor; C.FrameRect(R); if Control.BiDiMode = bdRightToLeft then R.Left := R.Right - 5 else R.Right := R.Left + 5; C.Brush.Color := TComboBox(Control).Color; C.FillRect(R); C.Pen.Color := BorderColor; if Control.BiDiMode = bdRightToLeft then begin C.Moveto(R.Left, R.Top); C.LineTo(R.Left, R.Bottom); end else begin C.Moveto(R.Right, R.Top); C.LineTo(R.Right, R.Bottom); end; C.Pen.Color := arrowColor; R := Control.ClientRect; if Control.BiDiMode = bdRightToLeft then X := R.Left + 5 else X := R.Right - 9; // Changed by Uwe Runkel, uwe@runkel.info // Changed value from 10 to 9 because the thumb has // moved one pixel to the right C.Moveto(X + 0, R.Top + 8); C.LineTo(X + 5, R.Top + 8); C.Moveto(X + 1, R.Top + 9); C.LineTo(X + 4, R.Top + 9); C.Moveto(X + 2, R.Top + 10); C.LineTo(X + 3, R.Top + 10); end; finally C.Free; ReleaseDC(TWinControl(Control).Handle, DC); end; end; procedure TControlSubClass.PaintEdit; var C: TControlCanvas; R: TRect; BorderColor: TColor; begin C := TControlCanvas.Create; try C.Control := Control; //XPMenu.SetGlobalColor(C); if TEdit(Control).Ctl3D <> false then begin FBuilding := true; TEdit(Control).Ctl3D := false; end; if (FmouseinControl) or (FIsFocused) then borderColor := NewColor(C, XPMenu.FFSelectBorderColor, 60) else borderColor := GetShadeColor(C, Control.Parent.Brush.Color, 60); if FBorderStyle = bsNone then begin if (FmouseinControl) and (not FIsFocused) then //borderColor := NewColor(C, Control.Parent.Brush.Color, 60) borderColor := NewColor(C, MergColor([TEdit(Control).Color,Control.Parent.Brush.Color]), 40) else borderColor := TEdit(Control).Color; end; R := Control.ClientRect; C.Pen.Color := BorderColor; C.Brush.Style := bsClear; C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); finally C.Free; end; end; procedure TControlSubClass.PaintRichEdit; var C: TControlCanvas; R: TRect; BorderColor: TColor; begin C := TControlCanvas.Create; try C.Control := Control.Parent; R := Control.BoundsRect; InflateRect(R, 1, 1); if FBorderStyle = bsSingle then begin FBuilding := true; TRichEdit(Control).BorderStyle := bsNone; if TRichEdit(Control).BorderWidth < 2 then TRichEdit(Control).BorderWidth := 2; end; if (FmouseinControl) or (FIsFocused) then borderColor := NewColor(C, XPMenu.FFSelectBorderColor,60) else begin if FBorderStyle = bsSingle then borderColor := GetShadeColor(C, Control.Parent.Brush.Color, 60) else borderColor := Control.Parent.Brush.Color; end; Frame3D(C, R, borderColor, borderColor, 1); finally C.Free; end; end; procedure TControlSubClass.PaintCheckBox; var C: TControlCanvas; R: TRect; SelectColor, BorderColor: TColor; begin C := TControlCanvas.Create; try C.Control := Control; if FMouseInControl then begin SelectColor := XPMenu.FFSelectColor; BorderColor := xpMenu.FFSelectBorderColor; end else begin SelectColor := clWindow; BorderColor := clBtnShadow; end; if (FIsFocused) then begin SelectColor := XPMenu.FFSelectColor; BorderColor := xpMenu.FFSelectBorderColor; end; if (FBressed) or (FLButtonBressed ) then SelectColor := XPMenu.FCheckedAreaSelectColor ; if TCheckBox(Control).State = cbGrayed then SelectColor := clSilver ; R := Control.ClientRect; InflateRect(R, 0, -3); R.Top := R.Top + ((R.Bottom - R.Top - GetSystemMetrics(SM_CXHTHUMB)) div 2); R.Bottom := R.Top + GetSystemMetrics(SM_CXHTHUMB); if ((Control.BiDiMode = bdRightToLeft) and (TCheckBox(Control).Alignment = taRightJustify)) or ((Control.BiDiMode = bdLeftToRight) and (TCheckBox(Control).Alignment = taLeftJustify)) then R.Left := R.Right - GetSystemMetrics(SM_CXHTHUMB) + 1 else if ((Control.BiDiMode = bdLeftToRight) and (TCheckBox(Control).Alignment = taRightJustify)) or ((Control.BiDiMode = bdRightToLeft) and (TCheckBox(Control).Alignment = taLeftJustify)) then R.Right := R.Left + GetSystemMetrics(SM_CXHTHUMB) - 1; C.Brush.Color := TCheckBox(Control).Color; C.FillRect(R); InflateRect(R, -2, -2); C.Brush.Color := SelectColor; C.Pen.Color := BorderColor; C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); if (TCheckBox(Control).Checked) or (TCheckBox(Control).State = cbGrayed) then begin if Control.Enabled then begin if (FBressed) or (FLButtonBressed ) then C.Pen.color := clWindow else begin if TCheckBox(Control).State = cbGrayed then C.Pen.color := clGray else C.Pen.color := clHighlight; end; end else C.Pen.color := xpMenu.FFDisabledColor; DrawCheckMark(C, R.Left, R.Bottom ) end; finally C.Free; end; end; procedure TControlSubClass.PaintRadio; var C: TControlCanvas; R: TRect; SelectColor, BorderColor: TColor; begin C := TControlCanvas.Create; try C.Control := Control; if FMouseInControl then begin SelectColor := XPMenu.FFSelectColor; BorderColor := xpMenu.FFSelectBorderColor;; end else begin SelectColor := clWindow; BorderColor := clBtnShadow; end; if (FIsFocused) then SelectColor := XPMenu.FFSelectColor; R := Control.ClientRect; InflateRect(R, 0, -4); R.Top := R.Top + ((R.Bottom - R.Top - GetSystemMetrics(SM_CXHTHUMB)) div 2); R.Bottom := R.Top + GetSystemMetrics(SM_CXHTHUMB)-1; if ((Control.BiDiMode = bdRightToLeft) and (TCheckBox(Control).Alignment = taRightJustify)) or ((Control.BiDiMode = bdLeftToRight) and (TCheckBox(Control).Alignment = taLeftJustify)) then R.Left := R.Right - GetSystemMetrics(SM_CXHTHUMB) + 1 else if ((Control.BiDiMode = bdLeftToRight) and (TCheckBox(Control).Alignment = taRightJustify)) or ((Control.BiDiMode = bdRightToLeft) and (TCheckBox(Control).Alignment = taLeftJustify)) then R.Right := R.Left + GetSystemMetrics(SM_CXHTHUMB) - 1; C.Brush.Color := TCheckBox(Control).Color; C.FillRect(R); InflateRect(R, -2, -2); C.Brush.Color := SelectColor; C.Pen.Color := BorderColor; C.Ellipse(R.Left, R.Top, R.Right, R.Bottom); if TRadioButton(Control).Checked then begin InflateRect(R, -2, -2); if Control.Enabled then C.Brush.Color := clHighlight else C.Brush.color := xpMenu.FFDisabledColor; C.Pen.Color := C.Brush.Color; C.Ellipse(R.Left, R.Top, R.Right, R.Bottom); end; finally C.Free; end; end; procedure TControlSubClass.PaintButton; var C: TControlCanvas; R: TRect; SelectColor, BorderColor: TColor; Txt: string; TextRect: TRect; TxtFont: TFont; CWidth, CHeight, TWidth, THeight: integer; TextFormat: integer; begin C := TControlCanvas.Create; try C.Control := Control; if (FMouseInControl) then begin if Control.Tag = 1000 then // UseParentColor SelectColor := NewColor(C, TControl(Control).Parent.Brush.Color, xpMenu.FDimParentColorSelect) else SelectColor := NewColor(C, clBtnFace, xpMenu.FDimParentColorSelect); BorderColor := NewColor(C, XPMenu.FFSelectBorderColor,60); end else begin if Control.Tag = 1000 then SelectColor := NewColor(C, TControl(Control).Parent.Brush.Color, xpMenu.FDimParentColor) else SelectColor := XPMenu.FFIconBackColor; BorderColor := clBtnShadow; end; if (not FmouseinControl) and (FIsFocused) then begin BorderColor := NewColor(C, XPMenu.FFSelectBorderColor,60); end; TextFormat := DT_CENTER + DT_VCENTER; R := Control.ClientRect; CWidth := (R.Right - R.Left); CHeight := (R.Bottom - R.Top); C.Brush.Color := Control.Parent.Brush.Color; C.FillRect(R); C.Brush.Color := SelectColor; C.Pen.Color := NewColor(C, BorderColor, 30); C.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 4, 4); if TControl(Control).Enabled then if FBressed or (FLButtonBressed and FmouseinControl) {or FBressed} then begin C.Pen.Color := GetShadeColor(C, BorderColor, 50); C.MoveTo(R.Left , R.Bottom - 2); C.LineTo(R.Left , R.Top + 1); C.LineTo(R.Left + 1, R.Top ); C.LineTo(R.Right - 1 , R.Top ); end else begin C.Pen.Color := GetShadeColor(C, BorderColor, 50); C.MoveTo(R.Right - 1, R.Top + 1); C.LineTo(R.Right - 1, R.Bottom - 2); C.LineTo(R.Right - 2, R.Bottom - 1); C.LineTo(R.Left , R.Bottom - 1); end; Txt := TButton(Control).Caption; TextRect := R; TxtFont := TButton(Control).Font; C.Font.Assign (TxtFont); if TButton(Control).IsRightToLeft then TextFormat := TextFormat + DT_RTLREADING; //--- //"Holger Lembke" if (Txt <> '') then begin FillChar(TextRect, SizeOf(TextRect),0); DrawText(C.Handle, PChar(Txt), Length(Txt), TextRect, DT_CALCRECT + control.DrawTextBiDiModeFlags(0)); TWidth := TextRect.Right; THeight := TextRect.Bottom; end else begin TWidth := 0; THeight := 0; end; //--- TextRect.Left := (CWidth - (TWidth)) div 2; TextRect.Right := TextRect.Left + TWidth; TextRect.Top := (CHeight - (THeight)) div 2; TextRect.Bottom := TextRect.Top + THeight; XPMenu.DrawTheText(Control, Txt, '', C, TextRect, false, TControl(Control).Enabled, TButton(Control).Default, false, TControl(Control).IsRightToLeft, TxtFont, TextFormat); finally C.Free; end; end; procedure TControlSubClass.PaintSpeedButton; var C: TControlCanvas; R: TRect; SelectColor, BorderColor: TColor; Txt: string; TextRect, IconRect: TRect; TxtFont: TFont; B, BF: TBitmap; CWidth, CHeight, BWidth, BHeight, TWidth, THeight, Space, NumGlyphs, Offset: integer; TextFormat: integer; FDown, FFlat, FTransparent: boolean; FLayout: TButtonLayout; P: TPoint; begin C := TControlCanvas.Create; try C.Control := Control; FDown := TSpeedButton(Control).Down; FFlat := TSpeedButton(Control).Flat; FTransparent := TSpeedButton(Control).Transparent; NumGlyphs := TSpeedButton(Control).NumGlyphs; //---------- if FFlat then if FMouseInControl then begin p := Mouse.CursorPos; P := Control.ScreenToClient(P); R := Control.ClientRect; FMouseInControl := (p.x >= R.Left) and (p.x <= R.Right) and (p.y >= R.Top) and (p.y <= R.Bottom); end; //---------- if (FMouseInControl) then begin if Control.Tag = 1000 then // UseParentColor begin SelectColor := NewColor(C, TControl(Control).Parent.Brush.Color, xpMenu.FDimParentColorSelect); if FFlat then SelectColor := xpMenu.FFSelectColor ; end else begin SelectColor := NewColor(C, clBtnFace, xpMenu.FDimParentColorSelect); if FFlat then SelectColor := xpMenu.FFSelectColor ; end; BorderColor := NewColor(C, XPMenu.FFSelectBorderColor,60); end else begin if Control.Tag = 1000 then SelectColor := NewColor(C, TControl(Control).Parent.Brush.Color, xpMenu.FDimParentColor) else SelectColor := XPMenu.FFIconBackColor; if FFlat then SelectColor := TControl(Control).Parent.Brush.Color; if (Control.ClassName = 'TNavButton') and FFlat then begin SelectColor := TControl(Control).Parent.Brush.Color; end; BorderColor := clBtnShadow; end; if FDown then begin SelectColor := XPMenu.FCheckedAreaColor; BorderColor := xpMenu.FFSelectBorderColor; end; if FDown and FMouseInControl then begin SelectColor := XPMenu.FCheckedAreaSelectColor; BorderColor := xpMenu.FFSelectBorderColor; end; if not TControl(Control).Enabled then BorderColor := clBtnShadow; TextFormat := + DT_CENTER + DT_VCENTER;; R := Control.ClientRect; CWidth := (R.Right - R.Left); CHeight := (R.Bottom - R.Top); if (FDown or FMouseInControl) and FTransparent then begin BF := TBitmap.Create; try BF.Width := R.Right - R.Left; BF.Height := R.Bottom - R.Top; if FFlat then begin if GetDeviceCaps(C.Handle, BITSPIXEL) > 16 then BF.Canvas.Brush.Color := NewColor(C, xpMenu.FFSelectColor, 20) else BF.Canvas.Brush.Color := SelectColor; end else begin if GetDeviceCaps(C.Handle, BITSPIXEL) > 16 then BF.Canvas.Brush.Color := NewColor(C, SelectColor, 5) else BF.Canvas.Brush.Color := SelectColor; end; BF.Canvas.FillRect (R); BitBlt(C.handle, R.Left, R.Top, R.Right - R.left, R.Bottom - R.top, BF.Canvas.Handle, 0, 0, SRCAND); finally BF.Free; end; end; C.Brush.Color := SelectColor; if not FTransparent then c.FillRect (R); if Control.ClassName = 'TNavButton' then begin c.FillRect (R); end; C.Pen.Color := NewColor(C, BorderColor, 30); if (FFlat) and (not FTransparent) and (not FDown) and (not FMouseInControl) then C.Pen.Color := C.Brush.Color; if FTransparent then C.Brush.Style := bsClear; if ((FTransparent) and (FMouseInControl)) or ((FTransparent) and (FDown)) or ((not FTransparent )) or ((not FFlat)) then begin C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); end; if TControl(Control).Enabled then begin if (FFlat) then begin if (FLButtonBressed ) or (FDown) then begin C.Pen.Color := BorderColor; C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); C.Pen.Color := GetShadeColor(C, BorderColor, 50); C.MoveTo(R.Left , R.Bottom - 1); C.LineTo(R.Left , R.Top ); C.LineTo(R.Right , R.Top ); end else if (FMouseInControl) then begin C.Pen.Color := xpmenu.FFSelectBorderColor; C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); end; end; if (not FFlat) then if (FLButtonBressed ) or (FDown) then begin C.Pen.Color := GetShadeColor(C, BorderColor, 50); C.MoveTo(R.Left , R.Bottom - 1); C.LineTo(R.Left , R.Top ); C.LineTo(R.Right , R.Top ); end else begin C.Pen.Color := GetShadeColor(C, BorderColor, 50); C.MoveTo(R.Right - 1, R.Top ); C.LineTo(R.Right - 1, R.Bottom - 1); C.LineTo(R.Left , R.Bottom - 1); end; end; Txt := TSpeedButton(Control).Caption; TextRect := R; TxtFont := TSpeedButton(Control).Font; C.Font.Assign (TxtFont); TWidth := C.TextWidth(Txt); //THeight := C.TextHeight(Txt); TextRect.Left := (CWidth - TWidth) div 2; if TControl(Control).IsRightToLeft then TextFormat := TextFormat + DT_RTLREADING; //--- //"Holger Lembke" if (Txt <> '') then begin FillChar(TextRect, sizeof(TextRect),0); DrawText(C.Handle, PChar(Txt), Length(Txt), TextRect, DT_CALCRECT + control.DrawTextBiDiModeFlags(0)); TWidth := TextRect.Right; THeight := TextRect.Bottom; end else begin TWidth := 0; THeight := 0; end; //--- if (TSpeedButton(Control).Glyph <> nil) then begin B := TBitmap.Create; BWidth := TSpeedButton(Control).Glyph.Width div TSpeedButton(Control).NumGlyphs; BHeight := TSpeedButton(Control).Glyph.Height; B.Width := BWidth; B.Height := BHeight; if Length(TSpeedButton(Control).Caption) > 0 then Space := TSpeedButton(Control).Spacing else Space := 0; IconRect := Rect(R.Left , R.Top, R.Left+BWidth, R.Top + BHeight); // Suggested by : "Holger Lembke" Offset := 1; if (not Control.Enabled) and (NumGlyphs > 1) then Offset := 2; if (FLButtonBressed) and (NumGlyphs > 2) then Offset := 3; if (FDown) and (NumGlyphs > 3) then Offset := 4; B.Canvas.CopyRect (Rect(0, 0, BWidth, BHeight), TSpeedButton(Control).Glyph.Canvas, Rect((BWidth * Offset) - BWidth, 0, BWidth * Offset, BHeight)); FLayout := TSpeedButton(Control).Layout; if Control.IsRightToLeft then begin if FLayout = blGlyphLeft then FLayout := blGlyphRight else if FLayout = blGlyphRight then FLayout := blGlyphLeft; end; case FLayout of blGlyphLeft: begin IconRect.Left := (CWidth - (BWidth + Space + TWidth)) div 2; IconRect.Right := IconRect.Left + BWidth; IconRect.Top := ((CHeight - (BHeight)) div 2) - 1; IconRect.Bottom := IconRect.Top + BHeight; TextRect.Left := IconRect.Right + Space; TextRect.Right := TextRect.Left + TWidth; TextRect.Top := (CHeight - (THeight)) div 2; TextRect.Bottom := TextRect.Top + THeight; end; blGlyphRight: begin IconRect.Right := (CWidth + (BWidth + Space + TWidth)) div 2; IconRect.Left := IconRect.Right - BWidth; IconRect.Top := (CHeight - (BHeight)) div 2; IconRect.Bottom := IconRect.Top + BHeight; TextRect.Right := IconRect.Left - Space; TextRect.Left := TextRect.Right - TWidth; TextRect.Top := (CHeight - (THeight)) div 2; TextRect.Bottom := TextRect.Top + THeight; end; blGlyphTop: begin IconRect.Left := (CWidth - BWidth) div 2; IconRect.Right := IconRect.Left + BWidth; IconRect.Top := (CHeight - (BHeight + Space + THeight)) div 2; IconRect.Bottom := IconRect.Top + BHeight; TextRect.Left := (CWidth - (TWidth)) div 2; TextRect.Right := TextRect.Left + TWidth; TextRect.Top := IconRect.Bottom + Space; TextRect.Bottom := TextRect.Top + THeight; end; blGlyphBottom: begin IconRect.Left := (CWidth - BWidth) div 2; IconRect.Right := IconRect.Left + BWidth; IconRect.Bottom := (CHeight + (BHeight + Space + THeight)) div 2; IconRect.Top := IconRect.Bottom - BHeight; TextRect.Left := (CWidth - (TWidth)) div 2; TextRect.Right := TextRect.Left + TWidth; TextRect.Bottom := IconRect.Top - Space; TextRect.Top := TextRect.Bottom - THeight; end; end; xpMenu.DrawIcon(Control, C , B, IconRect, FMouseinControl, FIsFocused, TControl(Control).Enabled, FDown or FLButtonBressed, false, TControl(Control).IsRightToLeft); B.Free; end; XPMenu.DrawTheText(Control, Txt, '', C, TextRect, false, TControl(Control).Enabled, false, false, TControl(Control).IsRightToLeft, TxtFont, TextFormat); finally C.Free; end; end; procedure TControlSubClass.PaintBitButn; var C: TControlCanvas; R: TRect; SelectColor, BorderColor: TColor; Txt: string; TextRect, IconRect: TRect; TxtFont: TFont; B: TBitmap; CWidth, CHeight, BWidth, BHeight, TWidth, THeight, Space: integer; TextFormat: integer; begin C := TControlCanvas.Create; try C.Control := Control; if (FMouseInControl or FBressed) then begin if (Control.Tag and 1000) = 1000 then SelectColor := NewColor(C, TControl(Control).Parent.Brush.Color, xpMenu.FDimParentColorSelect) else SelectColor := NewColor(C, clBtnFace, xpMenu.FDimParentColorSelect); BorderColor := NewColor(C, XPMenu.FFSelectBorderColor,60); end else begin if (Control.Tag and 1000) = 1000 then SelectColor := NewColor(C, TControl(Control).Parent.Brush.Color, xpMenu.FDimParentColor) else SelectColor := XPMenu.FFIconBackColor; BorderColor := clBtnShadow; end; if (not FmouseinControl) and (FIsFocused) then begin BorderColor := NewColor(C, XPMenu.FFSelectBorderColor,60); end; if (Control.Tag and 1001) = 1001 then begin BorderColor := SelectColor; end; TextFormat := + DT_CENTER + DT_VCENTER; R := Control.ClientRect; CWidth := (R.Right - R.Left); CHeight := (R.Bottom - R.Top); C.Brush.Color := Control.Parent.Brush.Color; C.FillRect(R); C.Brush.Color := SelectColor; C.Pen.Color := NewColor(C, BorderColor, 30); c.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 4, 4); if (Control.Tag and 1001) <> 1001 then begin if TControl(Control).Enabled then if (FLButtonBressed and FmouseinControl) or (FBressed) then begin C.Pen.Color := GetShadeColor(C, BorderColor, 50); C.MoveTo(R.Left , R.Bottom - 2); C.LineTo(R.Left , R.Top + 1); C.LineTo(R.Left + 1, R.Top ); C.LineTo(R.Right - 1 , R.Top ); end else begin C.Pen.Color := GetShadeColor(C, BorderColor, 50); C.MoveTo(R.Right - 1, R.Top + 1); C.LineTo(R.Right - 1, R.Bottom - 2); C.LineTo(R.Right - 2, R.Bottom - 1); C.LineTo(R.Left , R.Bottom - 1); end; end; Txt := TBitBtn(Control).Caption; TextRect := R; TxtFont := TBitBtn(Control).Font; C.Font.Assign (TxtFont); TWidth := C.TextWidth(Txt); TextRect.Left := (CWidth - TWidth) div 2; //--- //"Holger Lembke" if (Txt <> '') then begin FillChar(TextRect, sizeof(TextRect),0); DrawText(C.Handle, PChar(Txt), Length(Txt), TextRect, DT_CALCRECT + control.DrawTextBiDiModeFlags(0)); TWidth := TextRect.Right; THeight := TextRect.Bottom; end else begin TWidth := 0; THeight := 0; end; //--- if TBitBtn(Control).IsRightToLeft then TextFormat := TextFormat + DT_RTLREADING; if (TBitBtn(Control).Glyph <> nil) then begin B := TBitmap.Create; BWidth := TBitBtn(Control).Glyph.Width div TBitBtn(Control).NumGlyphs; BHeight := TBitBtn(Control).Glyph.Height; B.Width := BWidth; B.Height := BHeight; Space := TBitBtn(Control).Spacing; if (Trim(TBitBtn(Control).Caption) = '') then Space := 0; //"Holger Lembke" IconRect := Rect(R.Left , R.Top, R.Left+BWidth, R.Top + BHeight); B.Canvas.CopyRect (Rect(0, 0, BWidth, BHeight), TBitBtn(Control).Glyph.Canvas, Rect(0, 0, BWidth, BHeight)); case TBitBtn(Control).Layout of blGlyphLeft: begin IconRect.Left := (CWidth - (BWidth + Space + TWidth)) div 2; IconRect.Right := IconRect.Left + BWidth; IconRect.Top := (CHeight - (BHeight)) div 2; IconRect.Bottom := IconRect.Top + BHeight; TextRect.Left := IconRect.Right + Space; TextRect.Right := TextRect.Left + TWidth; TextRect.Top := (CHeight - (THeight)) div 2; TextRect.Bottom := TextRect.Top + THeight; end; blGlyphRight: begin IconRect.Right := (CWidth + (BWidth + Space + TWidth)) div 2; IconRect.Left := IconRect.Right - BWidth; IconRect.Top := (CHeight - (BHeight)) div 2; IconRect.Bottom := IconRect.Top + BHeight; TextRect.Right := IconRect.Left - Space; TextRect.Left := TextRect.Right - TWidth; TextRect.Top := (CHeight - (THeight)) div 2; TextRect.Bottom := TextRect.Top + THeight; end; blGlyphTop: begin IconRect.Left := (CWidth - BWidth) div 2; IconRect.Right := IconRect.Left + BWidth; IconRect.Top := (CHeight - (BHeight + Space + THeight)) div 2; IconRect.Bottom := IconRect.Top + BHeight; TextRect.Left := (CWidth - (TWidth)) div 2; TextRect.Right := TextRect.Left + TWidth; TextRect.Top := IconRect.Bottom + Space; TextRect.Bottom := TextRect.Top + THeight; end; blGlyphBottom: begin IconRect.Left := (CWidth - BWidth) div 2; IconRect.Right := IconRect.Left + BWidth; IconRect.Bottom := (CHeight + (BHeight + Space + THeight)) div 2; IconRect.Top := IconRect.Bottom - BHeight; TextRect.Left := (CWidth - (TWidth)) div 2; TextRect.Right := TextRect.Left + TWidth; TextRect.Bottom := IconRect.Top - Space; TextRect.Top := TextRect.Bottom - THeight; end; end; xpMenu.DrawIcon(Control, C , B, IconRect, FMouseinControl, FIsFocused, TControl(Control).Enabled, false, false, TControl(Control).IsRightToLeft); B.Free; end; if (Control.Tag and 1002) = 1002 then begin if TBitBtn(Control).IsRightToLeft then TextFormat := + DT_RIGHT + DT_VCENTER else TextFormat := + DT_LEFT + DT_VCENTER; TextRect := R; InflateRect(TextRect, -4,-2); end; XPMenu.DrawTheText(Control, Txt, '', C, TextRect, false, TControl(Control).Enabled, TBitBtn(Control).Default, false, TControl(Control).IsRightToLeft, TxtFont, TextFormat); finally C.Free; end; end; procedure TControlSubClass.PaintUpDownButton; var C: TControlCanvas; R: TRect; SelectColor, BorderColor, ArrowColor: TColor; P: TPoint; H: integer; procedure DrawUpDownButton(ARect: TRect; Arrow: integer; Active: boolean); begin if Control.Enabled then ArrowColor := clBlack else ArrowColor := clWhite; if Active then begin if FLButtonBressed then begin BorderColor := XPMenu.FFSelectBorderColor; SelectColor := XPMenu.FCheckedAreaSelectColor ; ArrowColor := clWhite; end else begin BorderColor := XPMenu.FFSelectBorderColor; SelectColor := NewColor(C, XPMenu.FFSelectColor, 60);//XPMenu.FFSelectColor; end; end else begin if Control.Tag = 1000 then SelectColor := NewColor(C, TControl(Control).Parent.Brush.Color, xpMenu.FDimParentColor) else SelectColor := NewColor(C, XPMenu.FFSelectColor, xpMenu.FDimParentColor);//clBtnFace; BorderColor := NewColor(C, TControl(Control).Parent.Brush.Color, 80);//SelectColor; end; C.Pen.Color := BorderColor; C.Brush.Color := SelectColor; C.Font.Color := ArrowColor; if C.Pixels[ARect.Left, ARect.Top] <> ColorToRGB(BorderColor) then begin C.Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom); C.Pen.Color := ArrowColor; DrawArrow(C, ARect.Left + ((ARect.Right - ARect.Left) div 2), ARect.Top + ((ARect.Bottom - ARect.Top) div 2) -2, Arrow); end; end; begin C := TControlCanvas.Create; try C.Control := Control; R := Control.ClientRect; H := (R.Bottom - R.Top) div 2; P := Control.ScreenToClient(Mouse.CursorPos); DrawUpDownButton(Rect(R.Left, R.Top, R.Right, R.Top + H), 0, TControl(Control).Enabled and FMouseInControl and (P.Y < H)); DrawUpDownButton(Rect(R.Left, R.Bottom - H, R.Right, R.Bottom), 1, TControl(Control).Enabled and FMouseInControl and not(P.Y < H)); finally C.Free; end; end; procedure TControlSubClass.PaintGroupBox; var C: TControlCanvas; R, RText: TRect; ShadowColor, LightColor: TColor; TextHeight, TextWidth: integer; Text: string; begin if FMsg <> WM_PAINT then exit; C := TControlCanvas.Create; try C.Control := Control; R := Control.ClientRect; C.Font.Assign (TGroupBox(Control).Font); C.Font.Height := TGroupBox(Control).Font.Height; Text := TGroupBox(Control).Caption; TextHeight := C.TextHeight(Text); TextWidth := C.TextWidth(Text); if Length(Text) = 0 then TextHeight := C.TextHeight(' '); ShadowColor := GetShadeColor(C, TGroupBox(Control).color, 60); LightColor := NewColor(C, TGroupBox(Control).color, 60); InflateRect(R,-1, -1); Inc(R.Top, (TextHeight)-1); C.Brush.Style := bsClear; C.Pen.Color := TGroupBox(Control).Color; // Control Color; C.Rectangle (R.Left, R.Top, R.Right, R.Bottom); //----Draw the outer Frame R := Control.ClientRect; Inc(R.Top, (TextHeight div 2)-1); C.Pen.Color := TGroupBox(Control).Color; C.MoveTo(R.Left + 1, R.Top); // Repeat C.LineTo(R.Left + 1, R.Bottom); if TGroupBox(Control).Ctl3D then Frame3D(C, R, LightColor, ShadowColor, 1) else Frame3D(C, R, ShadowColor, ShadowColor, 1); // Fill Upper part (outside frame) R := Control.ClientRect; R.Bottom := R.Top + (TextHeight div 2) + 1; C.Brush.Style := bsSolid; C.Brush.Color := Control.Parent.Brush.Color; // Parent Color; C.Pen.Color := C.Brush.Color; C.FillRect(R); if Control.IsRightToLeft then begin C.TextFlags := ETO_RTLREADING; RText.Right := R.Right - 9; RText.Left := RText.Right - TextWidth; end else begin RText.Left := R.Left + 9; RText.Right := RText.Left + TextWidth; end; RText.Top := R.Top ; RText.Bottom := R.Top + TextHeight; //(inside frame) InflateRect(R, -1, 0); R.Top := R.Bottom; R.Bottom := R.Top + (TextHeight div 2) + 1; C.Brush.Style := bsSolid; R.Left := RText.Left; R.Right := RText.Right; C.Brush.Color := TGroupBox(Control).Color; // Control Color; C.Pen.Color := C.Brush.Color; C.FillRect(R); R.Right := Control.ClientRect.Right; C.MoveTo(R.Right-2, R.Top); C.LineTo(R.Right-2, RText.Bottom); C.Brush.Style := bsClear; if Control.IsRightToLeft then C.TextFlags := ETO_RTLREADING; C.TextRect (RText, RText.Left, RText.Top, Text); // Draw Upper Line R := Control.ClientRect; Inc(R.Top, (TextHeight div 2) + 1); if TGroupBox(Control).Ctl3D then C.Pen.Color := LightColor else C.Pen.Color := ShadowColor; C.MoveTo(R.Left, R.Top); C.LineTo(RText.Left, R.Top); C.MoveTo(RText.Right, R.Top); C.LineTo(R.Right -1, R.Top); finally C.Free; end; end; procedure TControlSubClass.PaintPanel; var C: TControlCanvas; R: TRect; ShadowColor, LightColor: TColor; begin if FMsg <> WM_PAINT then exit; C := TControlCanvas.Create; try C.Control := Control; R := Control.ClientRect; ShadowColor := GetShadeColor(C, TPanel(Control).color, 60); LightColor := NewColor(C, TPanel(Control).color, 60); if TPanel(Control).BevelOuter <> bvNone then begin if TPanel(Control).BevelOuter = bvLowered then Frame3D(C, R, ShadowColor, LightColor, TPanel(Control).BevelWidth) else Frame3D(C, R, LightColor, ShadowColor, TPanel(Control).BevelWidth); end; if TPanel(Control).BevelInner <> bvNone then begin InflateRect(R, -TPanel(Control).BorderWidth, -TPanel(Control).BorderWidth); if TPanel(Control).BevelInner = bvLowered then Frame3D(C, R, ShadowColor, LightColor, TPanel(Control).BevelWidth) else Frame3D(C, R, LightColor, ShadowColor, TPanel(Control).BevelWidth); end; finally C.Free; end; end; type TCastWinControl = class(TWinControl); procedure TControlSubClass.PaintNCWinControl; var DC: HDC; C: TControlCanvas; R: TRect; BorderColor: TColor; begin C := TControlCanvas.Create; DC := GetWindowDC(TWinControl(Control).Handle); try C.Control := Control; C.Handle := DC; XPMenu.SetGlobalColor(C); if (FMouseInControl) or (FIsFocused) then begin if FBorderStyle = bsSingle then BorderColor := NewColor(C, XPMenu.FFSelectBorderColor, 60) else BorderColor := NewColor(C, XPMenu.FFSelectBorderColor, 80); end else begin if FBorderStyle = bsSingle then borderColor := GetShadeColor(C, Control.Parent.Brush.Color, 60) else borderColor := Control.Parent.Brush.Color; end; if TCastWinControl(Control).Ctl3D <> false then begin FBuilding := true; TCastWinControl(Control).Ctl3D := false; end; C.Pen.Color := BorderColor; C.Brush.Style := bsClear; R := Rect(0, 0, Control.Width, Control.Height); C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); finally C.Free; ReleaseDC(TWinControl(Control).Handle, DC); end; end; procedure TControlSubClass.PaintProgressBar; var DC: HDC; C: TControlCanvas; R: TRect; BorderColor: TColor; begin C := TControlCanvas.Create; DC := GetWindowDC(TWinControl(Control).Handle); try C.Control := Control; C.Handle := DC; if (FMouseInControl) then BorderColor := XPMenu.FFSelectBorderColor else BorderColor := GetShadeColor(C, Control.Parent.Brush.Color, 60); C.Pen.Color := BorderColor; C.Brush.Style := bsClear; R := Rect(0, 0, Control.Width, Control.Height); C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); finally C.Free; ReleaseDC(TWinControl(Control).Handle, DC); end; end; procedure TControlSubClass.PaintHotKey; var DC: HDC; C: TControlCanvas; R: TRect; BorderColor: TColor; begin C := TControlCanvas.Create; DC := GetWindowDC(TWinControl(Control).Handle); try C.Control := Control; C.Handle := DC; XPMenu.SetGlobalColor(C); if (FMouseInControl) or (FIsFocused) then BorderColor := NewColor(C, XPMenu.FFSelectBorderColor, 60) else BorderColor := GetShadeColor(C, Control.Parent.Brush.Color, 60); C.Pen.Color := BorderColor; C.Brush.Style := bsClear; R := Rect(0, 0, Control.Width, Control.Height); C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); InflateRect(R, -1, -1); C.Pen.Color := clWindow; C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); finally C.Free; ReleaseDC(TWinControl(Control).Handle, DC); end; end; // XPMenuManager // // Uwe Runkel, uwe@runkel.info // // Enable XPMenu to be used globally (all windows in the application use XPMenu). // Hence you don't need more than one instance in an application. However it is also // possible to have more than one instance. But only one instance is used for subclassing. // If this instance is destroyed the manager looks if there is another instance which is // allowed to subclass. constructor TXPMenuManager.Create; begin inherited Create; FXPMenuList := TList.Create; // list of XPMenu components in the application FFormList := TList.Create; // list of subclassed forms FPendingFormsList := TList.Create; // list of forms inserted but not subclassed yet FDisableSubclassing := false; // This disables the XPMenuManager FActiveXPMenu := nil; // Currently for subclassing used XPMenu // if this is nil no subclassing is done. Application.HookMainWindow(MainWindowHook); end; destructor TXPMenuManager.Destroy; begin FPendingFormsList.Free; FXPMenuList.Free; FFormList.Free; inherited; end; // A component has been inserted or removed, if it is a form and subclassing is // allowed then subclass it, so this form doesn't need a XPMenu component as well procedure TXPMenuManager.Notification(AComponent: TComponent; Operation: TOperation); begin if (FActiveXPMenu = nil) or FDisableSubclassing then Exit; case Operation of opInsert: // At this place we cannot subclass the control because it did not yet get its // initial window procedure. // So we add it to an intermediate list and subclass it at a later moment. if (AComponent is TCustomForm) and (FPendingFormsList.IndexOf(AComponent) < 0) then FPendingFormsList.Add(AComponent); opRemove: if (AComponent is TWinControl) then begin if AComponent is TCustomForm then begin // Remove the destroyed form from any form list if it is still there. FPendingFormsList.Remove(AComponent); FFormList.Remove(AComponent); end; end; end; end; // Add some XPMenu to the manager procedure TXPMenuManager.Add(AXPMenu: TXPMenu); begin FXPMenuList.Add(AXPMenu); FFormList.Add(AXPMenu.Form); if (FActiveXPMenu = nil) and AXPMenu.Active and not(AXPMenu.DisableSubclassing) and not(FDisableSubclassing) then begin FActiveXPMenu := AXPMenu; CollectForms; end; end; // Remove some XPMenu from the manager procedure TXPMenuManager.Delete(AXPMenu: TXPMenu); begin if AXPMenu = FActiveXPMenu then UpdateActiveXPMenu(AXPMenu); FXPMenuList.Remove(AXPMenu); end; // Select a new ActiveXPMenu (except the one given in the parameter) procedure TXPMenuManager.UpdateActiveXPMenu(AXPMenu: TXPMenu); var Cnt : integer; XPM : TXPMenu; Item: TControlSubClass; Comp: TControlSubClass; begin XPM := FindSubclassingXPMenu(AXPMenu); if XPM = nil then begin FPendingFormsList.Clear; if not Assigned(Application.MainForm) then Exit; for Cnt := 0 to FFormList.Count - 1 do if (AXPMenu = nil) or (FFormList[Cnt] <> AXPMenu.Form) then RemoveChildSubclassing(TCustomForm(FFormList[Cnt])); FFormList.Clear; FActiveXPMenu := XPM; end else begin if FActiveXPMenu = nil then begin FActiveXPMenu := XPM; CollectForms; end else begin for Cnt := 0 to FActiveXPMenu.ComponentCount - 1 do if (FActiveXPMenu.Components[Cnt] is TControlSubClass) then begin Comp := FActiveXPMenu.Components[Cnt] as TControlSubClass; if (AXPMenu <> nil) and not(AXPMenu.Form.ContainsControl(Comp.Control)) then begin Item := TControlSubClass.Create(XPM); Item.Control := Comp.Control; Item.orgWindowProc := Comp.orgWindowProc; Item.Control.WindowProc := Item.ControlSubClass; Item.XPMenu := XPM; Item.FCtl3D := Comp.FCtl3D; Item.FBorderStyle := Comp.FBorderStyle; {Item.FOnDrawCell := Comp.FOnDrawCell;} Item.FDefaultDrawing := Comp.FDefaultDrawing; Item.FSelCol := Comp.FSelCol; Item.FSelRow := Comp.FSelRow; end; end; FActiveXPMenu := XPM; end; end; end; // Find an XPMenu which can be used for subclassing function TXPMenuManager.FindSubclassingXPMenu(Exclude: TXPMenu): TXPMenu; var XPM: TXPMenu; Cnt: integer; begin Result := nil; if (FXPMenuList.Count = 0) or FDisableSubclassing then Exit; Cnt := 0; repeat XPM := TXPMenu(FXPMenuList[Cnt]); if XPM.Active and not(XPM.DisableSubclassing) and (XPM <> Exclude) then Result := XPM; inc(Cnt); until (Result <> nil) or (Cnt = FXPMenuList.Count); end; // Listens to messages sent to the application and looks if a window is inserted. function TXPMenuManager.MainWindowHook(var Message: TMessage): boolean; var i: integer; NewForm: TCustomForm; FMenuItem: TMenuItem; // +jt FMenu: TMenu; // +jt r: TRECT; // +jt pt: TPOINT; // +jt hWndM: HWND; // +j begin Result := false; if Message.Msg = WM_DRAWMENUBORDER then begin FMenuItem:=TMenuItem(Message.LParam); if Assigned(FMenuItem) then begin GetMenuItemRect(0,FMenuItem.Parent.Handle,FMenuItem.MenuIndex,r); FMenu := FMenuItem.Parent.GetParentMenu; pt.x:=r.Left+(r.Right-r.Left) div 2; pt.y:=r.Top+(r.Bottom-r.Top) div 2; hWndM :=WindowFromPoint(pt); if hWndM<>0 then FActiveXPMenu.DrawWindowBorder(hWndM, FMenu.IsRightToLeft); end; end; if Message.Msg = WM_DRAWMENUBORDER2 then begin hWndM := HWND(Message.LParam); FActiveXPMenu.DrawWindowBorder(hWndM, boolean(Message.WParam)); end; if (Assigned(FPendingFormsList)) and (FPendingFormsList <> nil) then try if (FPendingFormsList.Count > 0) then begin for i := 0 to FPendingFormsList.Count - 1 do begin NewForm := TCustomForm(FPendingFormsList[i]); if FFormList.IndexOf(NewForm) < 0 then begin FFormList.Add(NewForm); if not(FDisableSubclassing) then FActiveXPMenu.InitItems(NewForm, true, true); end; end; FPendingFormsList.Clear; end; except end; end; // Collect all forms of the application and subclass them procedure TXPMenuManager.CollectForms; var FCnt, CCnt: integer; HasXPMenu : boolean; begin if not FDisableSubclassing then for FCnt := 0 to Screen.FormCount - 1 do if (FFormList.IndexOf(Screen.Forms[FCnt]) < 0) and (Screen.Forms[FCnt].Tag <> 999) then begin HasXPMenu := false; for CCnt := 0 to Screen.Forms[FCnt].ComponentCount - 1 do HasXPMenu := HasXPMenu or (Screen.Forms[FCnt].Components[CCnt] is TXPMenu); if not(HasXPMenu) then FPendingFormsList.Add(Screen.Forms[FCnt]); end; end; // Remove subclassing from the original components procedure TXPMenuManager.RemoveChildSubclassing(AForm: TCustomForm); var Cnt : integer; Comp : TComponent; Control: TControl; begin //exit; for Cnt := FActiveXPMenu.ComponentCount - 1 downto 0 do begin Comp := FActiveXPMenu.Components[Cnt]; if (Comp is TControlSubClass) then begin Control := TControlSubClass(Comp).Control; if AForm.ContainsControl(Control) then begin try Control.WindowProc := TControlSubClass(Comp).orgWindowProc; if Control is TCustomEdit then begin TEdit(Control).Ctl3D := TControlSubClass(Comp).FCtl3D; TEdit(Control).BorderStyle := TControlSubClass(Comp).FBorderStyle; end; if Control.ClassName = 'TDBLookupComboBox' then TComboBox(Control).Ctl3D := TControlSubClass(Comp).FCtl3D; if Control is TCustomListBox then begin TListBox(Control).Ctl3D := TControlSubClass(Comp).FCtl3D; TListBox(Control).BorderStyle := TControlSubClass(Comp).FBorderStyle; end; if Control is TCustomListView then begin TListView(Control).Ctl3D := TControlSubClass(Comp).FCtl3D; TListView(Control).BorderStyle := TControlSubClass(Comp).FBorderStyle; end; if Control is TCustomTreeView then begin TTreeView(Control).Ctl3D := TControlSubClass(Comp).FCtl3D; TTreeView(Control).BorderStyle := TControlSubClass(Comp).FBorderStyle; end; except end; end; end; end; end; // Add a form manually to the current XPMenu procedure TXPMenuManager.AddForm(AForm: TCustomForm); begin if FPendingFormsList.IndexOf(AForm) < 0 then FPendingFormsList.Add(AForm); end; // Remove a form manually from the current XPMenu procedure TXPMenuManager.RemoveForm(AForm: TCustomForm); begin if FPendingFormsList.IndexOf(AForm) >= 0 then FPendingFormsList.Remove(AForm); if FFormList.IndexOf(AForm) >= 0 then FFormList.Remove(AForm); end; // Disable/Enable subclassing by the manager procedure TXPMenuManager.SetDisableSubclassing(AValue: boolean); begin if FDisableSubclassing = AValue then Exit; FDisableSubclassing := AValue; UpdateActiveXPMenu(nil); end; // Check if a Form is subclassed function TXPMenuManager.IsFormSubclassed(AForm: TCustomForm): boolean; begin Result := ((FFormList <> nil) and (FFormList.IndexOf(AForm) >= 0)) or ((FPendingFormsList <> nil) and (FPendingFormsList.IndexOf(AForm) >= 0)); end; // Check if a Component is subclassed function TXPMenuManager.IsComponentSubclassed(AComponent: TComponent): boolean; var Cnt: integer; begin Result := false; with FActiveXPMenu do for Cnt := 0 to ComponentCount - 1 do if Components[Cnt] is TControlSubClass then if TControlSubClass(Components[Cnt]).Control = TControl(AComponent) then Result := true; end; end.