Archivado/Componentes.Terceros.jvcl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
Componentes.Terceros.jvcl/official/3.39/examples/JvDocking/MSDN2002/Source/XPBarMenu.pas
david 78ab77cd4c Importación inicial 
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.jvcl@19 7f62d464-2af8-f54e-996c-e91b33f51cbe
2010-01-18 16:55:50 +00:00

2354 lines
68 KiB
ObjectPascal
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{
/// FileName:XPMenu.pas
XPMenu for Delphi
Author: Khaled Shagrouni
URL: http://www.shagrouni.com
e-mail: shagrouni@hotmail.com
Version 1.504, Septemper 5, 2001
/// Under Lines Add By Kingron
Modified: Kingron
Data: 2001.09.29
E_Mail:Kingron@163.net
WWW: http://Kingron.myetang.com
I hold the copyright of the modificatory code,If you make any modifications to
the code, please send them to me.Any question the component,Please Mail to me
Note:
- I Only Test the Component Under Win2K & Win98SE,May be not fit other OS.
/// End Add
XPMenu is a Delphi component to mimic Office XP menu and toolbar style.
Copyright (C) 2001 Khaled Shagrouni.
This component is FREEWARE with source code. I still hold the copyright.
If you have any ideas for improvement or bug reports, don't hesitate to e-mail me.
History:
========
/// Under Lines Add By Kingron
2001.10.4
- Fix Some Bugs,Ex:FlatMenu's Memory Hole~~~!
2001.10.1
- Optimize the Draw Speed For Win9x
- Fix The MenuItem Bitmap Transparent bug under Win9x
- Fix Other Bugs Under Win9x
- Fix Top MenuItem Bitmap Draw Bug.
- Use Double buffer to Draw the Bar(Text Only),Improve the Draw Speed.
2001.09.30
- Support Event Process.
OnDrawItem,OnMeasureItem,OnDrawBar,OnMeasureBar
- Adding a Example For Delphi 5.0.
- Fix a bug: Count Bar Height Error when user define the System Menu appearance
- Fix the Default MenuItem Display.
- Fix some Bugs Under Win9x.
2001.09.29
- Left Bar Support Stretch(Bitmap Only).
- Fix some Bugs
- Support 3D Style
2001.09.28
- Adding Left Bar,Support Bitmap and Text.
- Left Bar(Text Only) Support Gradient Color.
Known Bugs:
- Under Win9x,the FlatMenu property has some problam.
if use the component under Win9x,Please don't set the FlatMenu to False.
- Under Win9x,if you both use the ImageList and MenuItem.Bitmap,the Bar Height calc err.
You can use the Event to Special Process to avoid it!
- If SubMenu Level more than 3,Draw Speed Very Slow~~~~~~~
Because the Component recursion search all MenuItem of the Form!
I hope I can improve the arithmetic to fix this soon, help from others appreciated.
- if User Change The System Menu appearance,the Bar Calc Err.
Please Process SYSTEM SETTING CHANGE Message,Set the property UseSystemColors:=False then
Set the Property UseSystemColors := True
- May be not compatibly with other program,Ex: ScreenSave,Meet it infrequent.
- Under Win9x,if not use the Gradient Propety,the IconBack has some problem.
- Big Bug:Resource Not Free~~~~,Checking~~~~~~
OK: Don't use FlatMenu,the property Cause the Memory hole when the program running~~~~
But when the program exit,the Memory get back.
/// End Add
Sept 5, 2001, V1.504
- Removing some problematic code lines in the procedure: ToolBarDrawButton.
This code causes unwanted effect on desktop when activating the component
at run time with form contains a ToolBarButton with MenuItem.
Sept 4, 2001, V1.503
- Bug fixed.
Sept 3, 2001, V1.502
- Bugs fixed.
Sept 1, 2001, V1.501
- Some minor changes and bugs fixed.
July 29, 2001, V1.501 (Beta)
- Adding AutoDetect property.
- Compatibility issues with Delphi4.
July 25, 2001, V1.5
- Support for TToolbar.
- Getting closer to XP style appearance.
- New options.
june 23, 2001
- Compatibility issues with Delphi4.
- Changing the way of menus itration.
- Making the blue select rectangle little thinner.
june 21, 2001
Bug fixes:
- Items correctly sized even if no image list assigned.
- Shaded colors for top menu items if fixed for some menu bar colors.
(Actually the bugs was due to two statements deleted by me stupidly/accidentally)
June 19, 2001
This component is based on code which I have posted at Delphi3000.com
(http://www.delphi3000/articles/article_2246.asp) and Borland Code-Central
(http://codecentral.borland.com/codecentral/ccweb.exe/listing?id=16120).
Installation
A. Unzip the files: XPMENU.PAS and XPMENU.DCR Into the same directory.
B. From Delphi menu, Select File| New: Package.
C. Press Add, and browse to add the unit XPMENU.PAS.
D. Press Install.
E. The component is now installed in a new 'XP' page.
F. Save the package.
If you have a previous version installed:
Replace the old files (xpmenu.pas and xpmenu.dcr) with the new one,
open the package and recompile.
If you encounter any problems remove all the compiled units .dcu, .bpl, .dcp
(try to locate them also in 'C:\Program Files\Borland\DelphiX\Projects\Bpl' and
'C:\Program Files\Borland\DelphiX\lib'), then install pre-compiled units again.
--------------------------------------------------------------------------------
Notes on proprties:
Active property:
To activate/deactivate xpMenu, also, set this property to True when new items
added at run time.
AutoDetect property:
Set this property to True to force xpMenu to include new added items
automatically.
UseSystemColors property:
The global windows color scheme will be used, setting this property to true
will override other color related properties.
OverrideOwnerDraw property:
By default, xpMenu will not affect menu items that has owner draw handler
assigned (any code in OnDrawItem event). To override any custom draw set this property to true.
Gradient property:
IconBackcolor will be used as a gradient color for the entire menu,
Color property wil be ignored.
FlatMenu property:
To turn menu's border to flat (drop-down and pop-up menu). Any way, a flat
effect will not appear until a menu item is selected, also unwanted effect
come across if there is submenu item selected. I hope I can fix this soon,
help from others appreciated.
Form property:
The default is the host form, if you want to target a different
form other than the one hosting the component; set Form property to that form.
--------------------------------------------------------------------------------
ImageLists:
For toolbars only ImageList assigned to Images property is used; xpMenu
automatically generate dim and grayed images for non-hot and disabled items.
Buttons with tbsDivider style:
xpMenu cannot draw toolbar buttons with tbsDivider style, Windows override any
owner draw for this style (I am using Win 98). To work around this, set the
button style to tbsSeparator and set its Tag property to none zero value.
Creation order:
Make sure that the creation order of TXPMenu comes after any menu or toolbar
component. To change the creation order, choose Edit | Creation Order from
Delphi menu to open the Creation Order dialog box.
--------------------------------------------------------------------------------
Known issues:
- xpMenu supports menus only in Delphi 4.
- xpMenu doesn't detect menus and toolbars inside Frame, the work-around for
this is to add xpMenu component in the Frame it self.
--------------------------------------------------------------------------------
Tips:
How to create menu toolbar:
(Extracted from Delphi Help - TToolButton.MenuItem)
To create an "IE4-style" (Office-style) toolbar that corresponds to
an existing menu:
1 Drop a ToolBar on the form and add a ToolButton for each top-level menu
item you wish to create.
2 Set the MenuItem property of each ToolButton to correspond to the top level
menu items.
3 Set the Grouped property of each ToolButton to True.
4 Clear the MainMenu property of the Form (if it is assigned)
Images in toolbars and menus:
To make an image transparent, be sure to fill the background with a unique
color-a color your image is not using. Also, make sure that the color of the
bottom leftmost pixel shown onscreen has the same background color; xpMenu will
use this pixel to determine the transparent color.
}
//______________________________________________________________________________
{$IFDEF VER130}
{$DEFINE VER5U}
{$ENDIF}
{$IFDEF VER140}
{$DEFINE VER5U}
{$ENDIF}
unit XPBarMenu;
interface
uses
Windows, SysUtils, Classes, Graphics, Controls, ComCtrls, Forms,
Menus, Messages, Commctrl;
/// Under Lines Add By Kingron
type
TBarStyle = (bsText, bsBitmap, bsNone);
TDrawBarEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect; var CanDraw: Boolean) of object;
TMeasureBarEvent = procedure(Sender: TObject; ACanvas: TCanvas; var ARect, BarRect: TRect) of object;
/// End Add
type
TXPBarMenu = class(TComponent)
private
FActive: boolean;
FForm: TForm;
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;
FFColor, FFIconBackColor, FFSelectColor, FFSelectBorderColor,
FFSelectFontColor, FCheckedAreaColor, FCheckedAreaSelectColor,
FFCheckedColor, FFMenuBarColor, FFDisabledColor, FFSeparatorColor,
FMenuBorderColor, FMenuShadowColor: TColor;
Is16Bit: boolean;
FOverrideOwnerDraw: boolean;
FGradient: boolean;
FFlatMenu: boolean;
FAutoDetect: boolean;
/// Under Lines Add By Kingron
FItemHeight: integer;
FFrame3D: boolean;
FOnDrawBar: TDrawBarEvent;
FOnMeasureBar: TMeasureBarEvent;
FBarStretch: boolean;
FBarCaption: string;
FBarWidth: integer;
FBarColorStart: TColor;
FBarColorEnd: TColor;
FBarBitmap: TBitmap;
FBarFont: TFont;
FBarStyle: TBarStyle;
FOnDrawItem: TMenuDrawItemEvent;
FOnMeasureItem: TMenuMeasureItemEvent;
FBarColorStep: integer;
/// End Add
procedure SetActive(const Value: boolean);
procedure SetForm(const Value: TForm);
procedure SetFont(const Value: TFont);
procedure SetMenuBarColor(const Value: TColor);
procedure SetUseSystemColors(const Value: boolean);
procedure SetOverrideOwnerDraw(const Value: boolean);
/// Under Lines Add By Kingron
function CanDrawBar: boolean;
procedure SetBarFont(const Value: TFont);
procedure SetBarBitmap(const Value: TBitmap);
procedure SetBarColorStep(const Value: integer);
function _IsOSoK:boolean;
/// End Add
protected
/// Under Lines Add By Kingron
procedure DrawBar(Sender: TObject; ACanvas: TCanvas; ARect: TRect);
/// End Add
procedure InitMenueItems(Form: TScrollingWinControl; Enable: boolean);
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 ActivateMenuItem(MenuItem: TMenuItem);
procedure SetGlobalColor(ACanvas: TCanvas);
procedure DrawTopMenuItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
IsRightToLeft: boolean);
procedure DrawCheckedItem(FMenuItem: TMenuItem; Selected,
HasImgLstBitmap: boolean; ACanvas: TCanvas; CheckedRect: TRect);
procedure DrawTheText(txt, ShortCuttext: string; ACanvas: TCanvas;
TextRect: TRect; Selected, Enabled, Default, TopMenu,
IsRightToLeft: boolean; TextFormat: integer);
procedure DrawIcon(Sender: TObject; ACanvas: TCanvas; B: TBitmap;
IconRect: Trect; Hot, Selected, Enabled, Checked, FTopMenu,
IsRightToLeft: boolean);
procedure DrawArrow(ACanvas: TCanvas; X, Y: integer);
procedure MeasureItem(Sender: TObject; ACanvas: TCanvas;
var Width, Height: Integer);
function GetImageExtent(MenuItem: TMenuItem): TPoint;
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;
property Form: TForm read FForm write SetForm;
published
/// Under Lines Add By Kingron
property BarStretch: boolean read FBarStretch write FBarStretch default true;
property Frame3D: boolean read FFrame3D write FFrame3D default false;
property BarWidth: integer read FBarWidth write FBarWidth default 22;
property BarCaption: string read FBarCaption write FBarCaption;
property BarBitmap: TBitmap read FBarBitmap write SetBarBitmap;
property BarColorStart: TColor read FBarColorStart write FBarColorStart default clBlue;
property BarColorEnd: TColor read FBarColorEnd write FBarColorEnd default clBlack;
property BarColorStep: integer read FBarColorStep write SetBarColorStep default 100;
property BarStyle: TBarStyle read FBarStyle write FBarStyle default bsText;
property BarFont: TFont read FBarFont write SetBarFont;
property ItemHeight: integer read FItemHeight write FItemHeight default 0;
property OnDrawItem: TMenuDrawItemEvent read FOnDrawItem write FOnDrawItem;
property OnMeasureItem: TMenuMeasureItemEvent read FOnMeasureItem write FOnMeasureItem;
property OnDrawBar: TDrawBarEvent read FOnDrawBar write FOnDrawBar;
property OnMeasureBar: TMeasureBarEvent read FOnMeasureBar write FOnMeasureBar;
/// End Add
property Font: TFont read FFont write SetFont;
property Color: TColor read FColor write FColor default clMenu;
property IconBackColor: TColor read FIconBackColor write FIconBackColor default clMenu;
property MenuBarColor: TColor read FMenuBarColor write SetMenuBarColor default clMenu;
property SelectColor: TColor read FSelectColor write FSelectColor default clHighlight;
property SelectBorderColor: TColor read FSelectBorderColor write FSelectBorderColor default clActiveBorder;
property SelectFontColor: TColor read FSelectFontColor write FSelectFontColor default clHighlightText;
property DisabledColor: TColor read FDisabledColor write FDisabledColor default clGray;
property SeparatorColor: TColor read FSeparatorColor write FSeparatorColor default clGray;
property CheckedColor: TColor read FCheckedColor write FCheckedColor;
property IconWidth: integer read FIconWidth write FIconWidth;
property DrawSelect: boolean read FDrawSelect write FDrawSelect;
property UseSystemColors: boolean read FUseSystemColors write SetUseSystemColors;
property OverrideOwnerDraw: boolean read FOverrideOwnerDraw write SetOverrideOwnerDraw;
property Gradient: boolean read FGradient write FGradient default true;
property FlatMenu: boolean read FFlatMenu write FFlatMenu;
property AutoDetect: boolean read FAutoDetect write FAutoDetect;
property Active: boolean read FActive write SetActive;
end;
function GetShadeColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
function NewColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
procedure DimBitmap(ABitmap: TBitmap; Value: integer);
function GrayColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
procedure GrayBitmap(ABitmap: TBitmap; Value: integer);
procedure DrawBitmapShadow(B: TBitmap; ACanvas: TCanvas; X, Y: integer;
ShadowColor: TColor);
procedure GetSystemMenuFont(Font: TFont);
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TXPBarMenu]); ///Registry Control Pages Modified By Kingron
end;
{ TXPBarMenue }
constructor TXPBarMenu.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFont := TFont.Create;
GetSystemMenuFont(FFont);
FForm := Owner as TForm;
FUseSystemColors := true;
FColor := clMenu;
FIconBackColor := clMenu;
FSelectColor := clHighlight;
FSelectBorderColor := clActiveBorder;
FMenuBarColor := clMenu;
FDisabledColor := clGray;
FSeparatorColor := clGray;
FCheckedColor := clHighlight;
FSelectFontColor := clHighlightText;
FIconWidth := 24;
FDrawSelect := true;
///Under Line Add By Kingron
FFlatMenu := True;
FActive := True;
FAutoDetect := True;
FGradient := True;
FFrame3D := False;
FBarStretch := True;
FBarCaption := FForm.Caption; /// Bar Default Caption
FItemHeight := 0; /// Default Item Height
FBarWidth := 22; /// Bar Width
FBarColorStart := clBlue; /// The First Color
FBarColorEnd := clBlack; /// The Second Color
FBarColorStep := 100;
FBarFont := TFont.Create; /// Bar Text Font
FBarFont.Assign(FFont); /// Bar Font Init
FBarFont.Color := clWhite;
FBarBitmap := TBitmap.Create; /// Bar Bitmap
FBarStyle := bsText; /// Bar Style
/// End Add
if FActive then
begin
InitMenueItems(FForm, true);
end;
end;
destructor TXPBarMenu.Destroy;
begin
InitMenueItems(FForm, False);
FFont.Free;
/// Under Lines Add By Kingron
FBarFont.Free;
FreeAndNil(FBarBitmap);
/// End Add
inherited;
end;
procedure TXPBarMenu.ActivateMenuItem(MenuItem: TMenuItem);
procedure Activate(MenuItem: TMenuItem);
begin
if addr(MenuItem.OnDrawItem) <> addr(TXPBarMenu.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);
for i := 0 to MenuItem.Parent.Count - 1 do
begin
Activate(MenuItem.Parent.Items[i]);
for j := 0 to MenuItem.Parent.Items[i].Count - 1 do
ActivateMenuItem(MenuItem.Parent.Items[i].Items[j]);
end;
end;
procedure TXPBarMenu.InitMenueItems(Form: TScrollingWinControl; Enable: boolean);
procedure Activate(MenuItem: TMenuItem);
begin
if Enable 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
else
begin
if addr(MenuItem.OnDrawItem) = addr(TXPBarMenu.DrawItem) then
MenuItem.OnDrawItem := nil;
if addr(MenuItem.OnMeasureItem) = addr(TXPBarMenu.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
ItrateMenu(MenuItem.Items[i]);
end;
var
i, x : integer;
begin
for i := 0 to Form.ComponentCount - 1 do
begin
if Form.Components[i] is TMainMenu then
begin
for x := 0 to TMainMenu(Form.Components[i]).Items.Count - 1 do
begin
TMainMenu(Form.Components[i]).OwnerDraw := Enable;
Activate(TMainMenu(Form.Components[i]).Items[x]);
ItrateMenu(TMainMenu(Form.Components[i]).Items[x]);
end;
end;
if Form.Components[i] is TPopupMenu then
begin
for x := 0 to TPopupMenu(Form.Components[i]).Items.Count - 1 do
begin
TPopupMenu(FForm.Components[i]).OwnerDraw := Enable;
Activate(TMainMenu(Form.Components[i]).Items[x]);
ItrateMenu(TMainMenu(Form.Components[i]).Items[x]);
end;
end;
{$IFDEF VER5U}
if Form.Components[i] is TToolBar then
if not (csDesigning in ComponentState) then
begin
if not TToolBar(Form.Components[i]).Flat then
TToolBar(Form.Components[i]).Flat := true;
if Enable then
begin
for x := 0 to TToolBar(FForm.Components[i]).ButtonCount - 1 do
if (not assigned(TToolBar(Form.Components[i]).OnCustomDrawButton))
or (FOverrideOwnerDraw) then
begin
TToolBar(FForm.Components[i]).OnCustomDrawButton :=
ToolBarDrawButton;
end;
end
else
begin
if addr(TToolBar(Form.Components[i]).OnCustomDrawButton) =
addr(TXPBarMenu.ToolBarDrawButton) then
TToolBar(Form.Components[i]).OnCustomDrawButton := nil;
end;
end;
{$ENDIF}
end;
end;
procedure TXPBarMenu.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
begin
if FActive then
begin
MenueDrawItem(Sender, ACanvas, ARect, Selected);
/// Under Line Add By Kingron, Add OnDrawItem Event Process
if Assigned(FOnDrawItem) then
FOnDrawItem(Sender, ACanvas, ARect, Selected);
/// End Add
end;
end;
function TXPBarMenu.GetImageExtent(MenuItem: TMenuItem): TPoint;
var
HasImgLstBitmap : boolean;
B : TBitmap;
FTopMenu : boolean;
begin
FTopMenu := false;
B := TBitmap.Create;
B.Width := 0;
B.Height := 0;
Result.x := 0;
Result.Y := 0;
HasImgLstBitmap := false;
if FForm.Menu <> nil then
if MenuItem.GetParentComponent.Name = FForm.Menu.Name then
begin
FTopMenu := true;
if FForm.Menu.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(MenuItem.Bitmap);
Result.x := B.Width;
Result.Y := B.Height;
if not FTopMenu and not HasImgLstBitmap then
if Result.x < FIconWidth then
Result.x := FIconWidth;
B.Free;
end;
procedure TXPBarMenu.MeasureItem(Sender: TObject; ACanvas: TCanvas;
var Width, Height: Integer);
var
s : string;
W, H : integer;
P : TPoint;
IsLine : boolean;
/// Under Lines Add By Kingron
FMenu : TMenu;
FMenuItem : TMenuItem;
i : integer;
FTopMenu : boolean;
/// End Add
begin
if FActive then
begin
FMenuItem := TMenuItem(Sender);
S := FMenuItem.Caption;
//------
if S = '-' then IsLine := true else IsLine := false;
/// Under Lines Comment By Kingron
/// if IsLine then
/// End Comment
//------
if IsLine then
S := '';
if Trim(ShortCutToText(FMenuItem.ShortCut)) <> '' then
S := S + ShortCutToText(FMenuItem.ShortCut) + 'WWW';
ACanvas.Font.Assign(FFont);
W := ACanvas.TextWidth(s);
if pos('&', s) > 0 then
W := W - ACanvas.TextWidth('&');
P := GetImageExtent(FMenuItem);
W := W + P.x + 10;
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 + 4 > H then
H := P.y + 4;
if Height < H then
Height := H;
end;
///Under Lines Add By Kingron
//// <20><><EFBFBD><EFBFBD><EFBFBD>ط<EFBFBD><D8B7>д<EFBFBD><D0B4>ڸĽ<DAB8><C4BD>㷨<EFBFBD><E3B7A8><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ܲ<EFBFBD><DCB2>ܲ<EFBFBD>ʹ<EFBFBD><CAB9>ѭ<EFBFBD><D1AD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ٶ<EFBFBD>̫<EFBFBD><CCAB>~~~~~~
if CanDrawBar then /// Should Draw the Bar
begin
FTopMenu := False;
FMenu := FMenuItem.Parent.GetParentMenu;
if FMenu is TMainMenu then /// Search For Top Level Item?
begin
for i := 0 to FMenuItem.GetParentMenu.Items.Count - 1 do
if FMenuItem.GetParentMenu.Items[i] = FMenuItem then /// Yes!
begin
FTopMenu := True;
break;
end;
end;
if not FTopMenu then /// Should Not be the TOP Level Item!
Inc(Width, FBarWidth + 2); /// Add Width For the Bar
if FItemHeight <> 0 then /// User Define Item Height!
Height := FItemHeight;
end;
if Assigned(FOnMeasureItem) then
FOnMeasureItem(Sender, ACanvas, Width, Height);
/// End Add
end;
end;
procedure TXPBarMenu.MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
var
txt : string;
B : TBitmap;
IconRect, TextRect, CheckedRect: TRect;
i, X1, X2 : integer;
TextFormat : integer;
HasImgLstBitmap : boolean;
FMenuItem : TMenuItem;
FMenu : TMenu;
FTopMenu : boolean;
ISLine : boolean;
ImgListHandle : HImageList; {Commctrl.pas}
ImgIndex : integer;
hWndM : HWND;
hDcM : HDC;
/// Under Add By Kingron
FBarHeight : integer;
BarRect : TRect;
/// End Add
/// Under Function Add By Kingron
function GetItemHeigth(Sender: TObject): integer;
var
Width, Height : Integer;
begin
Height := 0;
MeasureItem(Sender, ACanvas, Width, Height);
Result := Height;
end;
/// End Function Add
begin
FTopMenu := false;
FMenuItem := TMenuItem(Sender);
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;
break;
end;
/// Under Lines Add By Kingron
if not FTopMenu and CanDrawBar then
begin
FBarHeight := 0; /// Count For the Bar height
for i := 0 to FMenuItem.Parent.Count - 1 do
if FMenuItem.Parent.Items[i].Visible then
if FItemHeight <> 0 then /// if User Define the Item Height?
Inc(FBarHeight, FItemHeight) /// Yes,Should Add the Define ItemHeight
else
if FMenuItem.Parent.Items[i].IsLine then /// Is -------?
Inc(FBarHeight, 4) /// The Line's Default Height!
else
Inc(FBarHeight, GetItemHeigth(FMenuItem.Parent.Items[i])); /// Add Default ItemHeight;
Dec(ARect.Right, FBarWidth); /// Adjust RECT for the Bar!
/// if You wan't Left a room for bar between,please modify: FBarWidth to FBarWidth - 1
OffsetRect(ARect, FBarWidth, 0);
BarRect := Rect(1, 1, FBarWidth, FBarHeight);
if Assigned(FOnMeasureBar) then
FOnMeasureBar(Sender, ACanvas, ARect, BarRect);
DrawBar(Sender, ACanvas, BarRect); /// Draw the Bar
end;
/// End Add
ACanvas.Font.Assign(FFont);
if FMenu.IsRightToLeft then
ACanvas.Font.Charset := ARABIC_CHARSET;
Inc(ARect.Bottom, 1);
TextRect := ARect;
txt := ' ' + FMenuItem.Caption;
B := TBitmap.Create;
HasImgLstBitmap := false;
if FMenuItem.Bitmap.Width > 0 then
B.Assign(TBitmap(FMenuItem.Bitmap));
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 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 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 FMenu.IsRightToLeft then
begin
X1 := ARect.Left;
X2 := ARect.Right - FIconWidth;
if B.Width > FIconWidth then
X2 := ARect.Right - B.Width - 4;
end
else
begin
X1 := ARect.Left + FIconWidth;
if B.Width > X1 then
X1 := B.Width + 4;
X2 := ARect.Right;
end;
TextRect := Rect(X1, ARect.Top, X2, ARect.Bottom);
if FTopMenu then
begin
if not HasImgLstBitmap then
begin
TextRect := ARect;
end
else
begin
if FMenu.IsRightToLeft then
TextRect.Right := TextRect.Right + 5
else
TextRect.Left := TextRect.Left - 5;
end
end;
/// Under Lines Add By Kingron,Fix Top MenuItem Bitmap Draw
if FMenuItem.Bitmap <> nil then
if FTopMenu then /// Top MenuItem
begin
Inc(TextRect.Left, B.Width); /// Adjust TextRect For Top MenuItem Bitmap
IconRect.Top := TextRect.Top + (TextRect.Bottom - TextRect.Top - B.Height) div 4;
if (TextRect.Bottom - TextRect.Top) < 20 then
Dec(IconRect.Top, 3); /// Adjust For Low Height
end
else
begin /// MenuItem
if not HasImgLstBitmap then
begin
IconRect.Top := TextRect.Top + (TextRect.Bottom - TextRect.Top - FIconWidth div 2) div 4;
if (TextRect.Bottom - TextRect.Top) >= FIconWidth then
Dec(IconRect.Top, 3) /// Adjust For Low Height
end
else
begin
IconRect.Top := TextRect.Top + (TextRect.Bottom - TextRect.Top - FMenuItem.Parent.GetParentMenu.Images.Height div 2) div 4;
if (TextRect.Bottom - TextRect.Top) <= FMenuItem.Parent.GetParentMenu.Images.Height then
Dec(IconRect.Top, FMenuItem.Parent.GetParentMenu.Images.Height div 2) /// Adjust For Low Height
else
Dec(IconRect.Top, 4);
end;
end;
/// Under Lines Fix The MenuItem IconRect Calc Err Bug under Win9x
if not _IsOSoK and not FTopMenu and (HasImgLstBitmap or (FMenuItem.Bitmap.Width <20)) then
Dec(IconRect.Top ,3);
/// End Add
if FTopMenu then
begin
ACanvas.brush.color := FFMenuBarColor;
ACanvas.Pen.Color := FFMenuBarColor;
ACanvas.FillRect(ARect);
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;
if (not FMenuItem.Enabled) and (Selected) then
else
ACanvas.FillRect(ARect);
ACanvas.brush.color := FFIconBackColor;
if (not FMenuItem.Enabled) and (Selected) then
else
/// Under Line Modify by Kingron,To Fix the Gradient Bug under Win9x
/// Old : ACanvas.FillRect(IconRect);
ACanvas.FillRect(Rect(IconRect.Left ,IconRect.Top -2,IconRect.Right,IconRect.Bottom +2));
end;
//------------
end;
if FMenuItem.Enabled then
ACanvas.Font.Color := FFont.Color
else
ACanvas.Font.Color := FDisabledColor;
if Selected and FDrawSelect then
begin
ACanvas.brush.Style := bsSolid;
if FTopMenu then
begin
DrawTopMenuItem(FMenuItem, ACanvas, ARect, FMenu.IsRightToLeft);
end
else
//------
if FMenuItem.Enabled then
begin
/// Under Lines Modify By Kingron,Frame 3D,IF Statement~~~~~~~
if FFrame3D then
DrawEdge(ACanvas.Handle, ARect, BDR_SUNKENOUTER, BF_RECT) /// Add By Kingron
else begin /// Begin ... End == Old Code
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;
end;
//-----
end;
DrawCheckedItem(FMenuItem, Selected, HasImgLstBitmap, ACanvas, CheckedRect);
//-----
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 := FFIconBackColor;
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}
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 := FFIconBackColor;
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
else
if FMenuItem.Bitmap.Width > 0 then
B.Assign(TBitmap(FMenuItem.Bitmap));
DrawIcon(FMenuItem, ACanvas, B, IconRect,
Selected, 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, 5);
end
else
begin
TextFormat := 0;
Inc(TextRect.Left, 5);
end;
DrawTheText(txt, ShortCutToText(FMenuItem.ShortCut),
ACanvas, TextRect,
Selected, FMenuItem.Enabled, FMenuItem.Default,
FTopMenu, FMenu.IsRightToLeft, TextFormat);
//-----------
end
else
begin
if FMenu.IsRightToLeft then
begin
X1 := TextRect.Left;
X2 := TextRect.Right - 7;
end
else
begin
/// Under Line Modified By Kingron
/// Old: X1 := TextRect.Left + 7;
X1 := TextRect.Left;
X2 := TextRect.Right;
end;
ACanvas.Pen.Color := FFSeparatorColor;
/// Under Lines Add By Kingron ,Adjust the Line Width!
if FGradient then /// Adjust Width For Bar
X1 := ARect.Left;
/// End Add
ACanvas.MoveTo(X1, TextRect.Top + Round((TextRect.Bottom - TextRect.Top) / 2));
ACanvas.LineTo(X2, TextRect.Top + Round((TextRect.Bottom - TextRect.Top) / 2))
end;
B.free;
//------
if not (csDesigning in ComponentState) then
begin
if (FFlatMenu) and (not FTopMenu) then
begin
hDcM := ACanvas.Handle;
hWndM := WindowFromDC(hDcM);
if hWndM <> FForm.Handle then
begin
DrawWindowBorder(hWndM, FMenu.IsRightToLeft);
end;
end;
end;
//-----
ActivateMenuItem(FMenuItem); // to check for new sub items
end;
{$IFDEF VER5U}
procedure TXPBarMenu.ToolBarDrawButton(Sender: TToolBar;
Button: TToolButton; State: TCustomDrawState; var DefaultDraw: Boolean);
var
ACanvas : TCanvas;
ARect, HPreviousRect : TRect;
B : TBitmap;
HasBitmap : boolean;
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 := HPreviousRect;
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;
HasBitmap := (TToolBar(Button.Parent).Images <> nil) and
(Button.ImageIndex <> -1) and
(Button.ImageIndex <= TToolBar(Button.Parent).Images.Count - 1);
IsTransparent := TToolBar(Button.Parent).Transparent;
ACanvas := Sender.Canvas;
SetGlobalColor(ACanvas);
if (Is16Bit) and (not UseSystemColors) then
FBSelectColor := NewColor(ACanvas, FSelectColor, 68)
else
FBSelectColor := FFSelectColor;
HPreviousRect := Button.BoundsRect;
ARect := HPreviousRect;
{Causing problem when activiting the component at run time
if FUseSystemColors then
begin
if (Button.MenuItem <> nil) then
begin
if (TToolBar(Button.Parent).Font.Name <> FFont.Name) or
(TToolBar(Button.Parent).Font.Size <> FFont.Size) then
begin
TToolBar(Button.Parent).Font.Assign(FFont);
Button.AutoSize := false;
Button.AutoSize := true;
end;
end
end;
}
if Is16Bit then
ACanvas.brush.color := NewColor(ACanvas, clBtnFace, 16)
else
ACanvas.brush.color := clBtnFace;
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 := FFMenuBarColor;
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)
and (cdsSelected in State) then
begin
DrawTopMenuItem(Button, ACanvas, ARect, false);
DefaultDraw := false;
end;
ARect := HPreviousRect;
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;
if HasBitmap then
begin
try
B := TBitmap.Create;
B.Width := TToolBar(Button.Parent).Images.Width;
B.Height := TToolBar(Button.Parent).Images.Height;
B.Canvas.Brush.Color := ACanvas.Brush.Color;
B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height));
ImageList_DrawEx(TToolBar(Button.Parent).Images.Handle, 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);
finally
B.Free;
end;
ARect := HPreviousRect;
DefaultDraw := false;
end;
//-----------
if TToolBar(Button.Parent).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) - 3;
end
else
begin
TextFormat := DT_VCENTER;
if Button.BiDiMode = bdRightToLeft then
begin
TextFormat := TextFormat + DT_Right;
Dec(ARect.Right, BitmapWidth + 7);
end
else
begin
Inc(ARect.Left, BitmapWidth + 6);
end
end;
if (Button.MenuItem <> nil) then
begin
TextFormat := DT_Center;
end;
if Button.BiDiMode = bdRightToLeft then
TextFormat := TextFormat + DT_RTLREADING;
DrawTheText(Button.Caption, '',
ACanvas, ARect,
(cdsSelected in State), Button.Enabled, false,
(Button.MenuItem <> nil),
(Button.BidiMode = bdRightToLeft), TextFormat);
ARect := HPreviousRect;
DefaultDraw := false;
end;
if Button.Index > 0 then
begin
XButton := TToolBar(Button.Parent).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, clBtnFace, 16)
else
ACanvas.brush.color := clBtnFace;
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 := FFDisabledColor;
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
ActivateMenuItem(Button.MenuItem);
end;
{$ENDIF}
procedure TXPBarMenu.SetGlobalColor(ACanvas: TCanvas);
begin
//-----
if GetDeviceCaps(ACanvas.Handle, BITSPIXEL) < 16 then
Is16Bit := false
else
Is16Bit := true;
FFColor := FColor;
FFIconBackColor := FIconBackColor;
FFSelectColor := FSelectColor;
if Is16Bit then
begin
FCheckedAreaColor := NewColor(ACanvas, FSelectColor, 75);
FCheckedAreaSelectColor := NewColor(ACanvas, FSelectColor, 50);
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 := clMenu;
FFDisabledColor := NewColor(ACanvas, clBtnShadow, 10);
FFSeparatorColor := NewColor(ACanvas, clBtnShadow, 25);
FFCheckedColor := clHighlight;
FCheckedAreaColor := NewColor(ACanvas, clHighlight, 75);
FCheckedAreaSelectColor := NewColor(ACanvas, clHighlight, 50);
end;
end;
end;
procedure TXPBarMenu.DrawTopMenuItem(Sender: TObject; ACanvas: TCanvas;
ARect: TRect; IsRightToLeft: boolean);
var
X1, X2 : integer;
DefColor, HoldColor: TColor;
begin
X1 := ARect.Left;
X2 := ARect.Right;
ACanvas.brush.Style := bsSolid;
ACanvas.brush.color := FFIconBackColor;
ACanvas.FillRect(ARect);
ACanvas.Pen.Color := FMenuBorderColor;
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);
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 := FMenuBorderColor;
ACanvas.Brush.Color := FMenuShadowColor;
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));
end;
end;
procedure TXPBarMenu.DrawCheckedItem(FMenuItem: TMenuItem; Selected,
HasImgLstBitmap: boolean; ACanvas: TCanvas; CheckedRect: TRect);
var
X1, X2 : integer;
begin
if FMenuItem.RadioItem then
begin
if FMenuItem.Checked then
begin
ACanvas.Pen.color := FFSelectBorderColor;
if selected then
ACanvas.Brush.Color := FCheckedAreaSelectColor
else
ACanvas.Brush.Color := FCheckedAreaColor;
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);
end;
end;
end
else
begin
if (FMenuItem.Checked) then
if (not HasImgLstBitmap) then
begin
ACanvas.Pen.color := FFCheckedColor;
if selected then
ACanvas.Brush.Color := FCheckedAreaSelectColor
else
ACanvas.Brush.Color := FCheckedAreaColor; ;
ACanvas.Brush.Style := bsSolid;
ACanvas.Rectangle(CheckedRect.Left, CheckedRect.Top,
CheckedRect.Right, CheckedRect.Bottom);
ACanvas.Pen.color := clBlack;
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
ACanvas.Pen.color := FFSelectBorderColor;
if selected then
ACanvas.Brush.Color := FCheckedAreaSelectColor
else
ACanvas.Brush.Color := FCheckedAreaColor;
ACanvas.Brush.Style := bsSolid;
ACanvas.Rectangle(CheckedRect.Left, CheckedRect.Top,
CheckedRect.Right, CheckedRect.Bottom);
end;
end;
end;
procedure TXPBarMenu.DrawTheText(txt, ShortCuttext: string; ACanvas: TCanvas; TextRect: TRect;
Selected, Enabled, Default, TopMenu, IsRightToLeft: boolean; TextFormat: integer);
var
DefColor : TColor;
begin
DefColor := FFont.Color;
ACanvas.Font.Assign(FFont);
if Enabled then
DefColor := FFont.Color;
if Selected then
DefColor := FFSelectFontColor;
if not Enabled then
begin
DefColor := FFDisabledColor;
//if Selected then
// if Is16Bit then
// DefColor := NewColor(ACanvas, FFDisabledColor, 10);
end;
if (TopMenu and Selected) then
DefColor := TopMenuFontColor(ACanvas, FFIconBackColor);
ACanvas.Font.color := DefColor; // will not affect Buttons
TextRect.Top := TextRect.Top +
((TextRect.Bottom - TextRect.Top) - ACanvas.TextHeight('W')) div 2;
SetBkMode(ACanvas.Handle, TRANSPARENT);
if Default and Enabled then
begin
Inc(TextRect.Left, 1);
ACanvas.Font.Style := [fsBold] + Font.Style; /// This Line Add By Kingron
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 TXPBarMenu.DrawIcon(Sender: TObject; ACanvas: TCanvas; B: TBitmap;
IconRect: Trect; Hot, Selected, Enabled, Checked, FTopMenu,
IsRightToLeft: boolean);
var
DefColor : TColor;
X1, X2 : integer;
begin
if B <> nil then
begin
X1 := IconRect.Left;
X2 := IconRect.Top + 2;
if Sender is TMenuItem then
begin
inc(X2, 2);
if FIconWidth >= B.Width then
X1 := X1 + ((FIconWidth - B.Width) div 2) - 1
else
begin
if IsRightToLeft then
X1 := IconRect.Right - b.Width - 2
else
X1 := IconRect.Left + 2;
end;
end;
if (Hot) and (not FTopMenu) and (Enabled) and (not Checked) then
if not Selected then
begin
dec(X1, 1);
dec(X2, 1);
end;
{$IFDEF WIN32} /// This Line Add By Kingron
/// Under Lines Cause some Problam in Win9x,Bitmap Transparent Bug
if (not Hot) and (Enabled) and (not Checked) and _IsOSoK then
if Is16Bit then
DimBitmap(B, 30);
/// Under Two Line Cause some problam in Win9x
if not Enabled and _IsOSoK then
GrayBitmap(B, 70);
{$ENDIF} /// This Line Add By Kingron
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, X1 + 2, X2 + 2, DefColor);
end;
B.Transparent := True;
ACanvas.Draw(X1, X2, B);
end;
end;
procedure TXPBarMenu.DrawArrow(ACanvas: TCanvas; X, Y: integer);
begin
ACanvas.MoveTo(X, Y);
ACanvas.LineTo(X + 4, Y);
ACanvas.MoveTo(X + 1, Y + 1);
ACanvas.LineTo(X + 4, Y);
ACanvas.MoveTo(X + 2, Y + 2);
ACanvas.LineTo(X + 3, Y);
end;
function TXPBarMenu.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);
// Result := FColor;
end;
procedure TXPBarMenu.SetActive(const Value: boolean);
begin
FActive := Value;
if FActive then
begin
InitMenueItems(FForm, false);
InitMenueItems(FForm, true);
end
else
InitMenueItems(FForm, false);
if FForm <> nil then
Windows.DrawMenuBar(FForm.Handle);
end;
procedure TXPBarMenu.SetForm(const Value: TForm);
var
Hold : boolean;
begin
if Value <> FForm then
begin
Hold := Active;
Active := false;
FForm := Value;
if Hold then
Active := True;
end;
end;
procedure TXPBarMenu.SetFont(const Value: TFont);
begin
FFont.Assign(Value);
DrawMenuBar(FForm.Handle);
end;
procedure TXPBarMenu.SetMenuBarColor(const Value: TColor);
begin
FMenuBarColor := Value;
Windows.DrawMenuBar(FForm.Handle);
end;
procedure TXPBarMenu.SetOverrideOwnerDraw(const Value: boolean);
begin
FOverrideOwnerDraw := Value;
if FActive then
Active := True;
end;
procedure TXPBarMenu.SetUseSystemColors(const Value: boolean);
begin
FUseSystemColors := Value;
Windows.DrawMenuBar(FForm.Handle);
end;
procedure GetSystemMenuFont(Font: TFont);
var
FNonCLientMetrics : TNonCLientMetrics;
FFont:TFont;
begin
FFont:=TFont.Create;
FNonCLientMetrics.cbSize := Sizeof(TNonCLientMetrics);
if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @FNonCLientMetrics, 0) then
begin
FFont.Handle := CreateFontIndirect(FNonCLientMetrics.lfMenuFont);
FFont.Color := clMenuText;
if FFont.Name = 'MS Sans Serif' then
FFont.Name := 'Tahoma';
end;
Font.Assign(FFont);
FFont.Free;
end;
procedure TXPBarMenu.DrawGradient(ACanvas: TCanvas; ARect: TRect;
IsRightToLeft: boolean);
var
i : integer;
v : integer;
BRect : TRect;
B : TBitmap;
begin
/// The modify by Kingron,Use Double Buffer to improce the Draw Speed
B:=TBitmap.Create;
V := 0;
B.Height :=ARect.Bottom - ARect.Top;
B.Width := ARect.Right - ARect.Left;
BRect := Rect(0,0,B.Width -1 ,B.Height -1);
if IsRightToLeft then
begin
BRect.Left := BRect.Right -1 ;
for i := ARect.Right downto ARect.Left do
begin
if (BRect.Left < ARect.Right)
and (BRect.Left > ARect.Right - FIconWidth + 5) then
inc(v, 3)
else
inc(v, 1);
if v > 96 then v := 96;
B.Canvas.Brush.Color := NewColor(B.Canvas, FFIconBackColor, v);
B.Canvas.FillRect(BRect);
Dec(BRect.Left);
BRect.Right := BRect.Left - 1;
end;
ACanvas.CopyRect(ARect,B.Canvas,Rect(0,0,B.Width -1 ,B.Height -1));
end
else
begin
BRect.Right := BRect.Left +1;
for i := ARect.Left to ARect.Right do
begin
if (BRect.Left > ARect.Left)
and (BRect.Left < ARect.Left + FIconWidth + 5) then
inc(v, 3)
else
inc(v, 1);
if v > 96 then v := 96;
B.Canvas.Brush.Color := NewColor(B.Canvas, FFIconBackColor, v);
B.Canvas.FillRect(BRect);
Inc(BRect.Left);
BRect.Right := BRect.Left + 1;
end;
ACanvas.CopyRect(ARect,B.Canvas,Rect(0,0,B.Width -1 ,B.Height -1));
end;
B.Free;
end;
procedure TXPBarMenu.DrawWindowBorder(hWnd: HWND; IsRightToLeft: boolean);
var
WRect, CRect : TRect;
dCanvas : TCanvas;
begin
if hWnd <= 0 then exit;
dCanvas := nil;
try
dCanvas := TCanvas.Create;
dCanvas.Handle := GetDc(0);
GetClientRect(hWnd, CRect);
GetWindowRect(hWnd, WRect);
ExcludeClipRect(dCanvas.Handle, CRect.Left, CRect.Top, CRect.Right,
CRect.Bottom);
dCanvas.Brush.Style := bsClear;
Dec(WRect.Right, 2);
Dec(WRect.Bottom, 2);
dCanvas.Pen.Color := FMenuBorderColor;
dCanvas.Rectangle(WRect.Left, WRect.Top, WRect.Right, WRect.Bottom);
if IsRightToLeft then
begin
dCanvas.Pen.Color := FFColor;
dCanvas.Rectangle(WRect.Left + 1, WRect.Top + 1, WRect.Right - 2,
WRect.Top + 3);
dCanvas.MoveTo(WRect.Left + 2, WRect.Top + 2);
dCanvas.LineTo(WRect.Left + 2, WRect.Bottom - 2);
dCanvas.Pen.Color := FFIconBackColor;
dCanvas.MoveTo(WRect.Right - 2, WRect.Top + 2);
dCanvas.LineTo(WRect.Right - 2, WRect.Bottom - 2);
dCanvas.MoveTo(WRect.Right - 2, WRect.Top + 2);
dCanvas.LineTo(WRect.Right - 1 - FIconWidth, WRect.Top + 2);
end
else
begin
if not FGradient then
begin
dCanvas.Pen.Color := FFColor;
dCanvas.Rectangle(WRect.Left + 1, WRect.Top + 1, WRect.Right - 2,
WRect.Top + 3);
dCanvas.Pen.Color := FFIconBackColor;
dCanvas.MoveTo(WRect.Left + 1, WRect.Top + 2);
dCanvas.LineTo(WRect.Left + 2 + FIconWidth, WRect.Top + 2);
end;
dCanvas.Pen.Color := FFIconBackColor;
dCanvas.MoveTo(WRect.Left + 1, WRect.Top + 1);
dCanvas.LineTo(WRect.Left + 1, WRect.Bottom - 2);
end;
Inc(WRect.Right, 2);
Inc(WRect.Bottom, 2);
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);
dCanvas.Pen.Color := FFIconBackColor;
dCanvas.Rectangle(WRect.Left, WRect.Bottom - 2, WRect.Left + 2, WRect.Bottom);
dCanvas.Rectangle(WRect.Right - 2, WRect.Top, WRect.Right, WRect.Top + 2);
finally
IntersectClipRect(dCanvas.Handle, WRect.Left, WRect.Top, WRect.Right, WRect.Bottom);
/// Under Line Add By Kingron ,to Fix Memory Hole Bug!!!!!
ReleaseDC(0,dCanvas.Handle);
dCanvas.Free;
end;
end;
procedure TXPBarMenu.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if not FAutoDetect then exit;
if (Operation = opInsert) and
((AComponent is TMenuItem) or (AComponent is TToolButton)) then
begin
if (csDesigning in ComponentState) then
Active := true
else
//if ComponentState = [] then
Active := true;
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));
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));
end;
function GrayColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
var
r, g, b, avg : 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;
Avg := (r + g + b) div 3;
Avg := Avg + Value;
if Avg > 240 then Avg := 240;
Result := Windows.GetNearestColor(ACanvas.Handle, 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;
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;
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;
/// The Procedure DrawBar Add By Kingron
procedure TXPBarMenu.DrawBar(Sender: TObject; ACanvas: TCanvas; ARect: TRect);
var
NeedDrawBar : boolean;
procedure DrawBarText; /// Draw Text
var
i : word;
DR, DG, DB : integer;
R, G, B : integer;
dy, y : real;
lf : TLogFont;
tf : TFont;
Bmp : TBitmap;
begin
/// Draw Dither Back Color
/// FBarColorStep used for Win9x, To Adjust the Draw Speed
Bmp := TBitmap.Create;
Bmp.Height :=ARect.Bottom-ARect.Top;
Bmp.Width := ARect.Right - ARect.Left;
R := GetRValue(ColorToRGB(FBarColorEnd));
G := GetGValue(ColorToRGB(FBarColorEnd));
B := GetBValue(ColorToRGB(FBarColorEnd));
DR := (R - GetRValue(ColorToRGB(FBarColorStart))) div FBarColorStep;
DG := (G - GetGValue(ColorToRGB(FBarColorStart))) div FBarColorStep;
DB := (B - GetBValue(ColorToRGB(FBarColorStart))) div FBarColorStep;
dy := (ARect.Bottom - ARect.Top) / FBarColorStep;
y := 0;
for i := FBarColorStep downto 0 do
begin
Bmp.Canvas.brush.color := RGB(i * DR + R, i * DG + G, i * DB + B);
Bmp.Canvas.fillrect(rect(0, round(y), ARect.Right - ARect.Left, round(y + dy)));
y := y + dy;
end;
/// Draw Caption
with Bmp.Canvas do
begin
Brush.Style := bsClear;
Font.Assign(FBarFont);
tf := TFont.Create;
tf.Assign(Font);
GetObject(tf.Handle, sizeof(lf), @lf);
lf.lfEscapement := 900;
tf.Handle := CreateFontIndirect(lf);
Font.Assign(tf);
tf.Free;
TextOut(ARect.Left + 2, ARect.Bottom - 5, FBarCaption);
end;
ACanvas.CopyRect(ARect,Bmp.Canvas,Rect(0,0,Bmp.Width - 1,Bmp.Height - 1));
Bmp.Free;
end;
procedure DrawBarBitmap; /// Draw Bitmap
var
X, Y, W, H : integer;
Y2 : integer;
begin
X := ARect.Left;
Y := ARect.Top;
W := ARect.Right - X;
H := ARect.Bottom - Y;
Y2 := 0;
/// Stretch Draw the Bitmap
if FBarStretch then
StretchBlt(ACanvas.Handle, X, Y - 2, W, H, FBarBitmap.Canvas.Handle, 0, 0, FBarBitmap.Width - 1, FBarBitmap.Height - 1, SRCCOPY)
else
begin
if H > FBarBitmap.Height then
Inc(Y, H - FBarBitmap.Height)
else
Inc(Y2, FBarBitmap.Height - H);
BitBlt(ACanvas.Handle, X, Y - 2, W, H, FBarBitmap.Canvas.Handle, 0, Y2, SRCCOPY);
end;
end;
begin
NeedDrawBar := CanDrawBar;
if Assigned(FOnDrawBar) then
FOnDrawBar(Sender, ACanvas, ARect, NeedDrawBar);
if not NeedDrawBar then exit; /// Don't Need to Draw
if FBarStyle = bsText then
DrawBarText
else
DrawBarBitmap;
end;
procedure TXPBarMenu.SetBarFont(const Value: TFont);
begin
FBarFont.Assign(Value);
end;
procedure TXPBarMenu.SetBarBitmap(const Value: TBitmap);
begin
FBarBitmap.Assign(Value);
end;
function TXPBarMenu.CanDrawBar: boolean;
begin
Result := False;
if (BarStyle = bsText) and (FBarCaption <> '') then
Result := True;
if (BarStyle = bsBitmap) and (not FBarBitmap.Empty) then
Result := True;
if BarStyle = bsNone then
Result := False;
end;
procedure TXPBarMenu.SetBarColorStep(const Value: integer);
begin
FBarColorStep := Value;
if FBarColorStep <= 0 then
FBarColorStep := 1;
if FBarColorStep > 255 then
FBarColorStep := 255;
end;
/// Os is Win2000 or Higher?
function TXPBarMenu._IsOSoK: boolean;
begin
Result :=DWORD(LOBYTE(LOWORD(GetVersion)))>=5;
end;
end.
Reference in New Issue View Git Blame Copy Permalink