Delphi控件源码

开发平台：

Delphi

BusinessSkinForm.pas：源码内容

{*******************************************************************}
{ }
{ Almediadev Visual Component Library }
{ BusinessSkinForm }
{ Version 2.90 }
{ }
{ }
{ Home: http://www.almdev.com }
{ Support: support@almdev.com }
{ }
{*******************************************************************}
Unit BusinessSkinForm;
{$P+,S-,W-,R-}
{$WARNINGS OFF}
{$HINTS OFF}
interface
uses
Windows, Messages, Classes, Graphics, Controls, Forms,
ExtCtrls, bsSkinData, Menus, bsSkinMenus, bsSkinCtrls, bsUtils, bsSkinTabs,
bsSkinBoxCtrls, bsTrayIcon, bsSkinHint;
type
TbsBorderIcon = (biSystemMenu, biMinimize, biMaximize, biRollUp, biMinimizeToTray);
TbsBorderIcons = set of TbsBorderIcon;
TbsPaintEvent = procedure (IDName: String; Canvas: TCanvas;
ObjectRect: TRect) of object;
TbsMouseEnterEvent= procedure (IDName: String) of object;
TbsMouseLeaveEvent = procedure (IDName: String) of object;
TbsMouseUpEvent = procedure (IDName: String;
X, Y: Integer; ObjectRect: TRect;
Button: TMouseButton) of object;
TbsMouseDownEvent = procedure (IDName: String;
X, Y: Integer; ObjectRect: TRect;
Button: TMouseButton) of object;
TbsMouseMoveEvent = procedure (IDName: String; X, Y: Integer;
ObjectRect: TRect) of object;
TbsActivateCustomObjectEvent = procedure (IDName: String; var ObjectVisible: Boolean) of object;
TbsBusinessSkinForm = class;
TbsActiveSkinObject = class(TObject)
protected
Parent: TbsBusinessSkinForm;
FMorphKf: Double;
FMouseIn: Boolean;
Picture, ActivePicture: TBitMap;
procedure SetMorphKf(Value: Double);
procedure Redraw;
public
SD: TbsSkinData;
IDName: String;
Hint: String;
SkinRect: TRect;
ActiveSkinRect: TRect;
InActiveSkinRect: TRect;
ObjectRect: TRect;
Active: Boolean;
Morphing: Boolean;
MorphKind: TbsMorphKind;
Enabled: Boolean;
Visible: Boolean;
SkinRectInAPicture: Boolean;
function CanMorphing: Boolean; virtual;
procedure DoMorphing;
property MorphKf: Double read FMorphKf write SetMorphKf;
constructor Create(AParent: TbsBusinessSkinForm; AData: TbsDataSkinObject);
procedure Draw(Cnvs: TCanvas; UpDate: Boolean); virtual;
procedure DblClick; virtual;
procedure MouseDown(X, Y: Integer; Button: TMouseButton); virtual;
procedure MouseUp(X, Y: Integer; Button: TMouseButton); virtual;
procedure MouseMove(X, Y: Integer); virtual;
procedure MouseEnter; virtual;
procedure MouseLeave; virtual;
end;
TbsSkinAnimateObject = class(TbsActiveSkinObject)
protected
FFrame: Integer;
FInc: Integer;
TimerInterval: Integer;
MenuItem: TMenuItem;
FPopupUp: Boolean;
procedure SetFrame(Value: Integer);
procedure DoMinToTray;
procedure DoMax;
procedure DoMin;
procedure DoRollUp;
procedure DoClose;
procedure DoCommand;
procedure TrackMenu;
public
CountFrames: Integer;
Cycle: Boolean;
ButtonStyle: Boolean;
Increment: Boolean;
Command: TbsStdCommand;
procedure ChangeFrame;
procedure Start;
procedure Stop;
constructor Create(AParent: TbsBusinessSkinForm;
AData: TbsDataSkinObject);
procedure DblCLick; override;
procedure MouseUp(X, Y: Integer; Button: TMouseButton); override;
property Frame: Integer read FFrame write SetFrame;
procedure Draw(Cnvs: TCanvas; UpDate: Boolean); override;
procedure MouseEnter; override;
procedure MouseLeave; override;
end;
TbsUserObject = class(TbsActiveSkinObject)
public
procedure Draw(Cnvs: TCanvas; UpDate: Boolean); override;
end;
TbsSkinButtonObject = class(TbsActiveSkinObject)
protected
FDown: Boolean;
FPopupUp: Boolean;
procedure SetDown(Value: Boolean);
procedure TrackMenu;
public
DisableSkinRect: TRect;
DownRect: TRect;
MenuItem: TMenuItem;
constructor Create(AParent: TbsBusinessSkinForm;
AData: TbsDataSkinObject);
property Down: Boolean read FDown write SetDown;
procedure Draw(Cnvs: TCanvas; UpDate: Boolean); override;
procedure MouseDown(X, Y: Integer; Button: TMouseButton); override;
procedure MouseUp(X, Y: Integer; Button: TMouseButton); override;
procedure MouseEnter; override;
procedure MouseLeave; override;
function CanMorphing: Boolean; override;
end;
TbsSkinStdButtonObject = class(TbsSkinButtonObject)
protected
procedure DoMax;
procedure DoMin;
procedure DoClose;
procedure DoRollUp;
procedure DoCommand;
procedure DoMinimizeToTray;
public
FSkinSupport: Boolean;
Command: TbsStdCommand;
RestoreRect, RestoreActiveRect, RestoreInActiveRect,
RestoreDownRect: TRect;
procedure DblClick; override;
procedure MouseDown(X, Y: Integer; Button: TMouseButton); override;
procedure MouseUp(X, Y: Integer; Button: TMouseButton); override;
constructor Create(AParent: TbsBusinessSkinForm;
AData: TbsDataSkinObject);
procedure Draw(Cnvs: TCanvas; UpDate: Boolean); override;
procedure DefaultDraw(Cnvs: TCanvas);
function CanMorphing: Boolean; override;
end;
TbsSkinCaptionObject = class(TbsActiveSkinObject)
public
FontName: String;
FontStyle: TFontStyles;
FontHeight: Integer;
FontColor: TColor;
ActiveFontColor: TColor;
ShadowColor: TColor;
ActiveShadowColor: TColor;
Shadow: Boolean;
Alignment: TAlignment;
TextRct: TRect;
FrameRect, ActiveFrameRect: TRect;
FrameLeftOffset, FrameRightOffset: Integer;
FrameTextRect: TRect;
constructor Create(AParent: TbsBusinessSkinForm;
AData: TbsDataSkinObject);
procedure MouseEnter; override;
procedure MouseLeave; override;
procedure MouseDown(X, Y: Integer; Button: TMouseButton); override;
procedure MouseUp(X, Y: Integer; Button: TMouseButton); override;
procedure Draw(Cnvs: TCanvas; UpDate: Boolean); override;
end;
TbsSkinMainMenu = class(TMainMenu)
protected
BSF: TbsBusinessSkinForm;
FSD: TbsSkinData;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
public
constructor Create(AOwner: TComponent); override;
published
property SkinData: TbsSkinData read FSD write FSD;
end;
// Menu Bar //
TbsSkinMainMenuBar = class;
TbsMenuBarObject = class(TObject)
protected
Parent: TbsSkinMainMenuBar;
FMouseIn: Boolean;
Picture: TBitMap;
FDown: Boolean;
FMorphKf: Double;
procedure Redraw;
procedure SetMorphKf(Value: Double);
public
IDName: String;
SkinRect: TRect;
ActiveSkinRect: TRect;
DownRect: TRect;
ObjectRect: TRect;
Active: Boolean;
Enabled: Boolean;
Visible: Boolean;
Morphing: Boolean;
MorphKind: TbsMorphKind;
constructor Create(AParent: TbsSkinMainMenuBar; AData: TbsDataSkinObject);
procedure Draw(Cnvs: TCanvas); virtual;
procedure MouseDown(X, Y: Integer; Button: TMouseButton); virtual;
procedure MouseUp(X, Y: Integer; Button: TMouseButton); virtual;
procedure DblClick; virtual;
procedure MouseEnter; virtual;
procedure MouseLeave; virtual;
function CanMorphing: Boolean; virtual;
procedure DoMorphing;
property MorphKf: Double read FMorphKf write SetMorphKf;
end;
TbsSkinMainMenuBarButton = class(TbsMenuBarObject)
protected
FSkinSupport: Boolean;
procedure DoCommand;
public
Command: TbsStdCommand;
constructor Create(AParent: TbsSkinMainMenuBar; AData: TbsDataSkinObject);
procedure DefaultDraw(Cnvs: TCanvas);
procedure Draw(Cnvs: TCanvas); override;
procedure DblClick; override;
procedure MouseDown(X, Y: Integer; Button: TMouseButton); override;
procedure MouseUp(X, Y: Integer; Button: TMouseButton); override;
procedure MouseEnter; override;
procedure MouseLeave; override;
end;
TbsSkinMainMenuBarItem = class(TbsMenuBarObject)
protected
FSkinSupport: Boolean;
TempObjectRect: TRect;
OldEnabled: Boolean;
Visible: Boolean;
function SearchDown: Boolean;
procedure SearchActive;
procedure SetDown(Value: Boolean);
procedure TrackMenu;
public
MenuItem: TMenuItem;
FontName: String;
FontHeight: Integer;
FontStyle: TFontStyles;
UnEnabledFontColor, FontColor,
ActiveFontColor, DownFontColor: TColor;
TextRct: TRect;
DownRect: TRect;
LO, RO: Integer;
constructor Create(AParent: TbsSkinMainMenuBar; AData: TbsDataSkinObject);
procedure DefaultDraw(Cnvs: TCanvas);
procedure Draw(Cnvs: TCanvas); override;
procedure MouseEnter; override;
procedure MouseDown(X, Y: Integer; Button: TMouseButton); override;
procedure MouseLeave; override;
end;
TbsItemEnterEvent = procedure (MenuItem: TMenuItem) of object;
TbsItemLeaveEvent = procedure (MenuItem: TMenuItem) of object;
TbsSkinMainMenuBar = class(TbsSkinControl)
protected
FOnItemMouseEnter: TbsItemEnterEvent;
FOnItemMouseLeave: TbsItemLeaveEvent;
FScrollMenu: Boolean;
FDefItemFont: TFont;
FUseSkinFont: Boolean;
FSkinSupport: Boolean;
ButtonsCount: Integer;
FMDIChildMax: Boolean;
FPopupToUp: Boolean;
MenuActive: Boolean;
Scroll: Boolean;
MarkerActive: Boolean;
BSF: TbsBusinessSkinForm;
FMainMenu: TMainMenu;
MouseTimer: TTimer;
MorphTimer: TTimer;
ActiveObject, OldActiveObject, MouseCaptureObject: Integer;
FOnMouseEnter, FOnMouseLeave: TNotifyEvent;
NewItemsRect: TRect;
FDefaultWidth: Integer;
FDefaultHeight: Integer;
procedure TestMorph(Sender: TObject);
procedure SetDefaultWidth(Value: Integer);
procedure SetDefaultHeight(Value: Integer);
procedure SetDefItemFont(Value: TFont);
procedure CloseSysMenu;
procedure AddButtons;
procedure DeleteButtons;
procedure CheckButtons(BI: TbsBorderIcons);
procedure TrackScrollMenu;
procedure CalcRects;
procedure SetMainMenu(Value: TMainMenu);
procedure TestMouse(Sender: TObject);
procedure PaintMenuBar(Cnvs: TCanvas);
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMCloseSkinMenu(var Message: TMessage); message WM_CLOSESKINMENU;
procedure WMSize(var Message: TWMSIZE); message WM_SIZE;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure TestActive(X, Y: Integer);
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure ClearObjects;
procedure DrawSkinObject(AObject: TbsMenuBarObject);
procedure MenuEnter;
procedure MenuExit;
procedure MenuClose;
function CheckReturnKey: Boolean;
procedure NextMainMenuItem;
procedure PriorMainMenuItem;
function FindHotKeyItem(CharCode: Integer): Boolean;
function GetMarkerRect: TRect;
procedure DrawMarker(Cnvs: TCanvas);
procedure MDIChildMaximize;
procedure MDIChildRestore;
public
//
SkinRect, ItemsRect: TRect;
MenuBarItem: String;
MaxButton, MinButton, SysMenuButton, CloseButton: String;
TrackMarkColor, TrackMarkActiveColor: Integer;
Picture: TBitMap;
//
ObjectList: TList;
//
ChildMenuIn: Boolean;
//
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetChildMainMenu: TMainMenu;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
procedure Paint; override;
procedure CreateMenu;
procedure ChangeSkinData; override;
procedure BeforeChangeSkinData; override;
procedure GetSkinData; override;
procedure UpDateItems;
published
property ScrollMenu: Boolean read FScrollMenu write FScrollMenu;
property UseSkinFont: Boolean
read FUseSkinFont write FUseSkinFont;
property DefItemFont: TFont read FDefItemFont write SetDefItemFont;
property DefaultWidth: Integer read FDefaultWidth write SetDefaultWidth;
property DefaultHeight: Integer read FDefaultHeight write SetDefaultHeight;
property PopupToUp: Boolean read FPopupToUp write FPopupToUp;
property BusinessSkinForm: TbsBusinessSkinForm read BSF write BSF;
property MainMenu: TMainMenu read FMainMenu write SetMainMenu;
property Anchors;
property Align;
property Visible;
property Enabled;
property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
property OnItemMouseEnter: TbsItemEnterEvent read FOnItemMouseEnter write FOnItemMouseEnter;
property OnItemMouseLeave: TbsItemLeaveEvent read FOnItemMouseLeave write FOnItemMouseLeave;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnClick;
end;
TbsSkinMDITabsBar = class;
TbsBusinessSkinForm = class(TComponent)
private
FClientWidth, FClientHeight: Integer;
FHideCaptionButtons: Boolean;
FAlwaysShowInTray: Boolean;
FLogoBitMapTransparent: Boolean;
FLogoBitMap: TBitMap;
FAlwaysMinimizeToTray: Boolean;
FIcon: TIcon;
FShowIcon: Boolean;
ButtonsInLeft: boolean;
FMaximizeOnFullScreen: Boolean;
FAlphaBlend: Boolean;
FAlphaBlendAnimation: Boolean;
FAlphaBlendValue: Byte;
FSkinHint: TbsSkinHint;
FShowObjectHint: Boolean;
FUseDefaultObjectHint: Boolean;
FMenusAlphaBlend: Boolean;
FMenusAlphaBlendValue: Byte;
FMenusAlphaBlendAnimation: Boolean;
FSkinSupport: Boolean;
FDefCaptionFont: TFont;
FDefInActiveCaptionFont: TFont;
FMDIChildMaximized: Boolean;
FFormActive: Boolean;
FOnMinimizeToTray: TNotifyEvent;
FOnRestoreFromTray: TNotifyEvent;
FTrayIcon: TbsTrayIcon;
FUseDefaultSysMenu: Boolean;
FSysMenu: TPopupMenu;
FSysTrayMenu: TbsSkinPopupMenu;
FInShortCut: Boolean;
FMainMenuBar: TbsSkinMainMenuBar;
FMDITabsBar: TbsSkinMDITabsBar;
FFullDrag: Boolean;
FFormWidth, FFormHeight: Integer;
FSizeMove: Boolean;
FRollUpState, MaxRollUpState: Boolean;
FBorderIcons: TbsBorderIcons;
RMTop, RMBottom, RMLeft, RMRight: TBitMap;
BlackColor: TColor;
MouseIn: Boolean;
OldBoundsRect: TRect;
OldHeight: Integer;
NewLTPoint, NewRBPoint, NewRTPoint, NewLBPoint: TPoint;
NewClRect, NewCaptionRect, NewButtonsRect: TRect;
NewButtonsOffset: Integer;
NewButtonsInLeft: Boolean;
NewMaskRectArea: TRect;
NewHitTestLTPoint,
NewHitTestRTPoint,
NewHitTestLBPoint,
NewHitTestRBPoint: TPoint;
NewDefCaptionRect: TRect;
FMinHeight, FMinWidth: Integer;
OldWindowProc: TWndMethod;
FClientInstance: Pointer;
FPrevClientProc: Pointer;
FSD: TbsSkinData;
FMSD: TbsSkinData;
FMainMenu: TMainMenu;
FSystemMenu: TPopupMenu;
FOnChangeSkinData: TNotifyEvent;
FOnActivate: TNotifyEvent;
FOnDeActivate: TNotifyEvent;
FOnChangeRollUpState: TNotifyEvent;
FInChangeSkinData: Boolean;
FWindowState: TWindowState;
FMagneticSize: Byte;
OldAppMessage: TMessageEvent;
FOnActivateCustomObject: TbsActivateCustomObjectEvent;
procedure CheckMDIMainMenu;
procedure CheckMDIBar;
procedure SetLogoBitMap(Value: TBitMap);
procedure SetShowIcon(Value: Boolean);
procedure UpDateActiveObjects;
procedure SetMenusAlphaBlend(Value: Boolean);
procedure SetMenusAlphaBlendAnimation(Value: Boolean);
procedure SetMenusAlphaBlendValue(Value: Byte);
function GetDefCaptionRect: TRect;
function GetDefCaptionHeight: Integer;
function GetDefButtonSize: Integer;
function IsSizeAble: Boolean;
procedure SetDefaultMenuItemHeight(Value: Integer);
function GetDefaultMenuItemHeight: Integer;
procedure SetDefaultMenuItemFont(Value: TFont);
function GetDefaultMenuItemFont: TFont;
procedure SetDefCaptionFont(Value: TFont);
procedure SetDefInActiveCaptionFont(Value: TFont);
procedure SetBorderIcons(Value: TbsBorderIcons);
procedure NewAppMessage(var Msg: TMsg; var Handled: Boolean);
procedure HookApp;
procedure UnHookApp;
function GetMaximizeMDIChild: TForm;
function IsMDIChildMaximized: Boolean;
procedure ResizeMDIChilds;
function GetMDIWorkArea: TRect;
procedure UpDateForm;
procedure FormClientWindowProcHook(var Message: TMessage);
procedure TSM_Restore(Sender: TObject);
procedure TSM_Close(Sender: TObject);
procedure SM_Restore(Sender: TObject);
procedure SM_Max(Sender: TObject);
procedure SM_Min(Sender: TObject);
procedure SM_RollUp(Sender: TObject);
procedure SM_Close(Sender: TObject);
procedure SM_MinToTray(Sender: TObject);
procedure TrayIconDBLCLK(Sender: TObject);
procedure TrackSystemMenu(X, Y: Integer);
procedure CreateSysMenu;
procedure CreateUserSysMenu;
procedure CreateSysTrayMenu;
function GetSystemMenu: TMenuItem;
procedure CalcRects;
procedure FormShortCut(var Msg: TWMKey; var Handled: Boolean);
procedure ChangeSkinData;
procedure CreateRollUpForm;
procedure RestoreRollUpForm;
procedure SetRollUpState(Value: Boolean);
procedure SetTrayIcon(Value: TbsTrayIcon);
procedure BeforeUpDateSkinControls(AFSD: Integer; WC: TWinControl);
procedure UpDateSkinControls(AFSD: Integer; WC: TWinControl);
procedure CheckObjects;
procedure CheckObjectsHint;
procedure SetWindowState(Value: TWindowState);
procedure SetSkinData(Value: TbsSkinData);
procedure SetMenusSkinData(Value: TbsSkinData);
procedure NewWndProc(var Message: TMessage);
function NewNCHitTest(P: TPoint): Integer;
function NewDefNCHitTest(P: TPoint): Integer;
procedure CreateNewRegion(FCanScale: Boolean);
procedure CreateNewForm(FCanScale: Boolean);
procedure FormChangeActive(AUpDate: Boolean);
procedure DoMaximize;
procedure DoNormalize;
procedure DoMinimize;
function InForm(P: TPoint): Boolean;
function PtInMask(P: TPoint): Boolean;
function CanScale: Boolean;
procedure SetAlphaBlendValue(Value: Byte);
procedure SetAlphaBlend(Value: Boolean);
procedure GetIconSize(var X, Y: Integer);
procedure GetIcon;
procedure DrawFormIcon(Cnvs: TCanvas; X, Y: Integer);
function GetUseSkinFontInMenu: Boolean;
procedure SetUseSkinFontInMenu(Value: Boolean);
function GetRealHeight: Integer;
protected
InMenu: Boolean;
InMainMenu: Boolean;
FRgn: HRGN;
MouseTimer: TTimer;
MorphTimer: TTimer;
AnimateTimer: TTimer;
FMagnetic: Boolean;
FOnSkinMenuOpen: TNotifyEvent;
FOnSkinMenuClose: TNotifyEvent;
FOnMainMenuEnter: TNotifyEvent;
FOnMainMenuExit: TNotifyEvent;
FOnMouseEnterEvent: TbsMouseEnterEvent;
FOnMouseLeaveEvent: TbsMouseLeaveEvent;
FOnMouseUpEvent : TbsMouseUpEvent;
FOnMouseDownEvent : TbsMouseDownEvent;
FOnMouseMoveEvent: TbsMouseMoveEvent;
FOnPaintEvent: TbsPaintEvent;
ActiveObject, OldActiveObject, MouseCaptureObject: Integer;
OldWindowState: TWindowState;
procedure DrawLogoBitMap(C: TCanvas);
procedure CorrectCaptionText(C: TCanvas; var S: String; W: Integer);
procedure CheckMenuVisible(var Msg: Cardinal);
procedure FormKeyDown(Message: TMessage);
function GetFullDragg: Boolean;
function GetMinimizeCoord: TPoint;
procedure PointToNCPoint(var P: TPoint);
function CheckReturnKey: Boolean;
function CanNextMainMenuItem: Boolean;
function CanPriorMainMenuItem: Boolean;
function FindHotKeyItem(CharCode: Integer): Boolean;
procedure DoMagnetic(var L, T: Integer; W, H: Integer);
procedure TestMouse(Sender: TObject);
procedure TestMorph(Sender: TObject);
procedure TestAnimate(Sender: TObject);
procedure TestActive(X, Y: Integer; InFrm: Boolean);
procedure MouseDown(Button: TMouseButton; X, Y: Integer);
procedure MouseDBlClick;
procedure MouseMove(X, Y: Integer);
procedure MouseUp(Button: TMouseButton; X, Y: Integer);
function CalcRealObjectRect(R: TRect): TRect;
procedure CalcAllRealObjectRect;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure LoadObjects;
procedure LoadDefObjects;
procedure MouseEnterEvent(IDName: String);
procedure MouseLeaveEvent(IDName: String);
procedure MouseUpEvent(IDName: String;
X, Y: Integer; ObjectRect: TRect;
Button: TMouseButton);
procedure MouseDownEvent(IDName: String;
X, Y: Integer; ObjectRect: TRect;
Button: TMouseButton);
procedure MouseMoveEvent(IDName: String; X, Y: Integer;
ObjectRect: TRect);
procedure PaintEvent(IDName: String; Canvas: TCanvas; ObjectRect: TRect);
procedure SkinMainMenuClose;
procedure SkinMenuClose2;
procedure ArangeMinimizedChilds;
function GetAutoRenderingInActiveImage: Boolean;
public
PreviewMode: Boolean;
SkinMenu: TbsSkinMenu;
FForm: TForm;
ObjectList: TList;
procedure AddChildToMenu(Child: TCustomForm);
procedure AddChildToBar(Child: TCustomForm);
procedure RefreshMDIBarTab(Child: TCustomForm);
procedure DeleteChildFromMenu(Child: TCustomForm);
procedure DeleteChildFromBar(Child: TCustomForm);
procedure MDIItemClick(Sender: TObject);
procedure UpDateChildCaptionInMenu(Child: TCustomForm);
procedure UpDateChildActiveInMenu;
function GetMinWidth: Integer;
function GetMinHeight: Integer;
function GetMaxWidth: Integer;
function GetMaxHeight: Integer;
procedure MinimizeAll;
procedure MaximizeAll;
procedure RestoreAll;
procedure Tile;
procedure Cascade;
procedure CloseAll;
function GetFormActive: Boolean;
procedure MinimizeToTray;
procedure RestoreFromTray;
procedure SkinMenuOpen;
procedure SkinMenuClose;
procedure DrawSkinObject(AObject: TbsActiveSkinObject);
//
procedure SetFormStyle(FS: TFormStyle);
procedure PopupSkinMenu(Menu: TMenu; P: TPoint);
procedure PopupSkinMenu1(Menu: TMenu; R: TRect; PopupUp: Boolean);
procedure ClearObjects;
function GetIndex(AIDName: String): Integer;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure PaintNCSkin;
procedure PaintBG(DC: HDC);
procedure PaintBG2(DC: HDC);
procedure PaintBG3(DC: HDC);
//
procedure PaintNCDefault;
procedure PaintBGDefault(DC: HDC);
procedure PaintMDIBGDefault(DC: HDC);
procedure CalcDefRects;
//
procedure SetEnabled(AIDName: String; Value: Boolean);
procedure UserObjectDraw(AIDName: String);
procedure LinkMenu(AIDName: String; AMenu: TMenu; APopupUp: Boolean);
//
property RollUpState: Boolean read FRollUpState write SetRollUpState;
property WindowState: TWindowState read FWindowState write SetWindowState;
property RealHeight: Integer read GetRealHeight write OldHeight;
published
property ClientWidth: Integer read FClientWidth write FClientWidth;
property ClientHeight: Integer read FClientHeight write FClientHeight;
property HideCaptionButtons: Boolean read
FHideCaptionButtons write FHideCaptionButtons;
property AlwaysShowInTray: Boolean read FAlwaysShowInTray write FAlwaysShowInTray;
property LogoBitMap: TBitMap read FLogoBitMap write SetLogoBitMap;
property LogoBitMapTransparent: Boolean
read FLogoBitMapTransparent
write FLogoBitMapTransparent;
property AlwaysMinimizeToTray: Boolean
read FAlwaysMinimizeToTray write FAlwaysMinimizeToTray;
property UseSkinFontInMenu: boolean
read GetUseSkinFontInMenu write SetUseSkinFontInMenu;
property ShowIcon: Boolean read FShowIcon write SetShowIcon;
property MaximizeOnFullScreen: Boolean
read FMaximizeOnFullScreen write FMaximizeOnFullScreen;
property AlphaBlend: Boolean read FAlphaBlend write SetAlphaBlend;
property AlphaBlendAnimation: Boolean
read FAlphaBlendAnimation write FAlphaBlendAnimation;
property AlphaBlendValue: Byte
read FAlphaBlendValue write SetAlphaBlendValue;
property SkinHint: TbsSkinHint read FSkinHint write FSkinHint;
property ShowObjectHint: Boolean read FShowObjectHint write FShowObjectHint;
property UseDefaultObjectHint: Boolean read FUseDefaultObjectHint write FUseDefaultObjectHint;
property MenusAlphaBlend: Boolean
read FMenusAlphaBlend write SetMenusAlphaBlend;
property MenusAlphaBlendAnimation: Boolean
read FMenusAlphaBlendAnimation write SetMenusAlphaBlendAnimation;
property MenusAlphaBlendValue: Byte
read FMenusAlphaBlendValue write SetMenusAlphaBlendValue;
property DefCaptionFont: TFont read FDefCaptionFont write SetDefCaptionFont;
property DefInActiveCaptionFont: TFont read FDefInActiveCaptionFont write SetDefInActiveCaptionFont;
property DefMenuItemHeight: Integer
read GetDefaultMenuItemHeight write SetDefaultMenuItemHeight;
property DefMenuItemFont: TFont
read GetDefaultMenuItemFont write SetDefaultMenuItemFont;
property TrayIcon: TbsTrayIcon read FTrayIcon write SetTrayIcon;
property UseDefaultSysMenu: Boolean
read FUseDefaultSysMenu write FUseDefaultSysMenu;
property MainMenuBar: TbsSkinMainMenuBar read FMainMenuBar write FMainMenuBar;
property MDITabsBar: TbsSkinMDITabsBar read FMDITabsBar write FMDITabsBar;
property SystemMenu: TPopupMenu read FSystemMenu write FSystemMenu;
property SkinData: TbsSkinData read FSD write SetSkinData;
property MenusSkinData: TbsSkinData read FMSD write SetMenusSkinData;
property MinHeight: Integer read FMinHeight write FMinHeight;
property MinWidth: Integer read FMinWidth write FMinWidth;
property Magnetic: Boolean read FMagnetic write FMagnetic;
property MagneticSize: Byte read FMagneticSize write FMagneticSize;
property BorderIcons: TbsBorderIcons read FBorderIcons write SetBorderIcons;
property OnChangeSkinData: TNotifyEvent read FOnChangeSkinData
write FOnChangeSkinData;
property OnMouseUpEvent: TbsMouseUpEvent read FOnMouseUpEvent
write FOnMouseUpEvent;
property OnMouseDownEvent: TbsMouseDownEvent read FOnMouseDownEvent
write FOnMouseDownEvent;
property OnMouseMoveEvent: TbsMouseMoveEvent read FOnMouseMoveEvent
write FOnMouseMoveEvent;
property OnMouseEnterEvent: TbsMouseEnterEvent read FOnMouseEnterEvent
write FOnMouseEnterEvent;
property OnMouseLeaveEvent: TbsMouseLeaveEvent read FOnMouseLeaveEvent
write FOnMouseLeaveEvent;
property OnPaintEvent: TbsPaintEvent read FOnPaintEvent
write FOnPaintEvent;
property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
property OnDeActivate: TNotifyEvent read FOnDeActivate write FOnDeActivate;
property OnSkinMenuOpen: TNotifyEvent read FOnSkinMenuOpen
write FOnSkinMenuOpen;
property OnSkinMenuClose: TNotifyEvent read FOnSkinMenuClose
write FOnSkinMenuClose;
property OnChangeRollUpState: TNotifyEvent read FOnChangeRollUpState
write FOnChangeRollUpState;
property OnMainMenuEnter: TNotifyEvent read FOnMainMenuEnter
write FOnMainMenuEnter;
property OnMainMenuExit: TNotifyEvent read FOnMainMenuExit
write FOnMainMenuExit;
property OnMinimizeToTray: TNotifyEvent
read FOnMinimizeToTray write FOnMinimizeToTray;
property OnRestoreFromTray: TNotifyEvent
read FOnRestoreFromTray write FOnRestoreFromTray;
property OnActivateCustomObject: TbsActivateCustomObjectEvent
read FOnActivateCustomObject write FOnActivateCustomObject;
end;
TbsMDITab = class(TObject)
protected
TabsBar: TbsSkinMDITabsBar;
public
Active, MouseIn: Boolean;
ObjectRect: TRect;
Child: TCustomForm;
constructor Create(AParentBar: TbsSkinMDITabsBar; AChild: TCustomForm);
procedure Draw(Cnvs: TCanvas);
end;
TbsMDITabMouseEnterEvent = procedure (MDITab: TbsMDITab) of object;
TbsMDITabMouseLeaveEvent = procedure (MDITab: TbsMDITab) of object;
TbsMDITabMouseDownEvent = procedure (Button: TMouseButton; Shift: TShiftState; MDITab: TbsMDITab) of object;
TbsMDITabMouseUpEvent = procedure (Button: TMouseButton; Shift: TShiftState; MDITab: TbsMDITab) of object;
TbsSkinMDITabsBar = class(TbsSkinControl)
private
IsDrag: Boolean;
DX, TabDX: Integer;
FDown: Boolean;
DragIndex: Integer;
FOnTabMouseEnter: TbsMDITabMouseEnterEvent;
FOnTabMouseLeave: TbsMDITabMouseLeaveEvent;
FOnTabMouseUp: TbsMDITabMouseUpEvent;
FOnTabMouseDown: TbsMDITabMouseDownEvent;
FDefaultTabWidth: Integer;
FDefaultHeight: Integer;
FDefaultFont: TFont;
ActiveTabIndex, OldTabIndex: Integer;
FMoveTabs: Boolean;
procedure SetDefaultHeight(Value: Integer);
procedure SetDefaultFont(Value: TFont);
procedure CalcObjectRects;
procedure TestActive(X, Y: Integer);
procedure CheckActive;
protected
procedure CreateControlDefaultImage(B: TBitMap); override;
procedure CreateControlSkinImage(B: TBitMap); override;
procedure ClearObjects;
procedure GetSkinData; override;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
function GetMoveIndex: Integer;
public
ObjectList: TList;
Picture: TBitMap;
TabRect, ActiveTabRect, MouseInTabRect: TRect;
TabsBGRect: TRect;
TabLeftOffset, TabRightOffset: Integer;
FontName: String;
FontStyle: TFontStyles;
FontHeight: Integer;
FontColor, ActiveFontColor, MouseInFontColor: TColor;
UpDown: String;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetTab(X, Y: Integer): TbsMDITab;
function GetTabIndex(X, Y: Integer): Integer;
procedure AddTab(Child: TCustomForm);
procedure DeleteTab(Child: TCustomForm);
procedure ChangeSkinData; override;
published
property MoveTabs: Boolean read FMoveTabs write FMoveTabs;
property DefaultHeight: Integer read FDefaultHeight write SetDefaultHeight;
property DefaultFont: TFont read FDefaultFont write SetDefaultFont;
property DefaultTabWidth: Integer read FDefaultTabWidth write FDefaultTabWidth;
property Align;
property PopupMenu;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property ParentShowHint;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnTabMouseEnter: TbsMDITabMouseEnterEvent
read FOnTabMouseEnter write FOnTabMouseEnter;
property OnTabMouseLeave: TbsMDITabMouseLeaveEvent
read FOnTabMouseLeave write FOnTabMouseLeave;
property OnTabMouseUp: TbsMDITabMouseUpEvent
read FOnTabMouseUp write FOnTabMouseUp;
property OnTabMouseDown: TbsMDITabMouseDownEvent
read FOnTabMouseDown write FOnTabMouseDown;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
property OnContextPopup;
end;
function GetBusinessSkinFormComponent(AForm: TCustomForm): TbsBusinessSkinForm;
function GetMDIChildBusinessSkinFormComponent: TbsBusinessSkinForm;
function GetMDIChildBusinessSkinFormComponent2: TbsBusinessSkinForm;
implementation
Uses bsEffects, bsConst;
const
WS_EX_LAYERED = $80000;
MouseTimerInterval = 50;
MorphTimerInterval = 20;
AnimateTimerInterval = 25;
MorphInc = 0.2;
// effects cosnts
InActiveBrightnessKf = 0.5;
InActiveDarknessKf = 0.3;
InActiveNoiseAmount = 50;
//
HTNCACTIVE = HTOBJECT;
TRACKMARKEROFFSET = 5;
DEFCAPTIONHEIGHT = 19;
DEFBUTTONSIZE = 17;
DEFTOOLCAPTIONHEIGHT = 15;
DEFTOOLBUTTONSIZE = 13;
DEFFORMMINWIDTH = 120;
TMI_RESTORENAME = 'TRAY_BSF_RESTORE';
TMI_CLOSENAME = 'TRAY_BSF_CLOSE';
MI_MINNAME = 'BSF_MINITEM';
MI_MAXNAME = 'BSF_MAXITEM';
MI_CLOSENAME = 'BSF_CLOSE';
MI_RESTORENAME = 'BSF_RESTORE';
MI_MINTOTRAYNAME = 'BSF_MINTOTRAY';
MI_ROLLUPNAME = 'BSF_ROLLUP';
MI_CHILDITEM = '_BSFCHILDITEM';
WM_MDICHANGESIZE = WM_USER + 206;
WM_MDICHILDMAX = WM_USER + 207;
WM_MDICHILDRESTORE = WM_USER + 208;
function GetBusinessSkinFormComponent;
var
i: Integer;
begin
Result := nil;
if AForm <> nil then
for i := 0 to AForm.ComponentCount - 1 do
if AForm.Components[i] is TbsBusinessSkinForm
then
begin
Result := (AForm.Components[i] as TbsBusinessSkinForm);
Break;
end;
end;
function GetMDIChildBusinessSkinFormComponent;
var
i: Integer;
begin
Result := nil;
for i := 0 to Application.MainForm.MDIChildCount - 1 do
begin
Result := GetBusinessSkinFormComponent(Application.MainForm.MDIChildren[i]);
if (Result <> nil) and (Result.WindowState = wsMaximized)
then
Break
else
Result := nil;
end;
end;
function GetMDIChildBusinessSkinFormComponent2;
begin
if (Application.MainForm <> nil) and (Application.MainForm.ActiveMDIChild <> nil)
then
Result := GetBusinessSkinFormComponent(Application.MainForm.ActiveMDIChild)
else
Result := nil;
end;
//============= TbsActiveSkinObject =============//
constructor TbsActiveSkinObject.Create;
begin
Visible := True;
Enabled := True;
Parent := AParent;
SD := Parent.SkinData;
FMorphKf := 0;
Morphing := False;
if AData <> nil
then
begin
with AData do
begin
Self.IDName := IDName;
Self.Hint := Hint;
Self.SkinRectInAPicture := SkinRectInAPicture;
Self.SkinRect := SkinRect;
Self.ActiveSkinRect := ActiveSkinRect;
Self.InActiveSkinRect:= InActiveSkinRect;
Self.Morphing := Morphing;
Self.MorphKind := MorphKind;
if (ActivePictureIndex <> - 1) and
(ActivePictureIndex < SD.FActivePictures.Count)
then
ActivePicture := TBitMap(SD.FActivePictures.Items[ActivePictureIndex])
else
begin
ActivePicture := nil;
ActiveSkinRect := NullRect;
end;
end;
if Morphing and IsNullRect(ActiveSkinRect) then Morphing := False;
ObjectRect := SkinRect;
Picture := SD.FPicture;
end;
end;
procedure TbsActiveSkinObject.ReDraw;
begin
if Morphing
then Parent.MorphTimer.Enabled := True
else Parent.DrawSkinObject(Self);
end;
procedure TbsActiveSkinObject.DblClick;
begin
end;
procedure TbsActiveSkinObject.MouseDown(X, Y: Integer; Button: TMouseButton);
begin
Parent.MouseDownEvent(IDName, X, Y, ObjectRect, Button);
end;
procedure TbsActiveSkinObject.MouseUp(X, Y: Integer; Button: TMouseButton);
begin
if FMouseIn then Parent.MouseUpEvent(IDName, X, Y, ObjectRect, Button);
end;
procedure TbsActiveSkinObject.MouseMove(X, Y: Integer);
begin
Parent.MouseMoveEvent(IDName, X, Y, ObjectRect);
end;
procedure TbsActiveSkinObject.MouseEnter;
begin
FMouseIn := True;
Active := True;
if not IsNullRect(ActiveSkinRect) then ReDraw;
Parent.MouseEnterEvent(IDName);
end;
procedure TbsActiveSkinObject.MouseLeave;
begin
FMouseIn := False;
Active := False;
if not IsNullRect(ActiveSkinRect) then ReDraw;
Parent.MouseLeaveEvent(IDName);
end;
function TbsActiveSkinObject.CanMorphing;
begin
Result := (Active and (MorphKf < 1)) or
(not Active and (MorphKf > 0));
end;
procedure TbsActiveSkinObject.DoMorphing;
begin
if Active
then MorphKf := MorphKf + MorphInc
else MorphKf := MorphKf - MorphInc;
Parent.DrawSkinObject(Self);
end;
procedure TbsActiveSkinObject.Draw;
procedure CreateObjectImage(B: TBitMap; AActive: Boolean);
begin
B.Width := RectWidth(ObjectRect);
B.Height := RectHeight(ObjectRect);
with B.Canvas do
begin
if AActive
then
CopyRect(Rect(0, 0, B.Width, B.Height), ActivePicture.Canvas, ActiveSkinRect)
else
if SkinRectInApicture
then
CopyRect(Rect(0, 0, B.Width, B.Height), ActivePicture.Canvas, SkinRect)
else
CopyRect(Rect(0, 0, B.Width, B.Height), Picture.Canvas, SkinRect);
end;
end;
var
PBuffer, APBuffer: TbsEffectBmp;
Buffer, ABuffer: TBitMap;
ASR, SR: TRect;
begin
ASR := ActiveSkinRect;
SR := SkinRect;
if Enabled and (not Parent.GetFormActive) and (not IsNullRect(InActiveSkinRect))
then
begin
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas, InActiveSkinRect)
end
else
if not Morphing or
((Active and (MorphKf = 1)) or (not Active and (MorphKf = 0)))
then
begin
if Active and not IsNullRect(ASR)
then
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas, ASR)
else
if UpDate or SkinRectInApicture
then
begin
if SkinRectInApicture
then
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas, SR)
else
Cnvs.CopyRect(ObjectRect, Picture.Canvas, SR);
end;
end
else
begin
Buffer := TBitMap.Create;
ABuffer := TBitMap.Create;
CreateObjectImage(Buffer, False);
CreateObjectImage(ABuffer, True);
PBuffer := TbsEffectBmp.CreateFromhWnd(Buffer.Handle);
APBuffer := TbsEffectBmp.CreateFromhWnd(ABuffer.Handle);
case MorphKind of
mkDefault: PBuffer.Morph(APBuffer, MorphKf);
mkGradient: PBuffer.MorphGrad(APBuffer, MorphKf);
mkLeftGradient: PBuffer.MorphLeftGrad(APBuffer, MorphKf);
mkRightGradient: PBuffer.MorphRightGrad(APBuffer, MorphKf);
mkLeftSlide: PBuffer.MorphLeftSlide(APBuffer, MorphKf);
mkRightSlide: PBuffer.MorphRightSlide(APBuffer, MorphKf);
mkPush: PBuffer.MorphPush(APBuffer, MorphKf);
end;
PBuffer.Draw(Cnvs.Handle, ObjectRect.Left, ObjectRect.Top);
PBuffer.Free;
APBuffer.Free;
Buffer.Free;
ABuffer.Free;
end;
end;
procedure TbsActiveSkinObject.SetMorphKf(Value: Double);
begin
FMorphKf := Value;
if FMorphKf < 0 then FMorphKf := 0 else
if FMorphKf > 1 then FMorphKf := 1;
end;
procedure TbsUserObject.Draw;
begin
Parent.PaintEvent(IDName, Cnvs, ObjectRect);
end;
//==============TbsSkinAnimateObject==================//
constructor TbsSkinAnimateObject.Create;
begin
inherited Create(AParent, AData);
Increment := True;
FFrame := 1;
FInc := AnimateTimerInterval;
TimerInterval := TbsDataSkinAnimate(AData).TimerInterval;
if TimerInterval < FInc then TimerInterval := FInc;
with TbsDataSkinAnimate(AData) do
begin
Self.CountFrames := CountFrames;
Self.Cycle := Cycle;
Self.ButtonStyle := ButtonStyle;
Self.Command := Command;
end;
FPopupUp := False;
MenuItem := nil;
end;
procedure TbsSkinAnimateObject.DoMinToTray;
begin
Parent.MinimizeToTray;
end;
procedure TbsSkinAnimateObject.DoMax;
begin
if Parent.WindowState = wsMaximized
then Parent.WindowState := wsNormal
else Parent.WindowState := wsMaximized;
end;
procedure TbsSkinAnimateObject.DoMin;
begin
if Parent.WindowState = wsMinimized
then Parent.WindowState := wsNormal
else Parent.WindowState := wsMinimized;
end;
procedure TbsSkinAnimateObject.DoClose;
begin
Parent.FForm.Close;
end;
procedure TbsSkinAnimateObject.DoRollUp;
begin
Parent.RollUpState := not Parent.RollUpState;
end;
procedure TbsSkinAnimateObject.DoCommand;
begin
case Command of
cmMinimizeToTray: DoMinToTray;
cmClose: DoClose;
cmMinimize:
begin
if not Parent.AlwaysMinimizeToTray
then
DoMin
else
Parent.MinimizeToTray;
end;
cmMaximize: DoMax;
cmSysMenu:
begin
MenuItem := Parent.GetSystemMenu;
TrackMenu;
end;
cmDefault:
if MenuItem <> nil then TrackMenu;
cmRollUp: DoRollUp;
end;
end;
procedure TbsSkinAnimateObject.TrackMenu;
var
R: TRect;
Menu: TMenu;
P: TPoint;
begin
if MenuItem = nil then Exit;
if MenuItem.Count = 0 then Exit;
R := ObjectRect;
if Parent.FForm.FormStyle = fsMDIChild
then
begin
if Parent.FSkinSupport
then
P := Point(-Parent.NewClRect.Left, -Parent.NewClRect.Top)
else
P := Point(- 3, -Parent.GetDefCaptionHeight - 3);
P := Parent.FForm.ClientToScreen(P);
OffsetRect(R, P.X, P.Y);
end
else
OffsetRect(R, Parent.FForm.Left, Parent.FForm.Top);
Menu := MenuItem.GetParentMenu;
if Menu is TbsSkinPopupMenu
then
TbsSkinPopupMenu(Menu).PopupFromRect(R, FPopupUp)
else
begin
Parent.SkinMenuOpen;
if Parent.MenusSkinData = nil
then
Parent.SkinMenu.Popup(nil, Parent.SkinData, 0, R, MenuItem, FPopupUp)
else
Parent.SkinMenu.Popup(nil, Parent.MenusSkinData, 0, R, MenuItem, FPopupUp);
end;
end;
procedure TbsSkinAnimateObject.DblCLick;
begin
if Command = cmSysMenu then DoClose;
end;
procedure TbsSkinAnimateObject.MouseUp;
begin
inherited;
if FMouseIn and ButtonStyle and (Button = mbLeft)
then DoCommand;
end;
procedure TbsSkinAnimateObject.SetFrame;
begin
if Increment
then
begin
if Value > CountFrames then FFrame := 1 else FFrame := Value;
end
else
begin
if Value < 1 then FFrame := CountFrames else FFrame := Value;
end;
Parent.DrawSkinObject(Self);
end;
procedure TbsSkinAnimateObject.Start;
begin
FInc := AnimateTimerInterval;
FFrame := 1;
Active := True;
if not Parent.AnimateTimer.Enabled
then
Parent.AnimateTimer.Enabled := True;
end;
procedure TbsSkinAnimateObject.Stop;
begin
Frame := 1;
Active := False;
FInc := AnimateTimerInterval;
end;
procedure TbsSkinAnimateObject.ChangeFrame;
begin
if FInc >= TimerInterval
then
begin
if Increment
then
begin
Frame := Frame + 1;
if not Cycle and (FFrame = CountFrames) then Active := False;
end
else
begin
Frame := Frame - 1;
if FFrame = 1 then Active := False;
end;
FInc := AnimateTimerInterval;
end
else
Inc(FInc, AnimateTimerInterval);
end;
procedure TbsSkinAnimateObject.MouseEnter;
begin
FMouseIn := True;
if ButtonStyle
then
begin
Active := True;
Increment := True;
if not Parent.AnimateTimer.Enabled
then
Parent.AnimateTimer.Enabled := True;
end;
Parent.MouseEnterEvent(IDName);
end;
procedure TbsSkinAnimateObject.MouseLeave;
begin
if not FMouseIn then Exit;
FMouseIn := False;
if ButtonStyle
then
begin
Active := True;
Increment := False;
if not Parent.AnimateTimer.Enabled
then
Parent.AnimateTimer.Enabled := True;
end;
Parent.MouseLeaveEvent(IDName);
end;
procedure TbsSkinAnimateObject.Draw;
var
FW, FH: Integer;
begin
FW := RectWidth(SkinRect);
FH := RectHeight(SkinRect);
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas,
Rect(ActiveSkinRect.Left + (FFrame - 1) * FW, ActiveSkinRect.Top,
ActiveSkinRect.Left + FFrame * FW,
ActiveSkinRect.Top + FH));
end;
//============= TbsSkinButtonObject ============= //
constructor TbsSkinButtonObject.Create;
begin
inherited Create(AParent, AData);
if AData <> nil
then
with TbsDataSkinButton(AData) do
begin
Self.DownRect := DownRect;
Self.DisableSkinRect := DisableSkinRect;
end;
MenuItem := nil;
FPopupUp := False;
end;
function TbsSkinButtonObject.CanMorphing;
begin
Result := inherited CanMorphing;
Result := Result and not ((MenuItem <> nil) and FDown);
end;
procedure TbsSkinButtonObject.Draw;
begin
if not Enabled and not IsNullRect(DisableSkinRect)
then
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas, DisableSkinRect)
else
if FDown and not IsNullRect(DownRect) and FMouseIn
then
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas, DownRect)
else
inherited Draw(Cnvs, UpDate);
end;
procedure TbsSkinButtonObject.SetDown;
begin
FDown := Value;
if Morphing and Active then MorphKf := 1;
Parent.DrawSkinObject(Self);
if Morphing and not FDown then ReDraw;
end;
procedure TbsSkinButtonObject.TrackMenu;
var
R: TRect;
Menu: TMenu;
P: TPoint;
begin
if MenuItem = nil then Exit;
if MenuItem.Count = 0 then Exit;
R := ObjectRect;
if Parent.FForm.FormStyle = fsMDIChild
then
begin
if Parent.FSkinSupport
then
P := Point(-Parent.NewClRect.Left, -Parent.NewClRect.Top)
else
P := Point(- 3, -Parent.GetDefCaptionHeight - 3);
P := Parent.FForm.ClientToScreen(P);
OffsetRect(R, P.X, P.Y);
end
else
OffsetRect(R, Parent.FForm.Left, Parent.FForm.Top);
Menu := MenuItem.GetParentMenu;
if Menu is TbsSkinPopupMenu
then
TbsSkinPopupMenu(Menu).PopupFromRect(R, FPopupUp)
else
begin
Parent.SkinMenuOpen;
if Menu is TbsSkinMainMenu
then
Parent.SkinMenu.Popup(nil, TbsSkinMainMenu(Menu).SkinData, 0, R, MenuItem, FPopupUp)
else
if Parent.MenusSkinData = nil
then
Parent.SkinMenu.Popup(nil, Parent.SkinData, 0, R, MenuItem, FPopupUp)
else
Parent.SkinMenu.Popup(nil, Parent.MenusSkinData, 0, R, MenuItem, FPopupUp);
end;
end;
procedure TbsSkinButtonObject.MouseDown;
begin
if not Enabled then Exit;
if (Button = mbLeft) and not FDown
then
begin
SetDown(True);
TrackMenu;
end;
inherited MouseDown(X, Y, Button);
end;
procedure TbsSkinButtonObject.MouseUp;
begin
if not Enabled then Exit;
if (Button <> mbLeft)
then
begin
inherited MouseUp(X, Y, Button);
Exit;
end;
if (MenuItem = nil) and FDown
then
SetDown(False);
inherited MouseUp(X, Y, Button);
end;
procedure TbsSkinButtonObject.MouseEnter;
begin
FMouseIn := True;
Active := True;
if IsNullRect(DownRect) or not FDown
then
begin
if not IsNullRect(ActiveSkinRect) then ReDraw;
end
else
begin
if FDown
then
begin
if Morphing then FMorphKf := 1;
Parent.DrawSkinObject(Self)
end
else
if not IsNullRect(ActiveSkinRect) then ReDraw;
end;
Parent.MouseEnterEvent(IDName);
end;
procedure TbsSkinButtonObject.MouseLeave;
begin
FMouseIn := False;
Active := False;
if (MenuItem = nil) or ((MenuItem <> nil) and not FDown)
then
begin
Parent.DrawSkinObject(Self);
Redraw;
end;
Parent.MouseLeaveEvent(IDName);
end;
//============= TbsSkinStdButtonObject =================//
constructor TbsSkinStdButtonObject.Create;
begin
inherited Create(AParent, AData);
if AData <> nil
then
with TbsDataSkinStdButton(AData) do
begin
Self.Command := Command;
Self.RestoreRect := RestoreRect;
Self.RestoreActiveRect := RestoreActiveRect;
Self.RestoreInActiveRect := RestoreInActiveRect;
Self.RestoreDownRect := RestoreDownRect;
FSkinSupport := True;
end
else
FSkinSupport := False;
end;
function TbsSkinStdButtonObject.CanMorphing: Boolean;
begin
if (Command = cmSysMenu) and Parent.ShowIcon and
(SkinRectInAPicture)
then
Result := False
else
Result := inherited CanMorphing;
end;
procedure TbsSkinStdButtonObject.DefaultDraw(Cnvs: TCanvas);
var
Buffer: TBitMap;
R: TRect;
IX, IY: Integer;
IC: TColor;
begin
if (Command = cmSysMenu) and Parent.FShowIcon
then
begin
Parent.DrawFormIcon(Cnvs, ObjectRect.Left, ObjectRect.Top);
Exit;
end;
Buffer := TBitMap.Create;
Buffer.Width := RectWidth(ObjectRect);
Buffer.Height := RectHeight(ObjectRect);
R := Rect(0, 0, Buffer.Width, Buffer.Height);
with Buffer.Canvas do
begin
if FDown and FMouseIn
then
begin
Frame3D(Buffer.Canvas, R, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
Brush.Color := BS_XP_BTNDOWNCOLOR;
FillRect(R);
end
else
if FMouseIn
then
begin
Frame3D(Buffer.Canvas, R, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
Brush.Color := BS_XP_BTNACTIVECOLOR;
FillRect(R);
end
else
begin
Brush.Color := clBtnFace;
FillRect(R);
end;
end;
IX := Buffer.Width div 2 - 5;
IY := Buffer.Height div 2 - 4;
if FDown and FMouseIn
then
begin
Inc(IX);
Inc(IY);
end;
if Enabled
then
IC := clBtnText
else
IC := clBtnShadow;
case Command of
cmMinimizeToTray:
DrawMTImage(Buffer.Canvas, IX, IY, IC);
cmClose:
DrawCloseImage(Buffer.Canvas, IX, IY, IC);
cmMaximize:
if Parent.WindowState = wsMaximized
then DrawRestoreImage(Buffer.Canvas, IX, IY, IC)
else DrawMaximizeImage(Buffer.Canvas, IX, IY, IC);
cmMinimize:
if Parent.WindowState = wsMinimized
then DrawRestoreImage(Buffer.Canvas, IX, IY, IC)
else DrawMinimizeImage(Buffer.Canvas, IX, IY, IC);
cmRollUp:
if Parent.RollUpState
then DrawRestoreRollUpImage(Buffer.Canvas, IX, IY, IC)
else DrawRollUpImage(Buffer.Canvas, IX, IY, IC);
cmSysMenu:
DrawSysMenuImage(Buffer.Canvas, IX, IY, IC);
end;
Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, Buffer);
Buffer.Free;
end;
procedure TbsSkinStdButtonObject.Draw;
procedure CreateRestoreObjectImage(B: TBitMap; AActive: Boolean);
begin
B.Width := RectWidth(ObjectRect);
B.Height := RectHeight(ObjectRect);
with B.Canvas do
begin
if AActive
then
CopyRect(Rect(0, 0, B.Width, B.Height), ActivePicture.Canvas, RestoreActiveRect)
else
CopyRect(Rect(0, 0, B.Width, B.Height), ActivePicture.Canvas, RestoreRect);
end;
end;
var
PBuffer, APBuffer: TbsEffectBmp;
Buffer, ABuffer: TBitMap;
ASR, SR: TRect;
FRestoreMode: Boolean;
begin
if not FSkinSupport
then
begin
DefaultDraw(Cnvs);
Exit;
end;
if (not Enabled) or
(Enabled and (not Parent.GetFormActive) and (not IsNullRect(InActiveSkinRect)))
then
begin
inherited;
Exit;
end;
if (Command = cmSysMenu) and Parent.FShowIcon and SkinRectInAPicture
then
begin
Parent.DrawFormIcon(Cnvs, ObjectRect.Left, ObjectRect.Top);
FMorphKf := 0;
Exit;
end;
FRestoreMode := False;
case Command of
cmMaximize:
if Parent.WindowState = wsMaximized
then FRestoreMode := True;
cmMinimize:
if Parent.WindowState = wsMinimized
then FRestoreMode := True;
cmRollUp:
if Parent.RollUpState
then FRestoreMode := True;
end;
if IsNullRect(RestoreRect) or not FRestoreMode
then
inherited
else
begin
if not Parent.GetFormActive and not IsNullRect(RestoreInActiveRect)
then
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas, RestoreInActiveRect)
else
if FDown and not IsNullRect(RestoreDownRect) and FMouseIn
then
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas, RestoreDownRect)
else
begin
ASR := RestoreActiveRect;
SR := RestoreRect;
if not Morphing or
((Active and (MorphKf = 1)) or (not Active and (MorphKf = 0)))
then
begin
if Active and not IsNullRect(ASR)
then
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas, ASR)
else
Cnvs.CopyRect(ObjectRect, ActivePicture.Canvas, SR);
end
else
begin
Buffer := TBitMap.Create;
ABuffer := TBitMap.Create;
CreateRestoreObjectImage(Buffer, False);
CreateRestoreObjectImage(ABuffer, True);
PBuffer := TbsEffectBmp.CreateFromhWnd(Buffer.Handle);
APBuffer := TbsEffectBmp.CreateFromhWnd(ABuffer.Handle);
case MorphKind of
mkDefault: PBuffer.Morph(APBuffer, MorphKf);
mkGradient: PBuffer.MorphGrad(APBuffer, MorphKf);
mkLeftGradient: PBuffer.MorphLeftGrad(APBuffer, MorphKf);
mkRightGradient: PBuffer.MorphRightGrad(APBuffer, MorphKf);
mkLeftSlide: PBuffer.MorphLeftSlide(APBuffer, MorphKf);
mkRightSlide: PBuffer.MorphRightSlide(APBuffer, MorphKf);
mkPush: PBuffer.MorphPush(APBuffer, MorphKf)
end;
PBuffer.Draw(Cnvs.Handle, ObjectRect.Left, ObjectRect.Top);
PBuffer.Free;
APBuffer.Free;
Buffer.Free;
ABuffer.Free;
end;
end;
end;
end;
procedure TbsSkinStdButtonObject.DoMinimizeToTray;
begin
Parent.MinimizeToTray;
end;
procedure TbsSkinStdButtonObject.DoMax;
begin
if Parent.WindowState = wsMaximized
then Parent.WindowState := wsNormal
else Parent.WindowState := wsMaximized;
end;
procedure TbsSkinStdButtonObject.DoMin;
begin
if Parent.WindowState = wsMinimized
then Parent.WindowState := wsNormal
else Parent.WindowState := wsMinimized;
end;
procedure TbsSkinStdButtonObject.DoClose;
begin
Parent.FForm.Close;
end;
procedure TbsSkinStdButtonObject.DoRollUp;
begin
Parent.RollUpState := not Parent.RollUpState;
end;
procedure TbsSkinStdButtonObject.DoCommand;
begin
case Command of
cmMinimizeToTray: DoMinimizeToTray;
cmClose: DoClose;
cmMinimize:
if Parent.AlwaysMinimizeToTray
then
Parent.MinimizeToTray
else
DoMin;
cmMaximize: DoMax;
cmRollUp: DoRollUp;
end;
end;
procedure TbsSkinStdButtonObject.DblClick;
begin
if Command = cmSysMenu then DoClose;
end;
procedure TbsSkinStdButtonObject.MouseDown;
begin
if not Enabled then Exit;
if (Button = mbLeft) and not FDown
then
begin
SetDown(True);
if (Command = cmSysMenu)
then
begin
Self.MenuItem := Parent.GetSystemMenu;
TrackMenu;
end;
end;
end;
procedure TbsSkinStdButtonObject.MouseUp;
begin
if (Command = cmClose)
then
begin
inherited;
if Active and (Button = mbLeft) then DoCommand;
end
else
begin
if Active and (Button = mbLeft) then DoCommand;
inherited;
end;
end;
//============= TbsSkinCaptionObject ==================//
constructor TbsSkinCaptionObject.Create;
begin
inherited Create(AParent, AData);
with TbsDataSkinCaption(AData) do
begin
Self.FontName := FontName;
Self.FontStyle := FontStyle;
Self.FontHeight := FontHeight;
Self.FontColor := FontColor;
Self.ActiveFontColor := ActiveFontColor;
Self.Alignment := Alignment;
Self.TextRct := TextRct;
Self.Shadow := Shadow;
Self.ShadowColor := ShadowColor;
Self.ActiveShadowColor := ActiveShadowColor;
Self.FrameRect := FrameRect;
Self.ActiveFrameRect := ActiveFrameRect;
Self.FrameLeftOffset := FrameLeftOffset;
Self.FrameRightOffset := FrameRightOffset;
Self.FrameTextRect := FrameTextRect;
end;
end;
procedure TbsSkinCaptionObject.MouseDown;
begin
with Parent do
begin
MouseDownEvent(IDName, X, Y, ObjectRect, Button);
end;
end;
procedure TbsSkinCaptionObject.MouseUp;
begin
with Parent do
begin
MouseUpEvent(IDName, X, Y, ObjectRect, Button);
end;
end;
procedure TbsSkinCaptionObject.MouseEnter;
begin
FMouseIn := True;
Parent.MouseEnterEvent(IDName);
end;
procedure TbsSkinCaptionObject.MouseLeave;
begin
FMouseIn := False;
Parent.MouseLeaveEvent(IDName);
end;
procedure TbsSkinCaptionObject.Draw;
var
Image, ActiveImage: TBitMap;
EB1, EB2: TbsEffectBmp;
tx, ty: Integer;
RealTextRect: TRect;
SR, ASR: TRect;
procedure CnvSetFont(Cnv: TCanvas; FColor: TColor);
begin
with Cnv do
begin
Font.Name := FontName;
Font.Style := FontStyle;
Font.Height := FontHeight;
Font.Color := FColor;
if (Parent.SkinData <> nil) and (Parent.SkinData.ResourceStrData <> nil)
then
Font.CharSet := Parent.SkinData.ResourceStrData.Charset
else
Font.CharSet := Parent.DefCaptionFont.Charset;
end;
end;
function CorrectText(Cnv: TCanvas; var S1: String): String;
var
w: Integer;
S: String;
begin
S := S1;
w := RectWidth(RealTextRect);
Parent.CorrectCaptionText(Cnv, S, w);
Result := S;
end;
procedure CreateCaptionBitMap(DestB: TBitMap; SourceRect: TRect; SourceB: TBitMap);
var
X, XCnt: Integer;
w: Integer;
R: TRect;
XO, LO, RO: Integer;
begin
LO := SD.LTPoint.X - SR.Left;
RO := SR.Right - SD.RTPoint.X;
DestB.Width := RectWidth(ObjectRect);
DestB.Height := RectHeight(ObjectRect);
R := Rect(SourceRect.Left + LO, SourceRect.Top,
SourceRect.Right - RO, SourceRect.Bottom);
if (LO = 0) and (RO = 0)
then
DestB.Canvas.CopyRect(Rect(0, 0, DestB.Width, DestB.Height),
SourceB.Canvas, R)
else
begin
w := RectWidth(R);
XCnt := DestB.Width div w;
for X := 0 to XCnt do
begin
if X * w + w > DestB.Width
then XO := X * w + w - DestB.Width else XO := 0;
Dec(R.Right, XO);
DestB.Canvas.CopyRect(Rect(X * w, 0, X * w + w - XO, DestB.Height),
SourceB.Canvas, R);
end;
end;
with DestB.Canvas do
begin
if LO <> 0
then
CopyRect(Rect(0, 0, LO, DestB.Height),
SourceB.Canvas, Rect(SourceRect.Left, SourceRect.Top,
SourceRect.Left + LO, SourceRect.Bottom));
if RO <> 0
then
CopyRect(Rect(DestB.Width - RO, 0, DestB.Width, DestB.Height),
SourceB.Canvas, Rect(SourceRect.Right - RO, SourceRect.Top,
SourceRect.Right, SourceRect.Bottom));
end;
end;
procedure CalcTextCoord(tw, th: Integer);
var
w, h: Integer;
begin
w := RectWidth(RealTextRect);
h := RectHeight(RealTextRect);
ty := h div 2 - th div 2 + RealTextRect.Top;
case Alignment of
taLeftJustify: tx := RealTextRect.Left;
taRightJustify: tx := RealTextRect.Right - tw;
taCenter: tx := w div 2 - tw div 2 + RealTextRect.Left;
end;
end;
procedure DrawCaptionText(Cnv: TCanvas; OX, OY: Integer; AActive: Boolean);
var
S1: String;
C: TColor;
F: TForm;
B: TBitMap;
FR: TRect;
begin
S1 := Parent.FForm.Caption;
if (Parent.FForm.FormStyle = fsMDIForm) and Parent.IsMDIChildMaximized
then
begin
F := Parent.GetMaximizeMDIChild;
if F <> nil then S1 := S1 + ' - [' + F.Caption + ']';
end;
if (S1 = '') or IsNullRect(TextRct) then Exit;
S1 := CorrectText(Cnv, S1);
with Cnv do
begin
CalcTextCoord(TextWidth(S1), TextHeight(S1));
tx := tx + OX;
ty := ty + OY;
Brush.Style := bsClear;
if not IsNullRect(Self.FrameRect)
then
begin
B := TBitMap.Create;
if (AActive) and not IsNullRect(ActiveFrameRect)
then FR := ActiveFrameRect
else FR := Self.FrameRect;
CreateHSkinImage(FrameLeftOffset, FrameRightOffset, B, ActivePicture, FR,
TextWidth(S1) + RectWidth(Self.FrameRect) - RectWidth(FrameTextRect),
RectHeight(Self.FrameRect));
Draw(TX - FrameTextRect.Left, TY - FrameTextRect.Top, B);
B.Free;
end;
if Shadow
then
begin
if (Parent.SkinData <> nil) and (Parent.SkinData.ResourceStrData <> nil)
then
Font.CharSet := Parent.SkinData.ResourceStrData.Charset
else
Font.Charset := Parent.FDefCaptionFont.Charset;
C := Font.Color;
if AActive
then Font.Color := ActiveShadowColor
else Font.Color := ShadowColor;
TextOut(tx + 1, ty + 1, S1);
Font.Color := C;
end;
TextOut(tx, ty, S1);
end;
end;
var
TextO: Integer;
begin
SR := SkinRect;
ASR := ActiveSkinRect;
RealTextRect := TextRct;
if not IsNullRect(TextRct)
then
begin
TextO := RectWidth(SkinRect) - TextRct.Right;
RealTextRect.Right := RectWidth(ObjectRect) - TextO;
end;
if not IsNullRect(FrameRect)
then
begin
Inc(RealTextRect.Top, FrameTextRect.Top);
Inc(RealTextRect.Left, FrameTextRect.Left);
Dec(RealTextRect.Right, RectWidth(FrameRect) - FrameTextRect.Right);
end;
if Active
then CnvSetFont(Cnvs, ActiveFontColor)
else CnvSetFont(Cnvs, FontColor);
if (((MorphKf > 0) and not Active) or ((MorphKf < 1) and Active)) and Morphing
then
begin
Image := TBitMap.Create;
CreateCaptionBitMap(Image, SR, Picture);
CnvSetFont(Image.Canvas, FontColor);
DrawCaptionText(Image.Canvas, 0, 0, False);
ActiveImage := TBitMap.Create;
CreateCaptionBitMap(ActiveImage, ASR, ActivePicture);
CnvSetFont(ActiveImage.Canvas, ActiveFontColor);
DrawCaptionText(ActiveImage.Canvas, 0, 0, True);
EB1 := TbsEffectBmp.CreateFromhWnd(Image.Handle);
EB2 := TbsEffectBmp.CreateFromhWnd(ActiveImage.Handle);
case MorphKind of
mkDefault: EB1.Morph(EB2, MorphKf);
mkGradient: EB1.MorphGrad(EB2, MorphKf);
mkLeftGradient: EB1.MorphLeftGrad(EB2, MorphKf);
mkRightGradient: EB1.MorphRightGrad(EB2, MorphKf);
mkLeftSlide: EB1.MorphLeftSlide(EB2, MorphKf);
mkRightSlide: EB1.MorphRightSlide(EB2, MorphKf);
mkPush: EB1.MorphPush(EB2, MorphKf)
end;
if Parent.GetAutoRenderingInActiveImage and not Active
then
case Parent.FSD.InActiveEffect of
ieBrightness:
EB1.ChangeBrightness(InActiveBrightnessKf);
ieDarkness:
EB1.ChangeDarkness(InActiveDarknessKf);
ieGrayScale:
EB1.GrayScale;
ieNoise:
EB1.AddMonoNoise(InActiveNoiseAmount);
ieSplitBlur:
EB1.SplitBlur(1);
ieInvert:
EB1.Invert;
end;
EB1.Draw(Cnvs.Handle, ObjectRect.Left, ObjectRect.Top);
EB1.Free;
EB2.Free;
Image.Free;
ActiveImage.Free;
end
else
if IsNullRect(ASR) or (not IsNullRect(ASR) and not Active) and not Morphing
then
DrawCaptionText(Cnvs, ObjectRect.Left, ObjectRect.Top, Active)
else
if not Active and Morphing
then
begin
Image := TBitMap.Create;
CreateCaptionBitMap(Image, SR, Picture);
CnvSetFont(Image.Canvas, FontColor);
DrawCaptionText(Image.Canvas, 0, 0, False);
if Parent.GetAutoRenderingInActiveImage
then
begin
EB1 := TbsEffectBmp.CreateFromhWnd(Image.Handle);
case Parent.FSD.InActiveEffect of
ieBrightness:
EB1.ChangeBrightness(InActiveBrightnessKf);
ieDarkness:
EB1.ChangeDarkness(InActiveDarknessKf);
ieGrayScale:
EB1.GrayScale;
ieNoise:
EB1.AddMonoNoise(InActiveNoiseAmount);
ieSplitBlur:
EB1.SplitBlur(1);
ieInvert:
EB1.Invert;
end;
EB1.Draw(Cnvs.Handle, ObjectRect.Left, ObjectRect.Top);
EB1.Free;
end
else
Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, Image);
Image.Free;
end
else
if Active
then
begin
Image := TBitMap.Create;
CreateCaptionBitMap(Image, ASR, ActivePicture);
CnvSetFont(Image.Canvas, ActiveFontColor);
DrawCaptionText(Image.Canvas, 0, 0, True);
Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, Image);
Image.Free;
end;
end;
//============= TbsSkinMainMenu =============//
constructor TbsSkinMainMenu.Create;
begin
inherited Create(AOwner);
BSF := nil;
FSD := nil;
end;
procedure TbsSkinMainMenu.Notification;
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = FSD) then FSD := nil;
end;
// =========== TbsSkinMainMenuBar ==========//
constructor TbsMenuBarObject.Create;
begin
Parent := AParent;
Enabled := True;
Visible := True;
FMorphKf := 0;
FDown := False;
Morphing := False;
Picture := nil;
if AData <> nil then
with AData do
begin
Self.IDName := IDName;
Self.SkinRect := SkinRect;
Self.ActiveSkinRect := ActiveSkinRect;
Self.DownRect := ActiveSkinRect;
Self.Morphing := Morphing;
Self.MorphKind := MorphKind;
ObjectRect := SkinRect;
if (ActivePictureIndex <> - 1) and
(ActivePictureIndex < Parent.SkinData.FActivePictures.Count)
then
Picture := TBitMap(Parent.SkinData.FActivePictures.Items[ActivePictureIndex]);
if Morphing and IsNullRect(ActiveSkinRect) then Morphing := False;
end;
end;
procedure TbsMenuBarObject.DblClick;
begin
end;
procedure TbsMenuBarObject.ReDraw;
begin
if Morphing
then Parent.MorphTimer.Enabled := True
else Parent.DrawSkinObject(Self);
end;
procedure TbsMenuBarObject.MouseDown(X, Y: Integer; Button: TMouseButton);
begin
end;
procedure TbsMenuBarObject.MouseUp(X, Y: Integer; Button: TMouseButton);
begin
end;
procedure TbsMenuBarObject.MouseEnter;
begin
FMouseIn := True;
Active := True;
ReDraw;
end;
procedure TbsMenuBarObject.MouseLeave;
begin
FMouseIn := False;
Active := False;
ReDraw;
end;
function TbsMenuBarObject.CanMorphing;
begin
Result := not (FDown and not IsNullRect(DownRect)) and
((Active and (MorphKf < 1)) or
(not Active and (MorphKf > 0)));
end;
procedure TbsMenuBarObject.DoMorphing;
begin
if Active
then MorphKf := MorphKf + MorphInc
else MorphKf := MorphKf - MorphInc;
Draw(Parent.Canvas);
end;
procedure TbsMenuBarObject.Draw;
begin
end;
procedure TbsMenuBarObject.SetMorphKf(Value: Double);
begin
FMorphKf := Value;
if FMorphKf < 0 then FMorphKf := 0 else
if FMorphKf > 1 then FMorphKf := 1;
end;
// ============== TbsSkinMainMenuBarButton ================ //
constructor TbsSkinMainMenuBarButton.Create;
begin
inherited Create(AParent, AData);
if AData <> nil
then
with TbsDataSkinMainMenuBarButton(AData) do
begin
Self.Command := Command;
Self.DownRect := DownRect;
FSkinSupport := True;
end
else
FSkinSupport := False;
end;
procedure TbsSkinMainMenuBarButton.DefaultDraw(Cnvs: TCanvas);
var
Buffer: TBitMap;
R: TRect;
IX, IY: Integer;
IC: TColor;
begin
Buffer := TBitMap.Create;
Buffer.Width := RectWidth(ObjectRect);
Buffer.Height := RectHeight(ObjectRect);
R := Rect(0, 0, Buffer.Width, Buffer.Height);
with Buffer.Canvas do
begin
if FDown and FMouseIn
then
begin
Frame3D(Buffer.Canvas, R, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
Brush.Color := BS_XP_BTNDOWNCOLOR;
FillRect(R);
end
else
if FMouseIn
then
begin
Frame3D(Buffer.Canvas, R, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
Brush.Color := BS_XP_BTNACTIVECOLOR;
FillRect(R);
end
else
begin
Brush.Color := clBtnFace;
FillRect(R);
end;
end;
IX := Buffer.Width div 2 - 5;
IY := Buffer.Height div 2 - 4;
if FDown and FMouseIn
then
begin
Inc(IX);
Inc(IY);
end;
if Enabled then IC := clBtnText else IC := clBtnShadow;
case Command of
cmClose: DrawCloseImage(Buffer.Canvas, IX, IY, IC);
cmMaximize: DrawRestoreImage(Buffer.Canvas, IX, IY, IC);
cmMinimize: DrawMinimizeImage(Buffer.Canvas, IX, IY, IC);
cmSysMenu: DrawSysMenuImage(Buffer.Canvas, IX, IY, IC);
end;
Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, Buffer);
Buffer.Free;
end;
procedure TbsSkinMainMenuBarButton.MouseEnter;
begin
if (Command = cmSysMenu) and FDown
then
begin
FMouseIn := True;
Active := True;
end
else
inherited;
end;
procedure TbsSkinMainMenuBarButton.MouseLeave;
begin
if (Command = cmSysMenu) and FDown
then
begin
if Morphing then FMorphKf := 1;
Active := False;
FMouseIn := False;
end
else
inherited;
end;
procedure TbsSkinMainMenuBarButton.Draw;
procedure CreateObjectImage(B: TBitMap; AActive: Boolean);
begin
B.Width := RectWidth(ObjectRect);
B.Height := RectHeight(ObjectRect);
with B.Canvas do
begin
if AActive
then
CopyRect(Rect(0, 0, B.Width, B.Height), Picture.Canvas, ActiveSkinRect)
else
CopyRect(Rect(0, 0, B.Width, B.Height), Picture.Canvas, SkinRect);
end;
end;
var
PBuffer, APBuffer: TbsEffectBmp;
Buffer, ABuffer: TBitMap;
ASR, SR: TRect;
begin
if not FSkinSupport or (Picture = nil)
then
begin
DefaultDraw(Cnvs);
Exit;
end;
if (FDown and not IsNullRect(DownRect)) and FMouseIn
then
Cnvs.CopyRect(ObjectRect, Picture.Canvas, DownRect)
else
begin
ASR := ActiveSkinRect;
SR := SkinRect;
if not Morphing or
((Active and (MorphKf = 1)) or (not Active and (MorphKf = 0)))
then
begin
if Active and not IsNullRect(ASR)
then
Cnvs.CopyRect(ObjectRect, Picture.Canvas, ASR)
else
Cnvs.CopyRect(ObjectRect, Picture.Canvas, SR);
end
else
begin
Buffer := TBitMap.Create;
ABuffer := TBitMap.Create;
CreateObjectImage(Buffer, False);
CreateObjectImage(ABuffer, True);
PBuffer := TbsEffectBmp.CreateFromhWnd(Buffer.Handle);
APBuffer := TbsEffectBmp.CreateFromhWnd(ABuffer.Handle);
case MorphKind of
mkDefault: PBuffer.Morph(APBuffer, MorphKf);
mkGradient: PBuffer.MorphGrad(APBuffer, MorphKf);
mkLeftGradient: PBuffer.MorphLeftGrad(APBuffer, MorphKf);
mkRightGradient: PBuffer.MorphRightGrad(APBuffer, MorphKf);
mkLeftSlide: PBuffer.MorphLeftSlide(APBuffer, MorphKf);
mkRightSlide: PBuffer.MorphRightSlide(APBuffer, MorphKf);
mkPush: PBuffer.MorphPush(APBuffer, MorphKf);
end;
PBuffer.Draw(Cnvs.Handle, ObjectRect.Left, ObjectRect.Top);
PBuffer.Free;
APBuffer.Free;
Buffer.Free;
ABuffer.Free;
end;
end;
end;
procedure TbsSkinMainMenuBarButton.DblClick;
var
DS: TbsBusinessSkinForm;
begin
DS := GetMDIChildBusinessSkinFormComponent;
if (DS <> nil) and (Command = cmSysMenu)
then
begin
Parent.BSF.SkinMenu.Hide;
Parent.BSF.SkinMenuClose;
DS.FForm.Close;
end;
end;
procedure TbsSkinMainMenuBarButton.DoCommand;
var
DS: TbsBusinessSkinForm;
MI: TMenuItem;
R: TRect;
P: TPoint;
begin
DS := GetMDIChildBusinessSkinFormComponent;
if DS <> nil
then
case Command of
cmClose: DS.FForm.Close;
cmMinimize: DS.WindowState := wsMinimized;
cmMaximize: DS.WindowState := wsNormal;
cmSysMenu:
begin
Parent.Repaint;
P := Point(ObjectRect.Left, ObjectRect.Top);
P := Parent.ClientToScreen(P);
R := Rect(P.X, P.Y, P.X + RectWidth(ObjectRect), P.Y + RectHeight(ObjectRect));
MI := DS.GetSystemMenu;
Parent.BSF.SkinMenuOpen;
if Parent.BSF.MenusSkinData = nil
then
Parent.BSF.SkinMenu.Popup(Parent, Parent.BSF.SkinData, 0, R, MI, Parent.PopupToUp)
else
Parent.BSF.SkinMenu.Popup(Parent, Parent.BSF.MenusSkinData, 0, R, MI, Parent.PopupToUp);
end;
end;
end;
procedure TbsSkinMainMenuBarButton.MouseDown;
begin
if not Enabled then Exit;
if (Button <> mbLeft)
then
begin
inherited MouseDown(X, Y, Button);
Exit;
end;
if not FDown
then
begin
FDown := True;
if Morphing and not IsNullRect(DownRect) then MorphKf := 1;
Parent.DrawSkinObject(Self);
if Command = cmSysMenu then DoCommand;
end;
end;
procedure TbsSkinMainMenuBarButton.MouseUp;
begin
if not Enabled then Exit;
if (Button <> mbLeft)
then
begin
inherited MouseUp(X, Y, Button);
Exit;
end;
inherited MouseUp(X, Y, Button);
if (Command <> cmSysMenu)
then
begin
FDown := False;
ReDraw;
end;
if Active and (Command <> cmSysMenu)
then DoCommand;
end;
// ==============TspSkinMainMenuBar =============//
constructor TbsSkinMainMenuBarItem.Create;
begin
inherited Create(AParent, AData);
if AData <> nil
then
begin
FSkinSupport := True;
with TbsDataSkinMainMenuBarItem(AData) do
begin
Self.FontName := FontName;
Self.FontHeight := FontHeight;
Self.FontStyle := FontStyle;
Self.FontColor := FontColor;
Self.ActiveFontColor := ActiveFontColor;
Self.DownFontColor := DownFontColor;
Self.TextRct := TextRct;
Self.DownRect := DownRect;
Self.LO := ItemLO;
Self.RO := ItemRO;
Self.UnEnabledFontColor := UnEnabledFontColor;
end;
if IsNullRect(DownRect) then
if IsNullRect(ActiveSkinRect)
then DownRect := SkinRect else DownRect := ActiveSkinRect;
if IsNullRect(ActiveSkinRect) then Morphing := False;
end
else
FSkinSupport := False;
OldEnabled := Enabled;
Visible := True;
end;
procedure TbsSkinMainMenuBarItem.SearchActive;
var
i: Integer;
begin
for i := 0 to Parent.ObjectList.Count - 1 do
if (TbsMenuBarObject(Parent.ObjectList.Items[i]) is TbsSkinMainMenuBarItem)
and (TbsSkinMainMenuBarItem(Parent.ObjectList.Items[i]).IDName <> IDName)
and (TbsSkinMainMenuBarItem(Parent.ObjectList.Items[i]).Active)
then
begin
TbsSkinMainMenuBarItem(Parent.ObjectList.Items[i]).MouseLeave;
Break;
end;
end;
function TbsSkinMainMenuBarItem.SearchDown;
var
i: Integer;
begin
Result := False;
for i := 0 to Parent.ObjectList.Count - 1 do
if (TbsMenuBarObject(Parent.ObjectList.Items[i]) is TbsSkinMainMenuBarItem)
and (TbsSkinMainMenuBarItem(Parent.ObjectList.Items[i]).IDName <> IDName)
and (TbsSkinMainMenuBarItem(Parent.ObjectList.Items[i]).FDown)
then
begin
TbsSkinMainMenuBarItem(Parent.ObjectList.Items[i]).SetDown(False);
Result := True;
Break;
end;
end;
procedure TbsSkinMainMenuBarItem.DefaultDraw;
function CalcObjectRect(Cnvs: TCanvas): TRect;
var
w, i, j: Integer;
R, TR: TRect;
begin
w := 2;
Cnvs.Font.Assign(Parent.DefItemFont);
if (Parent.SkinData <> nil) and (Parent.SkinData.ResourceStrData <> nil)
then
Cnvs.Font.CharSet := Parent.SkinData.ResourceStrData.CharSet;
TR := Rect(0, 0, 0, 0);
DrawText(Cnvs.Handle, PChar(MenuItem.Caption),
Length(MenuItem.Caption), TR, DT_CALCRECT or DT_CENTER);
w := w + RectWidth(TR) + 10;
R := Rect(0, 0, 0, 0);
j := Parent.ObjectList.IndexOf(Self);
for i := j - 1 downto 0 do
if TbsMenuBarObject(Parent.ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
begin
R.Left := TbsMenuBarObject(Parent.ObjectList.Items[i]).ObjectRect.Right;
Break;
end;
if R.Left = 0 then R.Left := Parent.NewItemsRect.Left;
R.Top := Parent.NewItemsRect.Top;
R.Right := R.Left + w;
R.Bottom := Parent.NewItemsRect.Bottom;
Result := R;
end;
var
Buffer: TBitMap;
R, R1: TRect;
TMO: Integer;
begin
Buffer := TBitMap.Create;
ObjectRect := CalcObjectRect(Buffer.Canvas);
if Parent.ScrollMenu
then
TMO := TRACKMARKEROFFSET
else
TMO := 0;
if ObjectRect.Right > Parent.NewItemsRect.Right - TMO
then
begin
Parent.Scroll := True;
if Visible
then
begin
OldEnabled := Enabled;
Enabled := False;
Visible := False;
end;
Buffer.Free;
Exit;
end
else
if not Visible
then
begin
Visible := True;
Enabled := OldEnabled;
end;
Buffer.Width := RectWidth(ObjectRect);
Buffer.Height := RectHeight(ObjectRect);
R := Rect(0, 0, Buffer.Width, Buffer.Height);
with Buffer.Canvas do
begin
if FDown
then
begin
Frame3D(Buffer.Canvas, R, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
Brush.Color := BS_XP_BTNDOWNCOLOR;
FillRect(R);
end
else
if FMouseIn
then
begin
Frame3D(Buffer.Canvas, R, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
Brush.Color := BS_XP_BTNACTIVECOLOR;
FillRect(R);
end
else
begin
Brush.Color := clBtnFace;
FillRect(R);
end;
end;
//
R1 := Rect(0, 0, 0, 0);
Buffer.Canvas.Font.Assign(Parent.DefItemFont);
if (Parent.SkinData <> nil) and (Parent.SkinData.ResourceStrData <> nil)
then
Buffer.Canvas.Font.CharSet := Parent.SkinData.ResourceStrData.CharSet;
DrawText(Buffer.Canvas.Handle, PChar(MenuItem.Caption),
Length(MenuItem.Caption), R1, DT_CALCRECT);
R.Top := R.Top + RectHeight(R) div 2 - R1.Bottom div 2;
R.Bottom := R.Top + R1.Bottom;
if FDown
then
begin
Inc(R.Left);
Inc(R.Top);
end;
DrawText(Buffer.Canvas.Handle, PChar(MenuItem.Caption),
Length(MenuItem.Caption), R, DT_CENTER or DT_VCENTER);
Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, Buffer);
Buffer.Free;
end;
procedure TbsSkinMainMenuBarItem.Draw;
function CalcObjectRect(Cnvs: TCanvas): TRect;
var
w, i, j: Integer;
R, TR: TRect;
begin
w := TextRct.Left + RectWidth(SkinRect) - TextRct.Right;
if Parent.FUseSkinFont
then
with Cnvs do
begin
Font.Name := FontName;
Font.Style := FontStyle;
Font.Height := FontHeight;
end
else
Cnvs.Font.Assign(Parent.DefItemFont);
if (Parent.SkinData <> nil) and (Parent.SkinData.ResourceStrData <> nil)
then
Cnvs.Font.CharSet := Parent.SkinData.ResourceStrData.Charset
else
Cnvs.Font.CharSet := Parent.DefItemFont.Charset;
TR := Rect(0, 0, 0, 0);
DrawText(Cnvs.Handle, PChar(MenuItem.Caption),
Length(MenuItem.Caption), TR, DT_CALCRECT or DT_CENTER);
w := w + RectWidth(TR) + 2;
R := Rect(0, 0, 0, 0);
j := Parent.ObjectList.IndexOf(Self);
for i := j - 1 downto 0 do
if TbsMenuBarObject(Parent.ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
begin
R.Left := TbsMenuBarObject(Parent.ObjectList.Items[i]).ObjectRect.Right;
Break;
end;
if R.Left = 0 then R.Left := Parent.NewItemsRect.Left;
R.Top := Parent.NewItemsRect.Top;
R.Right := R.Left + w;
R.Bottom := R.Top + RectHeight(SkinRect);
Result := R;
end;
procedure CreateItemImage(B: TBitMap; Rct: TRect; AActive: Boolean);
var
XO, w, XCnt: Integer;
TR: TRect;
X: Integer;
begin
if Picture = nil then Exit;
B.Width := RectWidth(ObjectRect);
B.Height := RectHeight(ObjectRect);
with B.Canvas do
begin
if LO <> 0 then
CopyRect(Rect(0, 0, LO, B.Height), Picture.Canvas,
Rect(Rct.Left, Rct.Top, Rct.Left + LO, Rct.Bottom));
if RO <> 0 then
CopyRect(Rect(B.Width - RO, 0, B.Width, B.Height),
Picture.Canvas,
Rect(Rct.Right - RO, Rct.Top, Rct.Right, Rct.Bottom));
Inc(Rct.Left, LO);
Dec(Rct.Right, RO);
w := RectWidth(Rct);
XCnt := (B.Width - LO - RO) div w;
for X := 0 to XCnt do
begin
if LO + X * w + w > B.Width - RO
then XO := LO + X * w + w - (B.Width - RO)
else XO := 0;
B.Canvas.CopyRect(Rect(LO + X * w, 0, LO + X * w + w - XO,
B.Height),
Picture.Canvas,
Rect(Rct.Left, Rct.Top, Rct.Right - XO, Rct.Bottom));
end;
Brush.Style := bsClear;
if Parent.UseSkinFont
then
begin
Font.Name := FontName;
Font.Style := FontStyle;
Font.Height := FontHeight;
end
else
Font.Assign(Parent.DefItemFont);
if (Parent.SkinData <> nil) and (Parent.SkinData.ResourceStrData <> nil)
then
Font.CharSet := Parent.SkinData.ResourceStrData.Charset
else
Font.CharSet := Parent.DefItemFont.Charset;
if FDown
then
Font.Color := DownFontColor
else
if AActive
then
Font.Color := ActiveFontColor
else
if Self.MenuItem.Enabled
then Font.Color := FontColor
else Font.Color := UnEnabledFontColor;
TR := TextRct;
DrawText(B.Canvas.Handle, PChar(MenuItem.Caption),
Length(MenuItem.Caption), TR, DT_CALCRECT);
Inc(TR.Right, 2);
DrawText(B.Canvas.Handle, PChar(MenuItem.Caption),
Length(MenuItem.Caption), TR, DT_CENTER or DT_VCENTER);
end;
end;
var
Buffer, ABuffer: TBitMap;
PBuffer, APBuffer: TbsEffectBmp;
TMO: Integer;
begin
if not FSkinSupport
then
begin
DefaultDraw(Cnvs);
Exit;
end;
if IsNullRect(SkinRect) or IsNullRect(TextRct) then Exit;
if Parent.ScrollMenu
then
TMO := TRACKMARKEROFFSET
else
TMO := 0;
Buffer := TBitMap.Create;
ObjectRect := CalcObjectRect(Buffer.Canvas);
if ObjectRect.Right > Parent.NewItemsRect.Right - TMO
then
begin
Parent.Scroll := True;
if Visible
then
begin
OldEnabled := Enabled;
Enabled := False;
Visible := False;
end;
Buffer.Free;
Exit;
end
else
if not Visible
then
begin
Visible := True;
Enabled := OldEnabled;
end;
if FDown
then
begin
CreateItemImage(Buffer, DownRect, True);
Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, Buffer);
end
else
if not Morphing or
((Active and (MorphKf = 1)) or (not Active and (MorphKf = 0)))
then
begin
if Active
then
begin
if isNullRect(ActiveSkinRect)
then
CreateItemImage(Buffer, SkinRect, True)
else
CreateItemImage(Buffer, ActiveSkinRect, True);
end
else CreateItemImage(Buffer, SkinRect, False);
Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, Buffer);
end
else
begin
CreateItemImage(Buffer, SkinRect, False);
ABuffer := TBitMap.Create;
CreateItemImage(ABuffer, ActiveSkinRect, True);
PBuffer := TbsEffectBmp.CreateFromhWnd(Buffer.Handle);
APBuffer := TbsEffectBmp.CreateFromhWnd(ABuffer.Handle);
case MorphKind of
mkDefault: PBuffer.Morph(APBuffer, MorphKf);
mkGradient: PBuffer.MorphGrad(APBuffer, MorphKf);
mkLeftGradient: PBuffer.MorphLeftGrad(APBuffer, MorphKf);
mkRightGradient: PBuffer.MorphRightGrad(APBuffer, MorphKf);
mkLeftSlide: PBuffer.MorphLeftSlide(APBuffer, MorphKf);
mkRightSlide: PBuffer.MorphRightSlide(APBuffer, MorphKf);
mkPush: PBuffer.MorphPush(APBuffer, MorphKf);
end;
PBuffer.Draw(Cnvs.Handle, ObjectRect.Left, ObjectRect.Top);
PBuffer.Free;
APBuffer.Free;
ABuffer.Free;
end;
Buffer.Free;
end;
procedure TbsSkinMainMenuBarItem.MouseEnter;
begin
if SearchDown
then
begin
Active := True;
FMouseIn := True;
if Morphing then MorphKf := 1;
SetDown(True);
end
else
begin
SearchActive;
FMouseIn := True;
Active := True;
ReDraw;
if Assigned(Parent.OnItemMouseEnter)
then
Parent.OnItemMouseEnter(Self.MenuItem);
end;
end;
procedure TbsSkinMainMenuBarItem.MouseLeave;
begin
Active := False;
FMouseIn := False;
if Morphing and FDown then MorphKf := 0;
Redraw;
if Assigned(Parent.OnItemMouseLeave)
then
Parent.OnItemMouseLeave(Self.MenuItem);
end;
procedure TbsSkinMainMenuBarItem.SetDown;
begin
FDown := Value;
if FDown
then
begin
FMorphKf := 1;
Parent.DrawSkinObject(Self);
if Parent.BSF <> nil
then
with Parent.BSF do
begin
if not InMainMenu
then
begin
if Assigned(OnMainMenuEnter) then OnMainMenuEnter(Parent);
end;
end;
TrackMenu;
end
else
begin
Active := False;
if Morphing
then
begin
FMorphKf := 1;
ReDraw;
end
else
Parent.DrawSkinObject(Self);
end;
end;
procedure TbsSkinMainMenuBarItem.TrackMenu;
var
R: TRect;
P: TPoint;
begin
P := Point(ObjectRect.Left, ObjectRect.Top);
P := Parent.ClientToScreen(P);
R := Rect(P.X, P.Y, P.X + RectWidth(ObjectRect), P.Y + RectHeight(ObjectRect));
if Parent.BSF <> nil
then
with Parent.BSF do
begin
SkinMenuOpen;
if not InMainMenu then InMainMenu := True;
SkinMenu.Popup(nil, Parent.SkinData, 0, R, MenuItem, Parent.PopupToUp);
end;
end;
procedure TbsSkinMainMenuBarItem.MouseDown;
var
Menu: TMenu;
begin
if not Enabled then Exit;
if Button = mbLeft
then
begin
if MenuItem.Count <> 0
then
begin
Parent.MenuActive := True;
SetDown(True);
end
else
begin
if Parent.BSF.InMainMenu
then
Parent.BSF.SkinMainMenuClose;
Parent.BSF.InMenu := False;
if Morphing then ReDraw else Parent.DrawSkinObject(Self);
Menu := MenuItem.GetParentMenu;
Menu.DispatchCommand(MenuItem.Command);
end;
end;
end;
constructor TbsSkinMainMenuBar.Create(AOwner: TComponent);
begin
inherited;
ChildMenuIn := False;
FScrollMenu := True;
FSkinSupport := False;
FUseSkinFont := True;
Align := alTop;
FDefaultHeight := 22;
Height := 22;
MouseTimer := TTimer.Create(Self);
MouseTimer.Enabled := False;
MouseTimer.OnTimer := TestMouse;
MouseTimer.Interval := MouseTimerInterval;
MorphTimer := TTimer.Create(Self);
MorphTimer.Enabled := False;
MorphTimer.OnTimer := TestMorph;
MorphTimer.Interval := MorphTimerInterval;
ObjectList := TList.Create;
OldActiveObject := -1;
ActiveObject := -1;
MouseCaptureObject := -1;
BSF := nil;
MarkerActive := False;
MenuActive := False;
FPopupToUp := False;
FMDIChildMax := False;
ButtonsCount := 0;
FDefItemFont := TFont.Create;
with FDefItemFont do
begin
Name := 'Arial';
Style := [];
Height := 14;
Color := clBtnText;
end;
FSkinDataName := 'mainmenubar';
end;
destructor TbsSkinMainMenuBar.Destroy;
begin
FDefItemFont.Free;
ClearObjects;
ObjectList.Free;
MouseTimer.Free;
MorphTimer.Free;
inherited;
end;
procedure TbsSkinMainMenuBar.TestMorph;
var
i: Integer;
StopMorph: Boolean;
begin
StopMorph := True;
for i := 0 to ObjectList.Count - 1 do
with TbsMenuBarObject(ObjectList.Items[i]) do
begin
if Morphing and CanMorphing
then
begin
DoMorphing;
StopMorph := False;
end;
end;
if StopMorph
then
MorphTimer.Enabled := False;
end;
procedure TbsSkinMainMenuBar.SetDefaultWidth;
begin
FDefaultWidth := Value;
if (FIndex = -1) and (FDefaultWidth > 0) then Width := FDefaultWidth;
end;
procedure TbsSkinMainMenuBar.SetDefaultHeight;
begin
FDefaultHeight := Value;
if (FIndex = -1) and (FDefaultHeight > 0) then Height := FDefaultHeight;
end;
procedure TbsSkinMainMenuBar.SetDefItemFont;
begin
FDefItemFont.Assign(Value);
if FIndex = -1 then RePaint;
end;
procedure TbsSkinMainMenuBar.WMCloseSkinMenu;
begin
CloseSysMenu;
end;
procedure TbsSkinMainMenuBar.CloseSysMenu;
var
i: Integer;
begin
for i := 0 to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarButton then
with TbsSkinMainMenuBarButton(ObjectList.Items[i]) do
if (Command = cmSysMenu) and FDown
then
begin
if ActiveObject <> i
then
begin
Active := False;
FMouseIn := False;
end;
FDown := False;
ReDraw;
end;
end;
procedure TbsSkinMainMenuBar.CheckButtons;
var
i: Integer;
begin
for i := 0 to ButtonsCount - 1 do
with TbsSkinMainMenuBarButton(ObjectList.Items[i]) do
begin
Enabled := True;
case Command of
cmMinimize: if not (biMinimize in BI) then Enabled := False;
cmSysMenu: if not (biSystemMenu in BI) then Enabled := False;
end;
end;
end;
procedure TbsSkinMainMenuBar.AddButtons;
procedure AddButton(ButtonName: String);
var
ButtonData: TbsDataSkinMainMenuBarButton;
Index: Integer;
begin
if (FSD = nil) or (FSD.Empty)
then
Index := -1
else
Index := FSD.GetIndex(ButtonName);
if Index <> -1
then
ButtonData := TbsDataSkinMainMenuBarButton(FSD.ObjectList.Items[Index])
else
ButtonData := nil;
ObjectList.Insert(0, TbsSkinMainMenuBarButton.Create(Self, ButtonData));
with TbsSkinMainMenuBarButton(ObjectList.Items[0]) do
begin
IDName := ButtonName;
end;
Inc(ButtonsCount);
end;
begin
ButtonsCount := 0;
if FIndex <> -1
then
begin
AddButton(MinButton);
AddButton(MaxButton);
AddButton(CloseButton);
AddButton(SysMenuButton);
end
else
begin
AddButton('MinButton');
TbsSkinMainMenuBarButton(ObjectList.Items[0]).Command := cmMinimize;
AddButton('MaxButton');
TbsSkinMainMenuBarButton(ObjectList.Items[0]).Command := cmMaximize;
AddButton('CloseButton');
TbsSkinMainMenuBarButton(ObjectList.Items[0]).Command := cmClose;
AddButton('SysMenuButton');
TbsSkinMainMenuBarButton(ObjectList.Items[0]).Command := cmSysMenu;
end;
end;
procedure TbsSkinMainMenuBar.DeleteButtons;
var
i: Integer;
begin
for i := 0 to ButtonsCount - 1 do
begin