{$A8,B-,C+,D+,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1} {$MINSTACKSIZE $00004000} {$MAXSTACKSIZE $00100000} {$IMAGEBASE $00400000} {$APPTYPE GUI} {$WARN SYMBOL_DEPRECATED ON} {$WARN SYMBOL_LIBRARY ON} {$WARN SYMBOL_PLATFORM ON} {$WARN UNIT_LIBRARY ON} {$WARN UNIT_PLATFORM ON} {$WARN UNIT_DEPRECATED ON} {$WARN HRESULT_COMPAT ON} {$WARN HIDING_MEMBER ON} {$WARN HIDDEN_VIRTUAL ON} {$WARN GARBAGE ON} {$WARN BOUNDS_ERROR ON} {$WARN ZERO_NIL_COMPAT ON} {$WARN STRING_CONST_TRUNCED ON} {$WARN FOR_LOOP_VAR_VARPAR ON} {$WARN TYPED_CONST_VARPAR ON} {$WARN ASG_TO_TYPED_CONST ON} {$WARN CASE_LABEL_RANGE ON} {$WARN FOR_VARIABLE ON} {$WARN CONSTRUCTING_ABSTRACT ON} {$WARN COMPARISON_FALSE ON} {$WARN COMPARISON_TRUE ON} {$WARN COMPARING_SIGNED_UNSIGNED ON} {$WARN COMBINING_SIGNED_UNSIGNED ON} {$WARN UNSUPPORTED_CONSTRUCT ON} {$WARN FILE_OPEN ON} {$WARN FILE_OPEN_UNITSRC ON} {$WARN BAD_GLOBAL_SYMBOL ON} {$WARN DUPLICATE_CTOR_DTOR ON} {$WARN INVALID_DIRECTIVE ON} {$WARN PACKAGE_NO_LINK ON} {$WARN PACKAGED_THREADVAR ON} {$WARN IMPLICIT_IMPORT ON} {$WARN HPPEMIT_IGNORED ON} {$WARN NO_RETVAL ON} {$WARN USE_BEFORE_DEF ON} {$WARN FOR_LOOP_VAR_UNDEF ON} {$WARN UNIT_NAME_MISMATCH ON} {$WARN NO_CFG_FILE_FOUND ON} {$WARN MESSAGE_DIRECTIVE ON} {$WARN IMPLICIT_VARIANTS ON} {$WARN UNICODE_TO_LOCALE ON} {$WARN LOCALE_TO_UNICODE ON} {$WARN IMAGEBASE_MULTIPLE ON} {$WARN SUSPICIOUS_TYPECAST ON} {$WARN PRIVATE_PROPACCESSOR ON} {$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CODE OFF} {$WARN UNSAFE_CAST OFF} {$A8,B-,C+,D+,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1} {$MINSTACKSIZE $00004000} {$MAXSTACKSIZE $00100000} {$IMAGEBASE $00400000} {$APPTYPE GUI} {$WARN SYMBOL_DEPRECATED ON} {$WARN SYMBOL_LIBRARY ON} {$WARN SYMBOL_PLATFORM ON} {$WARN UNIT_LIBRARY ON} {$WARN UNIT_PLATFORM ON} {$WARN UNIT_DEPRECATED ON} {$WARN HRESULT_COMPAT ON} {$WARN HIDING_MEMBER ON} {$WARN HIDDEN_VIRTUAL ON} {$WARN GARBAGE ON} {$WARN BOUNDS_ERROR ON} {$WARN ZERO_NIL_COMPAT ON} {$WARN STRING_CONST_TRUNCED ON} {$WARN FOR_LOOP_VAR_VARPAR ON} {$WARN TYPED_CONST_VARPAR ON} {$WARN ASG_TO_TYPED_CONST ON} {$WARN CASE_LABEL_RANGE ON} {$WARN FOR_VARIABLE ON} {$WARN CONSTRUCTING_ABSTRACT ON} {$WARN COMPARISON_FALSE ON} {$WARN COMPARISON_TRUE ON} {$WARN COMPARING_SIGNED_UNSIGNED ON} {$WARN COMBINING_SIGNED_UNSIGNED ON} {$WARN UNSUPPORTED_CONSTRUCT ON} {$WARN FILE_OPEN ON} {$WARN FILE_OPEN_UNITSRC ON} {$WARN BAD_GLOBAL_SYMBOL ON} {$WARN DUPLICATE_CTOR_DTOR ON} {$WARN INVALID_DIRECTIVE ON} {$WARN PACKAGE_NO_LINK ON} {$WARN PACKAGED_THREADVAR ON} {$WARN IMPLICIT_IMPORT ON} {$WARN HPPEMIT_IGNORED ON} {$WARN NO_RETVAL ON} {$WARN USE_BEFORE_DEF ON} {$WARN FOR_LOOP_VAR_UNDEF ON} {$WARN UNIT_NAME_MISMATCH ON} {$WARN NO_CFG_FILE_FOUND ON} {$WARN MESSAGE_DIRECTIVE ON} {$WARN IMPLICIT_VARIANTS ON} {$WARN UNICODE_TO_LOCALE ON} {$WARN LOCALE_TO_UNICODE ON} {$WARN IMAGEBASE_MULTIPLE ON} {$WARN SUSPICIOUS_TYPECAST ON} {$WARN PRIVATE_PROPACCESSOR ON} {$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CODE OFF} {$WARN UNSAFE_CAST OFF} {$A8,B-,C+,D+,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1} {$MINSTACKSIZE $00004000} {$MAXSTACKSIZE $00100000} {$IMAGEBASE $00400000} {$APPTYPE GUI} {$WARN SYMBOL_DEPRECATED ON} {$WARN SYMBOL_LIBRARY ON} {$WARN SYMBOL_PLATFORM ON} {$WARN UNIT_LIBRARY ON} {$WARN UNIT_PLATFORM ON} {$WARN UNIT_DEPRECATED ON} {$WARN HRESULT_COMPAT ON} {$WARN HIDING_MEMBER ON} {$WARN HIDDEN_VIRTUAL ON} {$WARN GARBAGE ON} {$WARN BOUNDS_ERROR ON} {$WARN ZERO_NIL_COMPAT ON} {$WARN STRING_CONST_TRUNCED ON} {$WARN FOR_LOOP_VAR_VARPAR ON} {$WARN TYPED_CONST_VARPAR ON} {$WARN ASG_TO_TYPED_CONST ON} {$WARN CASE_LABEL_RANGE ON} {$WARN FOR_VARIABLE ON} {$WARN CONSTRUCTING_ABSTRACT ON} {$WARN COMPARISON_FALSE ON} {$WARN COMPARISON_TRUE ON} {$WARN COMPARING_SIGNED_UNSIGNED ON} {$WARN COMBINING_SIGNED_UNSIGNED ON} {$WARN UNSUPPORTED_CONSTRUCT ON} {$WARN FILE_OPEN ON} {$WARN FILE_OPEN_UNITSRC ON} {$WARN BAD_GLOBAL_SYMBOL ON} {$WARN DUPLICATE_CTOR_DTOR ON} {$WARN INVALID_DIRECTIVE ON} {$WARN PACKAGE_NO_LINK ON} {$WARN PACKAGED_THREADVAR ON} {$WARN IMPLICIT_IMPORT ON} {$WARN HPPEMIT_IGNORED ON} {$WARN NO_RETVAL ON} {$WARN USE_BEFORE_DEF ON} {$WARN FOR_LOOP_VAR_UNDEF ON} {$WARN UNIT_NAME_MISMATCH ON} {$WARN NO_CFG_FILE_FOUND ON} {$WARN MESSAGE_DIRECTIVE ON} {$WARN IMPLICIT_VARIANTS ON} {$WARN UNICODE_TO_LOCALE ON} {$WARN LOCALE_TO_UNICODE ON} {$WARN IMAGEBASE_MULTIPLE ON} {$WARN SUSPICIOUS_TYPECAST ON} {$WARN PRIVATE_PROPACCESSOR ON} {$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CODE OFF} {$WARN UNSAFE_CAST OFF} {$A8,B-,C+,D+,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1} {$MINSTACKSIZE $00004000} {$MAXSTACKSIZE $00100000} {$IMAGEBASE $00400000} {$APPTYPE GUI} {$WARN SYMBOL_DEPRECATED ON} {$WARN SYMBOL_LIBRARY ON} {$WARN SYMBOL_PLATFORM ON} {$WARN UNIT_LIBRARY ON} {$WARN UNIT_PLATFORM ON} {$WARN UNIT_DEPRECATED ON} {$WARN HRESULT_COMPAT ON} {$WARN HIDING_MEMBER ON} {$WARN HIDDEN_VIRTUAL ON} {$WARN GARBAGE ON} {$WARN BOUNDS_ERROR ON} {$WARN ZERO_NIL_COMPAT ON} {$WARN STRING_CONST_TRUNCED ON} {$WARN FOR_LOOP_VAR_VARPAR ON} {$WARN TYPED_CONST_VARPAR ON} {$WARN ASG_TO_TYPED_CONST ON} {$WARN CASE_LABEL_RANGE ON} {$WARN FOR_VARIABLE ON} {$WARN CONSTRUCTING_ABSTRACT ON} {$WARN COMPARISON_FALSE ON} {$WARN COMPARISON_TRUE ON} {$WARN COMPARING_SIGNED_UNSIGNED ON} {$WARN COMBINING_SIGNED_UNSIGNED ON} {$WARN UNSUPPORTED_CONSTRUCT ON} {$WARN FILE_OPEN ON} {$WARN FILE_OPEN_UNITSRC ON} {$WARN BAD_GLOBAL_SYMBOL ON} {$WARN DUPLICATE_CTOR_DTOR ON} {$WARN INVALID_DIRECTIVE ON} {$WARN PACKAGE_NO_LINK ON} {$WARN PACKAGED_THREADVAR ON} {$WARN IMPLICIT_IMPORT ON} {$WARN HPPEMIT_IGNORED ON} {$WARN NO_RETVAL ON} {$WARN USE_BEFORE_DEF ON} {$WARN FOR_LOOP_VAR_UNDEF ON} {$WARN UNIT_NAME_MISMATCH ON} {$WARN NO_CFG_FILE_FOUND ON} {$WARN MESSAGE_DIRECTIVE ON} {$WARN IMPLICIT_VARIANTS ON} {$WARN UNICODE_TO_LOCALE ON} {$WARN LOCALE_TO_UNICODE ON} {$WARN IMAGEBASE_MULTIPLE ON} {$WARN SUSPICIOUS_TYPECAST ON} {$WARN PRIVATE_PROPACCESSOR ON} {$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CODE OFF} {$WARN UNSAFE_CAST OFF} { :: Implements a Uname-IT-style painter for the X2MenuBar. :: :: Part of the X2Software Component Library :: http://www.x2software.net/ :: :: Last changed: $Date$ :: Revision: $Rev$ :: Author: $Author$ } unit X2CLunaMenuBarPainter; interface uses Classes, Graphics, ImgList, Windows, X2CLMenuBar; type TX2MenuBarunaProperty = class(TPersistent) private FOnChange: TNotifyEvent; protected procedure Changed; public property OnChange: TNotifyEvent read FOnChange write FOnChange; end; TX2MenuBarunaColor = class(TX2MenuBarunaProperty) private FDefaultDisabled: TColor; FDefaultHot: TColor; FDefaultNormal: TColor; FDefaultSelected: TColor; FDisabled: TColor; FHot: TColor; FNormal: TColor; FSelected: TColor; function IsDisabledStored: Boolean; function IsHotStored: Boolean; function IsNormalStored: Boolean; function IsSelectedStored: Boolean; procedure SetDisabled(const Value: TColor); procedure SetHot(const Value: TColor); procedure SetNormal(const Value: TColor); procedure SetSelected(const Value: TColor); protected procedure SetDefaultColors(AHot, ANormal, ASelected, ADisabled: TColor); property DefaultDisabled: TColor read FDefaultDisabled write FDefaultDisabled; property DefaultHot: TColor read FDefaultHot write FDefaultHot; property DefaultNormal: TColor read FDefaultNormal write FDefaultNormal; property DefaultSelected: TColor read FDefaultSelected write FDefaultSelected; public procedure Assign(Source: TPersistent); override; published property Disabled: TColor read FDisabled write SetDisabled stored IsDisabledStored; property Hot: TColor read FHot write SetHot stored IsHotStored; property Normal: TColor read FNormal write SetNormal stored IsNormalStored; property Selected: TColor read FSelected write SetSelected stored IsSelectedStored; end; TX2MenuBarunaGroupColors = class(TX2MenuBarunaProperty) private FFill: TX2MenuBarunaColor; FText: TX2MenuBarunaColor; FBorder: TX2MenuBarunaColor; procedure SetBorder(const Value: TX2MenuBarunaColor); procedure SetFill(const Value: TX2MenuBarunaColor); procedure SetText(const Value: TX2MenuBarunaColor); protected procedure ColorChange(Sender: TObject); public constructor Create; destructor Destroy; override; procedure Assign(Source: TPersistent); override; published property Border: TX2MenuBarunaColor read FBorder write SetBorder; property Fill: TX2MenuBarunaColor read FFill write SetFill; property Text: TX2MenuBarunaColor read FText write SetText; end; TX2MenuBarunaMetrics = class(TX2MenuBarunaProperty) private FAfterGroupHeader: Integer; FAfterItem: Integer; FAfterLastItem: Integer; FBeforeFirstItem: Integer; FBeforeGroupHeader: Integer; FBeforeItem: Integer; FGroupHeight: Integer; FItemHeight: Integer; FMargin: Integer; FImageOffsetY: Integer; FImageOffsetX: Integer; procedure SetAfterGroupHeader(const Value: Integer); procedure SetAfterItem(const Value: Integer); procedure SetAfterLastItem(const Value: Integer); procedure SetBeforeFirstItem(const Value: Integer); procedure SetBeforeGroupHeader(const Value: Integer); procedure SetBeforeItem(const Value: Integer); procedure SetGroupHeight(const Value: Integer); procedure SetItemHeight(const Value: Integer); procedure SetMargin(const Value: Integer); procedure SetImageOffsetX(const Value: Integer); procedure SetImageOffsetY(const Value: Integer); public constructor Create; procedure Assign(Source: TPersistent); override; published property AfterGroupHeader: Integer read FAfterGroupHeader write SetAfterGroupHeader default 8; property AfterItem: Integer read FAfterItem write SetAfterItem default 2; property AfterLastItem: Integer read FAfterLastItem write SetAfterLastItem default 10; property BeforeFirstItem: Integer read FBeforeFirstItem write SetBeforeFirstItem default 0; property BeforeGroupHeader: Integer read FBeforeGroupHeader write SetBeforeGroupHeader default 8; property BeforeItem: Integer read FBeforeItem write SetBeforeItem default 2; property GroupHeight: Integer read FGroupHeight write SetGroupHeight default 22; property ItemHeight: Integer read FItemHeight write SetItemHeight default 21; property Margin: Integer read FMargin write SetMargin default 10; property ImageOffsetX: Integer read FImageOffsetX write SetImageOffsetX default 0; property ImageOffsetY: Integer read FImageOffsetY write SetImageOffsetY default 0; end; THorzAlignment = (haLeft, haCenter, haRight); TVertAlignment = (vaTop, vaCenter, vaBottom); TX2MenuBarunaPainter = class(TX2CustomMenuBarPainter) private FArrowColor: TColor; FBlurShadow: Boolean; FColor: TColor; FGroupColors: TX2MenuBarunaGroupColors; FItemColors: TX2MenuBarunaColor; FMetrics: TX2MenuBarunaMetrics; FShadowColor: TColor; FShadowOffset: Integer; FGroupGradient: Integer; FArrowImages: TCustomImageList; FArrowImageIndex: TImageIndex; FBackground: TPicture; FBackgroundHorzAlignment: THorzAlignment; FBackgroundVertAlignment: TVertAlignment; procedure SetBlurShadow(const Value: Boolean); procedure SetGroupColors(const Value: TX2MenuBarunaGroupColors); procedure SetItemColors(const Value: TX2MenuBarunaColor); procedure SetMetrics(const Value: TX2MenuBarunaMetrics); procedure SetShadowColor(const Value: TColor); procedure SetShadowOffset(const Value: Integer); procedure SetGroupGradient(const Value: Integer); procedure SetArrowImageIndex(const Value: TImageIndex); procedure SetArrowImages(const Value: TCustomImageList); procedure SetBackground(const Value: TPicture); procedure SetBackgroundHorzAlignment(const Value: THorzAlignment); procedure SetBackgroundVertAlignment(const Value: TVertAlignment); protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; function HasArrowImage: Boolean; function ApplyMargins(const ABounds: TRect): TRect; override; function UndoMargins(const ABounds: TRect): TRect; override; function GetSpacing(AElement: TX2MenuBarSpacingElement): Integer; override; function GetGroupHeaderHeight(AGroup: TX2MenuBarGroup): Integer; override; function GetItemHeight(AItem: TX2MenuBarItem): Integer; override; procedure DrawBackground(ACanvas: TCanvas; const ABounds: TRect; const AOffset: TPoint); override; procedure DrawGroupHeader(ACanvas: TCanvas; AGroup: TX2MenuBarGroup; const ABounds: TRect; AState: TX2MenuBarDrawStates); override; procedure DrawItem(ACanvas: TCanvas; AItem: TX2MenuBarItem; const ABounds: TRect; AState: TX2MenuBarDrawStates); override; procedure DrawArrow(ACanvas: TCanvas; ABounds: TRect); procedure ColorChange(Sender: TObject); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure ResetColors; published property ArrowColor: TColor read FArrowColor write FArrowColor default clBlue; property ArrowImageIndex: TImageIndex read FArrowImageIndex write SetArrowImageIndex default -1; property ArrowImages: TCustomImageList read FArrowImages write SetArrowImages; property Background: TPicture read FBackground write SetBackground; property BackgroundHorzAlignment: THorzAlignment read FBackgroundHorzAlignment write SetBackgroundHorzAlignment default haLeft; property BackgroundVertAlignment: TVertAlignment read FBackgroundVertAlignment write SetBackgroundVertAlignment default vaTop; property BlurShadow: Boolean read FBlurShadow write SetBlurShadow default True; property Color: TColor read FColor write FColor default clWindow; property GroupColors: TX2MenuBarunaGroupColors read FGroupColors write SetGroupColors; property GroupGradient: Integer read FGroupGradient write SetGroupGradient default 0; property ItemColors: TX2MenuBarunaColor read FItemColors write SetItemColors; property Metrics: TX2MenuBarunaMetrics read FMetrics write SetMetrics; property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow; property ShadowOffset: Integer read FShadowOffset write SetShadowOffset default 2; end; implementation uses SysUtils, X2CLGraphics; const ArrowMargin = 2; ArrowWidth = 8; procedure Blur(ASource: Graphics.TBitmap); var refBitmap: Graphics.TBitmap; lines: array[0..2] of PRGBAArray; lineDest: PRGBAArray; lineIndex: Integer; line: PRGBAArray; xPos: Integer; yPos: Integer; maxX: Integer; maxY: Integer; sumRed: Integer; sumGreen: Integer; sumBlue: Integer; samples: Integer; begin ASource.PixelFormat := pf32bit; refBitmap := Graphics.TBitmap.Create; try refBitmap.Assign(ASource); for lineIndex := Low(lines) to High(lines) do lines[lineIndex] := nil; maxY := Pred(ASource.Height); for yPos := 0 to maxY do begin for lineIndex := Low(lines) to High(lines) - 1 do lines[lineIndex] := lines[Succ(lineIndex)]; if yPos = maxY then lines[High(lines)] := nil else lines[High(lines)] := refBitmap.ScanLine[Succ(yPos)]; lineDest := ASource.ScanLine[yPos]; maxX := Pred(ASource.Width); for xPos := 0 to maxX do begin sumBlue := 0; sumGreen := 0; sumRed := 0; samples := 0; for lineIndex := Low(lines) to High(lines) do if Assigned(lines[lineIndex]) then begin line := lines[lineIndex]; with line^[xPos] do begin Inc(sumBlue, rgbBlue); Inc(sumGreen, rgbGreen); Inc(sumRed, rgbRed); Inc(samples); end; if xPos > 0 then with line^[Pred(xPos)] do begin Inc(sumBlue, rgbBlue); Inc(sumGreen, rgbGreen); Inc(sumRed, rgbRed); Inc(samples); end; if xPos < maxX then with line^[Succ(xPos)] do begin Inc(sumBlue, rgbBlue); Inc(sumGreen, rgbGreen); Inc(sumRed, rgbRed); Inc(samples); end; end; if samples > 0 then with lineDest^[xPos] do begin rgbBlue := sumBlue div samples; rgbGreen := sumGreen div samples; rgbRed := sumRed div samples; end; end; end; finally FreeAndNil(refBitmap); end; end; { TX2MenuBarunaMetrics } constructor TX2MenuBarunaMetrics.Create; begin inherited; FAfterGroupHeader := 8; FAfterItem := 2; FAfterLastItem := 10; FBeforeFirstItem := 0; FBeforeGroupHeader := 8; FBeforeItem := 2; FGroupHeight := 22; FItemHeight := 21; FMargin := 10; end; procedure TX2MenuBarunaMetrics.Assign(Source: TPersistent); begin if Source is TX2MenuBarunaMetrics then with TX2MenuBarunaMetrics(Source) do begin Self.AfterGroupHeader := AfterGroupHeader; Self.AfterItem := AfterItem; Self.AfterLastItem := AfterLastItem; Self.BeforeFirstItem := BeforeFirstItem; Self.BeforeGroupHeader := BeforeGroupHeader; Self.BeforeItem := BeforeItem; Self.GroupHeight := GroupHeight; Self.ItemHeight := ItemHeight; Self.Margin := Margin; end else inherited; end; procedure TX2MenuBarunaMetrics.SetAfterGroupHeader(const Value: Integer); begin if Value <> FAfterGroupHeader then begin FAfterGroupHeader := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetAfterItem(const Value: Integer); begin if Value <> FAfterItem then begin FAfterItem := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetAfterLastItem(const Value: Integer); begin if Value <> FAfterLastItem then begin FAfterLastItem := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetBeforeFirstItem(const Value: Integer); begin if Value <> FBeforeFirstItem then begin FBeforeFirstItem := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetBeforeGroupHeader(const Value: Integer); begin if Value <> FBeforeGroupHeader then begin FBeforeGroupHeader := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetBeforeItem(const Value: Integer); begin if Value <> FBeforeItem then begin FBeforeItem := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetGroupHeight(const Value: Integer); begin if Value <> FGroupHeight then begin FGroupHeight := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetItemHeight(const Value: Integer); begin if Value <> FItemHeight then begin FItemHeight := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetMargin(const Value: Integer); begin if Value <> FMargin then begin FMargin := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetImageOffsetX(const Value: Integer); begin if Value <> FImageOffsetX then begin FImageOffsetX := Value; Changed; end; end; procedure TX2MenuBarunaMetrics.SetImageOffsetY(const Value: Integer); begin if Value <> FImageOffsetY then begin FImageOffsetY := Value; Changed; end; end; { TX2MenuBarunaPainter } constructor TX2MenuBarunaPainter.Create(AOwner: TComponent); begin inherited; FArrowImageIndex := -1; FBlurShadow := True; FGroupColors := TX2MenuBarunaGroupColors.Create; FItemColors := TX2MenuBarunaColor.Create; FMetrics := TX2MenuBarunaMetrics.Create; FShadowOffset := 2; FBackground := TPicture.Create; FBackgroundHorzAlignment := haLeft; FBackgroundVertAlignment := vaTop; FGroupColors.OnChange := ColorChange; FItemColors.OnChange := ColorChange; FMetrics.OnChange := ColorChange; ResetColors; end; destructor TX2MenuBarunaPainter.Destroy; begin SetArrowImages(nil); FreeAndNil(FBackground); FreeAndNil(FMetrics); FreeAndNil(FItemColors); FreeAndNil(FGroupColors); inherited; end; procedure TX2MenuBarunaPainter.ResetColors; const PurpleBlue = $00BE6363; var groupColor: TColor; textColor: TColor; disabledColor: TColor; begin ArrowColor := clBlue; Color := clWindow; ShadowColor := clBtnShadow; { Group buttons } groupColor := Blend(Color, Color32(clBtnFace, 128)); GroupColors.Border.SetDefaultColors(PurpleBlue, clBlack, PurpleBlue, clBlack); GroupColors.Fill.SetDefaultColors(groupColor, groupColor, groupColor, groupColor); GroupColors.Text.SetDefaultColors(PurpleBlue, clWindowText, PurpleBlue, clGrayText); { Items } textColor := Blend(clGrayText, Color32(clWindowText, 128)); disabledColor := Blend(Color, Color32(clGrayText, 128)); ItemColors.SetDefaultColors(clWindowText, textColor, clWindowText, disabledColor); end; procedure TX2MenuBarunaPainter.SetBlurShadow(const Value: Boolean); begin if Value <> FBlurShadow then begin FBlurShadow := Value; NotifyObservers; end; end; function TX2MenuBarunaPainter.ApplyMargins(const ABounds: TRect): TRect; begin Result := inherited ApplyMargins(ABounds); InflateRect(Result, -Metrics.Margin, -Metrics.Margin); end; function TX2MenuBarunaPainter.UndoMargins(const ABounds: TRect): TRect; begin Result := inherited UndoMargins(ABounds); InflateRect(Result, Metrics.Margin, Metrics.Margin); end; function TX2MenuBarunaPainter.GetSpacing(AElement: TX2MenuBarSpacingElement): Integer; begin Result := inherited GetSpacing(AElement); case AElement of seBeforeGroupHeader: Result := Metrics.BeforeGroupHeader; seAfterGroupHeader: Result := Metrics.AfterGroupHeader; seBeforeFirstItem: Result := Metrics.BeforeFirstItem; seAfterLastItem: Result := Metrics.AfterLastItem; seBeforeItem: Result := Metrics.BeforeItem; seAfterItem: Result := Metrics.AfterItem; end; end; function TX2MenuBarunaPainter.GetGroupHeaderHeight(AGroup: TX2MenuBarGroup): Integer; begin Result := Metrics.GroupHeight; end; function TX2MenuBarunaPainter.GetItemHeight(AItem: TX2MenuBarItem): Integer; begin Result := Metrics.ItemHeight end; procedure TX2MenuBarunaPainter.DrawBackground(ACanvas: TCanvas; const ABounds: TRect; const AOffset: TPoint); var pos: TPoint; begin ACanvas.Brush.Color := Self.Color; ACanvas.FillRect(ABounds); if (Background.Width > 0) and (Background.Height > 0) then begin case BackgroundHorzAlignment of haLeft: pos.X := 0; haCenter: pos.X := (MenuBar.ClientWidth - Background.Width) div 2; haRight: pos.X := ABounds.Right - Background.Width; end; case BackgroundVertAlignment of vaTop: pos.Y := 0; vaCenter: pos.Y := (MenuBar.ClientHeight - Background.Height) div 2; vaBottom: pos.Y := MenuBar.ClientHeight - Background.Height; end; Dec(pos.X, AOffset.X); Dec(pos.Y, AOffset.Y); ACanvas.Draw(pos.X, pos.Y, Background.Graphic); end; end; procedure TX2MenuBarunaPainter.DrawGroupHeader(ACanvas: TCanvas; AGroup: TX2MenuBarGroup; const ABounds: TRect; AState: TX2MenuBarDrawStates); const ShadowMargin = 2; procedure DrawShadowOutline(AShadowCanvas: TCanvas; AShadowBounds: TRect); begin AShadowCanvas.Brush.Color := ShadowColor; AShadowCanvas.Pen.Color := ShadowColor; AShadowCanvas.RoundRect(AShadowBounds.Left + ShadowMargin, AShadowBounds.Top + ShadowMargin, AShadowBounds.Right + ShadowMargin, AShadowBounds.Bottom + ShadowMargin, 5, 5); end; function GetColor(AColor: TX2MenuBarunaColor): TColor; begin if AGroup.Enabled then if (mdsSelected in AState) or (mdsGroupSelected in AState) then Result := AColor.Selected else if mdsHot in AState then Result := AColor.Hot else Result := AColor.Normal else Result := AColor.Disabled; end; var imageList: TCustomImageList; imagePos: TPoint; shadowBitmap: Graphics.TBitmap; shadowBounds: TRect; textRect: TRect; clipRegion: HRGN; startColor: TColor; endColor: TColor; groupOffset: TPoint; begin if not ((mdsSelected in AState) or (mdsGroupSelected in AState)) then begin { Shadow } if BlurShadow then begin shadowBitmap := Graphics.TBitmap.Create; try shadowBitmap.PixelFormat := pf32bit; shadowBitmap.Width := (ABounds.Right - ABounds.Left + (ShadowMargin * 2)); shadowBitmap.Height := (ABounds.Bottom - ABounds.Top + (ShadowMargin * 2)); shadowBounds := Rect(0, 0, shadowBitmap.Width, shadowBitmap.Height); groupOffset := ABounds.TopLeft; DrawBackground(shadowBitmap.Canvas, shadowBounds, groupOffset); DrawShadowOutline(shadowBitmap.Canvas, Rect(0, 0, shadowBitmap.Width - (ShadowMargin * 2), shadowBitmap.Height - (ShadowMargin * 2))); Blur(shadowBitmap); ACanvas.Draw(ABounds.Left, ABounds.Top, shadowBitmap); finally FreeAndNil(shadowBitmap); end end else begin shadowBounds := ABounds; OffsetRect(shadowBounds, -ShadowMargin, -ShadowMargin); DrawShadowOutline(ACanvas, ABounds); end; end; { Rounded rectangle } startColor := GetColor(GroupColors.Fill); endColor := startColor; if GroupGradient > 0 then endColor := LightenColor(startColor, GroupGradient) else if GroupGradient < 0 then endColor := DarkenColor(startColor, -GroupGradient); clipRegion := CreateRoundRectRgn(ABounds.Left, ABounds.Top, ABounds.Right, ABounds.Bottom, 5, 5); SelectClipRgn(ACanvas.Handle, clipRegion); GradientFillRect(ACanvas, ABounds, startColor, endColor); SelectClipRgn(ACanvas.Handle, 0); DeleteObject(clipRegion); ACanvas.Brush.Style := bsClear; ACanvas.Pen.Color := GetColor(GroupColors.Border); ACanvas.Pen.Style := psSolid; ACanvas.RoundRect(ABounds.Left, ABounds.Top, ABounds.Right, ABounds.Bottom, 5, 5); ACanvas.Brush.Style := bsSolid; ACanvas.Font.Color := GetColor(GroupColors.Text); textRect := ABounds; Inc(textRect.Left, 4); Dec(textRect.Right, 4); { Image } imageList := AGroup.MenuBar.Images; if Assigned(imageList) then begin if AGroup.ImageIndex > -1 then begin imagePos.X := textRect.Left; imagePos.Y := ABounds.Top + ((ABounds.Bottom - ABounds.Top - imageList.Height) div 2); Inc(imagePos.X, Metrics.ImageOffsetX); Inc(imagePos.Y, Metrics.ImageOffsetY); imageList.Draw(ACanvas, imagePos.X, imagePos.Y, AGroup.ImageIndex); end; Inc(textRect.Left, imageList.Width + 4); end; { Text } ACanvas.Font.Style := [fsBold]; SetBkMode(ACanvas.Handle, TRANSPARENT); DrawText(ACanvas, AGroup.Caption, textRect, taLeftJustify, taVerticalCenter, False, csEllipsis); end; procedure TX2MenuBarunaPainter.DrawItem(ACanvas: TCanvas; AItem: TX2MenuBarItem; const ABounds: TRect; AState: TX2MenuBarDrawStates); function GetColor(AColor: TX2MenuBarunaColor): TColor; begin if AItem.Enabled then if mdsSelected in AState then Result := AColor.Selected else if mdsHot in AState then Result := AColor.Hot else Result := AColor.Normal else Result := AColor.Disabled; end; var focusBounds: TRect; textBounds: TRect; begin focusBounds := ABounds; if HasArrowImage then Dec(focusBounds.Right, ArrowImages.Width + ArrowMargin) else Dec(focusBounds.Right, ArrowWidth + ArrowMargin); if (mdsSelected in AState) then begin { Focus rectangle and arrow } DrawFocusRect(ACanvas, focusBounds); DrawArrow(ACanvas, ABounds); end; { Text } ACanvas.Font.Color := GetColor(ItemColors); textBounds := focusBounds; Inc(textBounds.Left, 4); Dec(textBounds.Right, 4); if not AItem.Visible then { Design-time } ACanvas.Font.Style := [fsItalic] else ACanvas.Font.Style := []; SetBkMode(ACanvas.Handle, TRANSPARENT); DrawText(ACanvas, AItem.Caption, textBounds, taRightJustify, taVerticalCenter, False, csEllipsis); end; procedure TX2MenuBarunaPainter.DrawArrow(ACanvas: TCanvas; ABounds: TRect); var arrowX: Integer; arrowY: Integer; arrowPoints: array[0..2] of TPoint; begin if HasArrowImage then begin arrowX := ABounds.Right - ArrowImages.Width; arrowY := ABounds.Top + ((ABounds.Bottom - ABounds.Top - ArrowImages.Height) div 2); ArrowImages.Draw(ACanvas, arrowX, arrowY, ArrowImageIndex); end else begin ACanvas.Brush.Color := ArrowColor; ACanvas.Pen.Color := ArrowColor; arrowPoints[0].X := ABounds.Right - 8; arrowPoints[0].Y := ABounds.Top + ((ABounds.Bottom - ABounds.Top - 15) div 2) + 7; arrowPoints[1].X := Pred(ABounds.Right); arrowPoints[1].Y := arrowPoints[0].Y - 7; arrowPoints[2].X := Pred(ABounds.Right); arrowPoints[2].Y := arrowPoints[0].Y + 7; ACanvas.Polygon(arrowPoints); end; end; procedure TX2MenuBarunaPainter.ColorChange(Sender: TObject); begin NotifyObservers; end; function TX2MenuBarunaPainter.HasArrowImage: Boolean; begin Result := Assigned(ArrowImages) and (ArrowImageIndex > -1); end; procedure TX2MenuBarunaPainter.Notification(AComponent: TComponent; Operation: TOperation); begin if (Operation = opRemove) and (AComponent = FArrowImages) then SetArrowImages(nil); inherited; end; procedure TX2MenuBarunaPainter.SetGroupColors(const Value: TX2MenuBarunaGroupColors); begin if Value <> FGroupColors then begin FGroupColors.Assign(Value); NotifyObservers; end; end; procedure TX2MenuBarunaPainter.SetItemColors(const Value: TX2MenuBarunaColor); begin if Value <> FItemColors then begin FItemColors.Assign(Value); NotifyObservers; end; end; procedure TX2MenuBarunaPainter.SetMetrics(const Value: TX2MenuBarunaMetrics); begin if Value <> FMetrics then begin FMetrics.Assign(Value); NotifyObservers; end; end; procedure TX2MenuBarunaPainter.SetShadowColor(const Value: TColor); begin if Value <> FShadowColor then begin FShadowColor := Value; NotifyObservers; end; end; procedure TX2MenuBarunaPainter.SetShadowOffset(const Value: Integer); begin if Value <> FShadowOffset then begin FShadowOffset := Value; NotifyObservers; end; end; procedure TX2MenuBarunaPainter.SetGroupGradient(const Value: Integer); begin if Value <> FGroupGradient then begin FGroupGradient := Value; NotifyObservers; end; end; procedure TX2MenuBarunaPainter.SetArrowImageIndex(const Value: TImageIndex); begin if Value <> FArrowImageIndex then begin FArrowImageIndex := Value; NotifyObservers; end; end; procedure TX2MenuBarunaPainter.SetArrowImages(const Value: TCustomImageList); begin if Value <> FArrowImages then begin if Assigned(FArrowImages) then FArrowImages.RemoveFreeNotification(Self); FArrowImages := Value; if Assigned(FArrowImages) then FArrowImages.FreeNotification(Self); NotifyObservers; end; end; procedure TX2MenuBarunaPainter.SetBackground(const Value: TPicture); begin FBackground.Assign(Value); NotifyObservers; end; procedure TX2MenuBarunaPainter.SetBackgroundHorzAlignment(const Value: THorzAlignment); begin if Value <> FBackgroundHorzAlignment then begin FBackgroundHorzAlignment := Value; NotifyObservers; end; end; procedure TX2MenuBarunaPainter.SetBackgroundVertAlignment(const Value: TVertAlignment); begin if Value <> FBackgroundVertAlignment then begin FBackgroundVertAlignment := Value; NotifyObservers; end; end; { TX2MenuBarunaProperty } procedure TX2MenuBarunaProperty.Changed; begin if Assigned(FOnChange) then FOnChange(Self); end; { TX2MenuBarunaColor } procedure TX2MenuBarunaColor.Assign(Source: TPersistent); begin if Source is TX2MenuBarunaColor then with TX2MenuBarunaColor(Source) do begin Self.DefaultDisabled := DefaultDisabled; Self.DefaultHot := DefaultHot; Self.DefaultNormal := DefaultNormal; self.DefaultSelected := DefaultSelected; Self.Disabled := Disabled; Self.Hot := Hot; Self.Normal := Normal; self.Selected := Selected; end else inherited; end; function TX2MenuBarunaColor.IsDisabledStored: Boolean; begin Result := (FDisabled <> FDefaultDisabled); end; function TX2MenuBarunaColor.IsHotStored: Boolean; begin Result := (FHot <> FDefaultHot); end; function TX2MenuBarunaColor.IsNormalStored: Boolean; begin Result := (FNormal <> FDefaultNormal); end; function TX2MenuBarunaColor.IsSelectedStored: Boolean; begin Result := (FSelected <> FDefaultSelected); end; procedure TX2MenuBarunaColor.SetDefaultColors(AHot, ANormal, ASelected, ADisabled: TColor); begin FDefaultDisabled := ADisabled; FDefaultHot := AHot; FDefaultNormal := ANormal; FDefaultSelected := ASelected; FDisabled := ADisabled; FHot := AHot; FNormal := ANormal; FSelected := ASelected; end; procedure TX2MenuBarunaColor.SetDisabled(const Value: TColor); begin if Value <> FDisabled then begin FDisabled := Value; Changed; end; end; procedure TX2MenuBarunaColor.SetHot(const Value: TColor); begin if Value <> FHot then begin FHot := Value; Changed; end; end; procedure TX2MenuBarunaColor.SetNormal(const Value: TColor); begin if Value <> FNormal then begin FNormal := Value; Changed; end; end; procedure TX2MenuBarunaColor.SetSelected(const Value: TColor); begin if Value <> FSelected then begin FSelected := Value; Changed; end; end; { TX2MenuBarunaGroupColors } constructor TX2MenuBarunaGroupColors.Create; begin inherited; FBorder := TX2MenuBarunaColor.Create; FFill := TX2MenuBarunaColor.Create; FText := TX2MenuBarunaColor.Create; FBorder.OnChange := ColorChange; FFill.OnChange := ColorChange; FText.OnChange := ColorChange; end; destructor TX2MenuBarunaGroupColors.Destroy; begin FreeAndNil(FText); FreeAndNil(FFill); FreeAndNil(FBorder); inherited; end; procedure TX2MenuBarunaGroupColors.Assign(Source: TPersistent); begin if Source is TX2MenuBarunaGroupColors then with TX2MenuBarunaGroupColors(Source) do begin Self.Border.Assign(Border); Self.Fill.Assign(Fill); Self.Text.Assign(Text); end else inherited; end; procedure TX2MenuBarunaGroupColors.ColorChange(Sender: TObject); begin Changed; end; procedure TX2MenuBarunaGroupColors.SetBorder(const Value: TX2MenuBarunaColor); begin if Value <> FBorder then begin FBorder.Assign(Value); Changed; end; end; procedure TX2MenuBarunaGroupColors.SetFill(const Value: TX2MenuBarunaColor); begin if Value <> FFill then begin FFill.Assign(Value); Changed; end; end; procedure TX2MenuBarunaGroupColors.SetText(const Value: TX2MenuBarunaColor); begin if Value <> FText then begin FText.Assign(Value); Changed; end; end; end.