Delphi控件源码

开发平台：

Delphi

BusinessSkinForm.pas：源码内容

{*******************************************************************}
{ }
{ Almediadev Visual Component Library }
{ BusinessSkinForm }
{ Version 1.98 }
{ }
{ }
{ 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;
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;
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;
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;
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;
TbsSkinMainMenuBar = class(TbsSkinControl)
protected
FDefItemFont: TFont;
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;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
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 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 Visible;
property Enabled;
property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnClick;
end;
TbsBusinessSkinForm = class(TComponent)
private
FIcon: TIcon;
FShowIcon: Boolean;
ButtonsInLeft: boolean;
FMaximizeOnFullScreen: Boolean;
FAlphaBlend: Boolean;
FAlphaBlendAnimation: Boolean;
FAlphaBlendValue: Byte;
FSkinHint: TbsSkinHint;
FShowObjectHint: 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;
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;
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 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);
protected
InMenu: Boolean;
InMainMenu: Boolean;
FRgn: HRGN;
MouseTimer: TTimer;
MorphTimer: 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 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 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
SkinMenu: TbsSkinMenu;
FForm: TForm;
ObjectList: TList;
procedure AddChildToMenu(Child: TCustomForm);
procedure DeleteChildFromMenu(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 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;
published
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 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 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;
end;
function GetBusinessSkinFormComponent(AForm: TForm): TbsBusinessSkinForm;
function GetMDIChildBusinessSkinFormComponent: TbsBusinessSkinForm;
function GetMDIChildBusinessSkinFormComponent2: TbsBusinessSkinForm;
implementation
Uses bsEffects;
const
WS_EX_LAYERED = $80000;
MouseTimerInterval = 50;
MorphTimerInterval = 20;
MorphInc = 0.1;
// 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';
MI_MINCAPTION = 'Mi&nimize';
MI_MAXCAPTION = 'Ma&ximize';
MI_CLOSECAPTION = '&Close';
MI_RESTORECAPTION = '&Restore';
MI_MINTOTRAYCAPTION = 'Minimize to &Tray';
MI_ROLLUPCAPTION = 'Ro&llUp';
WM_MDICHANGESIZE = WM_USER + 206;
WM_MDICHILDMAX = WM_USER + 207;
WM_MDICHILDRESTORE = WM_USER + 208;
function GetBusinessSkinFormComponent;
var
i: Integer;
begin
Result := nil;
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.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 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;
//============= 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
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 DrawRollUpImage(Buffer.Canvas, IX, IY, IC)
else DrawRestoreRollUpImage(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
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.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
cmClose: DoClose;
cmMinimize: 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;
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
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);
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;
begin
Buffer := TBitMap.Create;
ObjectRect := CalcObjectRect(Buffer.Canvas);
if ObjectRect.Right > Parent.NewItemsRect.Right - TRACKMARKEROFFSET
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);
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;
with Cnvs do
begin
Font.Name := FontName;
Font.Style := FontStyle;
Font.Height := FontHeight;
Font.CharSet := Parent.DefItemFont.Charset;
end;
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 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;
Font.Name := FontName;
Font.Style := FontStyle;
Font.Height := FontHeight;
Font.CharSet := Parent.DefItemFont.Charset;
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;
begin
if not FSkinSupport
then
begin
DefaultDraw(Cnvs);
Exit;
end;
if IsNullRect(SkinRect) or IsNullRect(TextRct) then Exit;
Buffer := TBitMap.Create;
ObjectRect := CalcObjectRect(Buffer.Canvas);
if ObjectRect.Right > Parent.NewItemsRect.Right - TRACKMARKEROFFSET
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;
end;
end;
procedure TbsSkinMainMenuBarItem.MouseLeave;
begin
Active := False;
FMouseIn := False;
if Morphing and FDown then MorphKf := 0;
Redraw;
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;
FSkinSupport := False;
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
ActiveObject := -1;
MouseCaptureObject := -1;
TbsMenuBarObject(ObjectList.Items[0]).Free;
ObjectList.Delete(0);
end;
ButtonsCount := 0;
end;
procedure TbsSkinMainMenuBar.MDIChildMaximize;
var
BS: TbsBusinessSkinForm;
begin
if not FMDIChildMax
then
begin
FMDIChildMax := True;
OldActiveObject := -1;
ActiveObject := -1;
MouseCaptureObject := -1;
AddButtons;
BS := GetMDIChildBusinessSkinFormComponent;
if BS <> nil then CheckButtons(BS.BorderIcons);
RePaint;
end;
end;
procedure TbsSkinMainMenuBar.MDIChildRestore;
var
BS: TbsBusinessSkinForm;
begin
BS := GetMDIChildBusinessSkinFormComponent;
if (BS = nil) and FMDIChildMax
then
begin
FMDIChildMax := False;
DeleteButtons;
RePaint;
end
else
if BS <> nil
then CheckButtons(BS.BorderIcons);
end;
function TbsSkinMainMenuBar.GetMarkerRect;
begin
Result := Rect(NewItemsRect.Right - TRACKMARKEROFFSET, NewItemsRect.Top,
NewItemsRect.Right, NewItemsRect.Bottom);
end;
procedure TbsSkinMainMenuBar.DrawMarker;
var
C: TColor;
begin
if FIndex <> -1
then
begin
if MarkerActive
then C := TrackMarkActiveColor
else C := TrackMarkColor;
end
else
begin
if MarkerActive
then C := clBtnText
else C := clBtnShadow;
end;
DrawArrowImage(Cnvs, GetMarkerRect, C, 2);
end;
procedure TbsSkinMainMenuBar.TrackScrollMenu;
var
i, VisibleCount: Integer;
R: TRect;
P: TPoint;
begin
if BSF = nil then Exit;
VisibleCount := 0;
for i := 0 to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if Visible then Inc(VisibleCount);
end;
P := Point(NewItemsRect.Right, NewItemsRect.Top);
P := ClientToScreen(P);
R := Rect(P.X - TRACKMARKEROFFSET, P.Y,
P.X, P.Y + RectHeight(NewItemsRect));
BSF.SkinMenuOpen;
BSF.SkinMenu.Popup(nil, FSD, VisibleCount, R, FMainMenu.Items, False);
end;
function TbsSkinMainMenuBar.FindHotKeyItem;
var
i: Integer;
begin
Result := False;
if BSF <> nil then
for i := 0 to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if Enabled and Visible and
IsAccel(CharCode, MenuItem.Caption)
then
begin
MouseEnter;
if (not BSF.InMenu) or (MenuItem.Count = 0) then MouseDown(0, 0, mbLeft);
Result := True;
Break;
end;
end
end;
procedure TbsSkinMainMenuBar.NextMainMenuItem;
function IsEndItem(Index: Integer): Boolean;
var
i: Integer;
begin
Result := True;
if Index + 1 > ObjectList.Count - 1
then
Result := True
else
for i := Index + 1 to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if Enabled and Visible then Result := False;
end
end;
var
i, j: Integer;
EndI: Boolean;
FirstItem: Integer;
begin
EndI := False;
FirstItem := -1;
j := -1;
for i := 0 to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if Enabled and Visible
then
begin
if FirstItem = -1 then FirstItem := i;
if (Active or FDown)
then
begin
j := i;
MouseLeave;
EndI := IsEndItem(j);
Break;
end;
end;
end;
if j = -1
then
begin
j := FirstItem;
if j <> -1 then
TbsSkinMainMenuBarItem(ObjectList.Items[j]).MouseEnter;
end
else
begin
if EndI then j := 0 else j := j + 1;
if j < ObjectList.Count then
for i := j to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if Enabled and Visible
then
begin
MouseEnter;
Break;
end;
end;
end;
end;
procedure TbsSkinMainMenuBar.PriorMainMenuItem;
function IsEndItem(Index: Integer): Boolean;
var
i: Integer;
begin
Result := True;
if Index - 1 < 0
then
Result := True
else
for i := Index - 1 downto 0 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if Enabled and Visible then Result := False;
end
end;
var
i, j: Integer;
EndI: Boolean;
LastItem: Integer;
begin
EndI := False;
j := -1;
LastItem := -1;
for i := ObjectList.Count - 1 downto 0 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if Enabled and Visible
then
begin
if LastItem = -1 then LastItem := i;
if Active or FDown then
begin
j := i;
MouseLeave;
EndI := IsEndItem(j);
Break;
end;
end;
end;
if j = -1
then
begin
j := LastItem;
if j <> -1 then
TbsSkinMainMenuBarItem(ObjectList.Items[j]).MouseEnter;
end
else
begin
if EndI then j := ObjectList.Count - 1 else j := j - 1;
if j > -1 then
for i := j downto 0 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if Enabled and Visible
then
begin
MouseEnter;
Break;
end;
end;
end;
end;
function TbsSkinMainMenuBar.CheckReturnKey;
var
i: Integer;
begin
Result := False;
if BSF <> nil then
for i := 0 to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if (FDown and (MenuItem.Count = 0)) or
(Active and not BSF.InMenu)
then
begin
Active := False;
MouseDown(0, 0, mbLeft);
Result := True;
Break;
end;
end;
end;
procedure TbsSkinMainMenuBar.MenuEnter;
var
i: Integer;
FirstItem: Integer;
begin
FirstItem := -1;
MenuActive := True;
for i := 0 to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem
then
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
begin
if FirstItem = -1 then FirstItem := i;
if Active
then
begin
FirstItem := i;
Break;
end;
end;
if FirstItem <> -1
then
begin
TbsSkinMainMenuBarItem(ObjectList.Items[FirstItem]).MouseEnter;
if BSF <> nil then
with BSF do
begin
HookApp;
InMainMenu := True;
if Assigned(OnMainMenuEnter) then OnMainMenuEnter(Self);
end;
end;
end;
procedure TbsSkinMainMenuBar.MenuClose;
var
i: Integer;
begin
for i := 0 to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem then
begin
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
if FDown then
begin
FDown := False;
Active := True;
DrawSkinObject(TbsSkinMainMenuBarItem(ObjectList.Items[i]));
Break;
end;
end;
end;
procedure TbsSkinMainMenuBar.MenuExit;
var
i: Integer;
begin
MenuActive := False;
for i := 0 to ObjectList.Count - 1 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarItem then
begin
with TbsSkinMainMenuBarItem(ObjectList.Items[i]) do
if FDown or Active then
begin
Active := False;
FMouseIn := False;
FDown := False;
ReDraw;
Break;
end;
end;
ActiveObject := -1;
OldActiveObject := -1;
end;
procedure TbsSkinMainMenuBar.CalcRects;
var
Off: Integer;
i: Integer;
begin
if FSkinSupport
then
begin
Off := RectWidth(SkinRect) - ItemsRect.Right;
NewItemsRect := Rect(ItemsRect.Left, ItemsRect.Top, Width - Off, ItemsRect.Bottom);
end
else
NewItemsRect := Rect(2, 2, Width - 2, Height - 2);
if FMDIChildMax and (ButtonsCount = 4)
then
begin
if TbsMenuBarObject(ObjectList.Items[0]) is TbsSkinMainMenuBarButton
then
with TbsSkinMainMenuBarButton((ObjectList.Items[0])) do
begin
if FSkinSupport
then
begin
ObjectRect := Rect(NewItemsRect.Left,
NewItemsRect.Top +
RectHeight(NewItemsRect) div 2 - RectHeight(SkinRect) div 2,
NewItemsRect.Left + RectWidth(SkinRect),
NewItemsRect.Top +
RectHeight(NewItemsRect) div 2 - RectHeight(SkinRect) div 2 +
RectHeight(SkinRect));
Inc(NewItemsRect.Left, RectWidth(SkinRect) + 2);
end
else
begin
ObjectRect := Rect(NewItemsRect.Left,
NewItemsRect.Top,
NewItemsRect.Left + RectHeight(NewItemsRect),
NewItemsRect.Bottom);
Inc(NewItemsRect.Left, RectHeight(NewItemsRect) + 2);
end;
end;
for i := 1 to 3 do
if TbsMenuBarObject(ObjectList.Items[i]) is TbsSkinMainMenuBarButton
then
with TbsSkinMainMenuBarButton((ObjectList.Items[i])) do
begin
if FSkinSupport
then
begin
ObjectRect := Rect(NewItemsRect.Right - RectWidth(SkinRect),
NewItemsRect.Top +
RectHeight(NewItemsRect) div 2 - RectHeight(SkinRect) div 2,
NewItemsRect.Right,
NewItemsRect.Top +
RectHeight(NewItemsRect) div 2 - RectHeight(SkinRect) div 2 +
RectHeight(SkinRect));
Dec(NewItemsRect.Right, RectWidth(SkinRect) + 2);
end
else
begin
ObjectRect := Rect(NewItemsRect.Right - RectHeight(NewItemsRect),
NewItemsRect.Top,
NewItemsRect.Right,
NewItemsRect.Bottom);
Dec(NewItemsRect.Right, RectHeight(NewItemsRect) + 2);
end;
end;
end;
end;
procedure TbsSkinMainMenuBar.DrawSkinObject;
begin
if AObject.Visible then AObject.Draw(Canvas);
end;
procedure TbsSkinMainMenuBar.GetSkinData;
begin
inherited;
if FIndex <> -1
then
if TbsDataSkinControl(FSD.CtrlList.Items[FIndex]) is TbsDataSkinMainMenuBar
then
with TbsDataSkinMainMenuBar(FSD.CtrlList.Items[FIndex]) do
begin
Self.SkinRect := SkinRect;
Self.ItemsRect := ItemsRect;
Self.MenuBarItem := MenuBarItem;
Self.CloseButton := CloseButton;
Self.MaxButton := MaxButton;
Self.MinButton := MinButton;
Self.SysMenuButton := SysMenuButton;
Self.TrackMarkColor := TrackMarkColor;
Self.TrackMarkActiveColor := TrackMarkActiveColor;
if (PictureIndex <> -1) and (PictureIndex < FSD.FActivePictures.Count)
then
Picture := TBitMap(FSD.FActivePictures.Items[PictureIndex])
else
Picture := nil;
end;
end;
procedure TbsSkinMainMenuBar.WMSize;
begin
inherited;
CalcRects;
end;
procedure TbsSkinMainMenuBar.CreateMenu;
var
i, j: Integer;
MMIData: TbsDataSkinMainMenuBarItem;
BS: TbsBusinessSkinForm;
begin
ClearObjects;
if (FMainMenu = nil) then Exit;
if (FSD = nil) or (FSD.Empty)
then
MMIData := nil
else
begin
j := FSD.GetIndex(MenuBarItem);
if j <> -1
then MMIData := TbsDataSkinMainMenuBarItem(FSD.ObjectList.Items[j])
else MMIData := nil;
end;
for i := 0 to FMainMenu.Items.Count - 1 do
if FMainMenu.Items[i].Visible
then
begin
ObjectList.Add(TbsSkinMainMenuBarItem.Create(Self, MMIData));
with TbsSkinMainMenuBarItem(ObjectList.Items[ObjectList.Count - 1]) do
begin
IDName := FMainMenu.Items[i].Name;
Enabled := FMainMenu.Items[i].Enabled;
MenuItem := FMainMenu.Items[i];
end;
end;
if Self.FMDIChildMax
then
begin
AddButtons;
BS := GetMDIChildBusinessSkinFormComponent;
if BS <> nil then CheckButtons(BS.BorderIcons);
end;
end;
procedure TbsSkinMainMenuBar.SetMainMenu;
begin
FMainMenu := Value;
CreateMenu;
RePaint;
end;
procedure TbsSkinMainMenuBar.UpDateItems;
begin
CreateMenu;
RePaint;
end;
procedure TbsSkinMainMenuBar.ClearObjects;
var
i: Integer;
begin
for i := 0 to ObjectList.Count - 1 do
TbsMenuBarObject(ObjectList.Items[i]).Free;
ObjectList.Clear;
ButtonsCount := 0;
end;
procedure TbsSkinMainMenuBar.CMMouseEnter;
begin
inherited;
if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
MouseTimer.Enabled := True;
end;
procedure TbsSkinMainMenuBar.CMMouseLeave;
begin
inherited;
if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
MouseTimer.Enabled := False;
TestActive(-1, -1);
end;
procedure TbsSkinMainMenuBar.MouseDown;
begin
inherited;
TestActive(X, Y);
if (ActiveObject <> - 1)
then
with TbsMenuBarObject(ObjectList.Items[ActiveObject]) do
begin
MouseCaptureObject := ActiveObject;
MouseDown(X, Y, Button);
if ssDouble in Shift then DblCLick;
end
else
if Scroll
then
begin
if PtInRect(GetMarkerRect, Point(X, Y)) then TrackScrollMenu;
end;
end;
procedure TbsSkinMainMenuBar.MouseUp;
begin
if (MouseCaptureObject <> -1)
then
begin
TbsMenuBarObject(ObjectList.Items[MouseCaptureObject]).MouseUp(X, Y, Button);
MouseCaptureObject := -1;
end;
inherited;
end;
procedure TbsSkinMainMenuBar.MouseMove;
begin
if not MouseTimer.Enabled
then MouseTimer.Enabled := True;
inherited;
end;
procedure TbsSkinMainMenuBar.BeforeChangeSkinData;
begin
FSkinSupport := False;
inherited;
ClearObjects;
end;
procedure TbsSkinMainMenuBar.ChangeSkinData;
begin
GetSkinData;
FSkinSupport := FIndex <> -1;
CreateMenu;
if FSkinSupport
then
Height := RectHeight(SkinRect)
else
if FDefaultHeight > 0 then Height := FDefaultHeight;
RePaint;
end;
procedure TbsSkinMainMenuBar.TestActive;
var
i: Integer;
B: Boolean;
begin
if (ObjectList.Count = 0) then Exit;
OldActiveObject := ActiveObject;
i := -1;
B := False;
repeat
Inc(i);
with TbsMenuBarObject(ObjectList.Items[i]) do
begin
if Enabled then B := PtInRect(ObjectRect, Point(X, Y));
end;
until B or (i = ObjectList.Count - 1);
if not B and (OldActiveObject <> -1) and MenuActive and
(TbsMenuBarObject(ObjectList.Items[OldActiveObject]) is
TbsSkinMainMenuBarItem)
then
ActiveObject := OldActiveObject
else
if B then ActiveObject := i else ActiveObject := -1;
if (MouseCaptureObject <> -1) and
(ActiveObject <> MouseCaptureObject) and (ActiveObject <> -1)
then
ActiveObject := -1;
if OldActiveObject >= ObjectList.Count then OldActiveObject := -1;
if ActiveObject >= ObjectList.Count then ActiveObject := -1;
if (OldActiveObject <> ActiveObject)
then
begin
if OldActiveObject <> - 1
then
if TbsMenuBarObject(ObjectList.Items[OldActiveObject]).Enabled
then TbsMenuBarObject(ObjectList.Items[OldActiveObject]).MouseLeave;
if ActiveObject <> -1
then
if TbsMenuBarObject(ObjectList.Items[ActiveObject]).Enabled
then TbsMenuBarObject(ObjectList.Items[ActiveObject]).MouseEnter;
end;
if Scroll
then
begin
if PtInRect(GetMarkerRect, Point(X, Y)) and not MarkerActive
then
begin
MarkerActive := True;
DrawMarker(Canvas);
end
else
if MarkerActive and not PtInRect(GetMarkerRect, Point(X, Y))
then
begin
MarkerActive := False;
DrawMarker(Canvas);
end;
end;
end;
procedure TbsSkinMainMenuBar.TestMouse;
var
P: TPoint;
begin
GetCursorPos(P);
P := ScreenToClient(P);
if (P.X >= 0) and (P.Y >= 0) and (P.X <= Width) and (P.Y <= Height)
then
TestActive(P.X, P.Y)
else
if MouseTimer.Enabled
then
begin
MouseTimer.Enabled := False;
TestActive(-1, -1);
end;
end;
procedure TbsSkinMainMenuBar.SetBounds;
begin
GetSkinData;
if FIndex <> -1 then AHeight := RectHeight(SkinRect);
inherited;
RePaint;
end;
procedure TbsSkinMainMenuBar.PaintMenuBar(Cnvs: TCanvas);
var
Buffer: TBitMap;
R: TRect;
i: Integer;
begin
GetSkinData;
Buffer := TBitMap.Create;
R := Rect(0, 0, Width, Height);
if FIndex <> -1
then
begin
CreateHSkinImage(ItemsRect.Left, RectWidth(SkinRect) - ItemsRect.Right,
Buffer, Picture, SkinRect, Width, Height);
end
else
begin
Buffer.Width := Width;
Buffer.Height := Height;
with Buffer.Canvas do
begin
Brush.Color := clBtnFace;
FillRect(R);
end;
end;
CalcRects;
Scroll := False;
for i := 0 to ObjectList.Count - 1 do
with TbsMenuBarObject(ObjectList.Items[i]) do
begin
if Visible then Draw(Buffer.Canvas);
end;
if Scroll then DrawMarker(Buffer.Canvas);
Cnvs.Draw(0, 0, Buffer);
Buffer.Free;
end;
procedure TbsSkinMainMenuBar.Paint;
begin
end;
procedure TbsSkinMainMenuBar.WMEraseBkgnd;
var
Cnvs: TCanvas;
begin
Cnvs := TCanvas.Create;
Cnvs.Handle := TWMEraseBkgnd(Message).DC;
PaintMenuBar(Cnvs);
Cnvs.Free;
Message.Result := 1;
end;
procedure TbsSkinMainMenuBar.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = FMainMenu)
then FMainMenu := nil;
if (Operation = opRemove) and (AComponent = BSF)
then BSF := nil;
end;
//============= TbsBusinessSkinForm =============//
type
TParentForm = class(TForm);
constructor TbsBusinessSkinForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FIcon := nil;
FShowIcon := False;
FMaximizeOnFullScreen := False;
FAlphaBlendAnimation := False;
FAlphaBlend := False;
FAlphaBlendValue := 200;
FSkinHint := nil;
FShowObjectHint := False;
FSkinSupport := False;
FDefCaptionFont := TFont.Create;
FDefInActiveCaptionFont := TFont.Create;
FMenusAlphaBlend := False;
FMenusAlphaBlendValue := 200;
FMenusAlphaBlendAnimation := False;
with FDefCaptionFont do
begin
Name := 'Arial';
Style := [fsBold];
Height := 14;
Color := clBtnText;
end;
with FDefInActiveCaptionFont do
begin
Name := 'Arial';
Style := [fsBold];
Height := 14;
Color := clBtnShadow;
end;
InMenu := False;
InMainMenu := False;
RMTop := TBitMap.Create;
RMLeft := TBitMap.Create;
RMBottom := TBitMap.Create;
RMRight := TBitMap.Create;
BlackColor := RGB(0, 0, 0);
ObjectList := TList.Create;
FSD := nil;
FMainMenu := nil;
FSystemMenu := nil;
FInChangeSkinData := False;
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;
OldBoundsRect := NulLRect;
OldActiveObject := -1;
ActiveObject := -1;
MouseCaptureObject := -1;
MouseIn := False;
FMinWidth := 0;
FMinHeight := 0;
FRGN := 0;
FClientInstance := nil;
FPrevClientProc := nil;
FForm := (Owner as TForm);
FForm.BorderIcons := [];
FForm.OnShortCut := FormShortCut;
FForm.AutoSize := False;
FForm.AutoScroll := False;
FSysMenu := TPopupMenu.Create(Self);
FUseDefaultSysMenu := True;
FSysTrayMenu := TbsSkinPopupMenu.Create(Self);
FSysTrayMenu.ComponentForm := FForm;
CreateSysTrayMenu;
SkinMenu := TbsSkinMenu.CreateEx(Self, FForm);
FMagneticSize := 5;
FBorderIcons := [biSystemMenu, biMinimize, biMaximize, biRollUp];
FFullDrag := False;
FSizeMove := False;
FFormWidth := 0;
FFormHeight := 0;
FMainMenuBar := nil;
FInShortCut := False;
if not (csDesigning in ComponentState)
then
begin
OldWindowProc := FForm.WindowProc;
FForm.WindowProc := NewWndProc;
TParentForm(FForm).ReCreateWnd;
SetWindowLong(FForm.Handle, GWL_STYLE,
GETWINDOWLONG(FForm.Handle, GWL_STYLE) and not WS_CAPTION);
end;
end;
destructor TbsBusinessSkinForm.Destroy;
begin
if not (csDesigning in ComponentState) and (FForm <> nil)
then
FForm.WindowProc := OldWindowProc;
FDefCaptionFont.Free;
FDefInActiveCaptionFont.Free;
FSysMenu.Free;
FSysTrayMenu.Free;
ClearObjects;
RMTop.Free;
RMLeft.Free;
RMBottom.Free;
RMRight.Free;
MouseTimer.Free;
MorphTimer.Free;
ObjectList.Free;
SkinMenu.Free;
if FRgn <> 0 then DeleteObject(FRgn);
if FIcon <> nil then FIcon.Free;
inherited Destroy;
end;
procedure TbsBusinessSkinForm.SetShowIcon(Value: Boolean);
begin
FShowIcon := Value;
if not (csDesigning in ComponentState) and
not (csLoading in ComponentState)
then
SendMessage(FForm.Handle, WM_NCPAINT, 0, 0);
end;
procedure TbsBusinessSkinForm.GetIcon;
var
IH: HICON;
IX, IY: Integer;
B: Boolean;
begin
if FIcon = nil
then
begin
FIcon := TIcon.Create;
B := False;
IH := 0;
if FForm.Icon.Handle <> 0
then
IH := FForm.Icon.Handle
else
if Application.Icon.Handle <> 0
then
IH := Application.Icon.Handle
else
begin
IH := LoadIcon(0, IDI_APPLICATION);
B := True;
end;
GetIconSize(IX, IY);
FIcon.Handle := CopyImage(IH, IMAGE_ICON, IX, IY, LR_COPYFROMRESOURCE);
if B then DestroyIcon(IH);
end;
end;
procedure TbsBusinessSkinForm.DrawFormIcon(Cnvs: TCanvas; X, Y: Integer);
begin
GetIcon;
if FIcon <> nil then
DrawIconEx(Cnvs.Handle, X, Y, FIcon.Handle, 0, 0, 0, 0, DI_NORMAL);
end;
procedure TbsBusinessSkinForm.GetIconSize(var X, Y: Integer);
begin
X := GetSystemMetrics(SM_CXSMICON);
if X = 0 then X := GetSystemMetrics(SM_CXSIZE);
Y := GetSystemMetrics(SM_CYSMICON);
if Y = 0 then Y := GetSystemMetrics(SM_CYSIZE);
end;
procedure TbsBusinessSkinForm.MDIItemClick(Sender: TObject);
var
I: Integer;
S1, S2: String;
MainBSF, ChildBSF: TbsBusinessSkinForm;
begin
MainBSF := GetBusinessSkinFormComponent(Application.MainForm);
if MainBSF = nil then Exit;
S1 := TMenuItem(Sender).Name;
S2 := MI_CHILDITEM;
Delete(S1, Pos(S2, S1), Length(S2));
for I := 0 to MainBSF.FForm.MDIChildCount - 1 do
if MainBSF.FForm.MDIChildren[I].Name = S1
then
begin
ChildBSF := GetBusinessSkinFormComponent(MainBSF.FForm.MDIChildren[I]);
if (ChildBSF <> nil) and (ChildBSF.WindowState = wsMinimized)
then
ChildBSF.WindowState := wsNormal;
MainBSF.FForm.MDIChildren[I].Show;
end;
end;
procedure TbsBusinessSkinForm.UpDateChildCaptionInMenu(Child: TCustomForm);
var
WM: TMenuItem;
MainBSF: TbsBusinessSkinForm;
I: Integer;
S1, S2: String;
begin
MainBSF := BusinessSkinForm.GetBusinessSkinFormComponent(Application.MainForm);
if MainBSF = nil then Exit;
WM := MainBSF.FForm.WindowMenu;
if WM = nil then Exit;
for I := 0 to WM.Count - 1 do
if (Pos(MI_CHILDITEM, WM.Items[I].Name) <> 0) and
(Pos('DIVIDER', WM.Items[I].Name) = 0)
then
begin
S1 := WM.Items[I].Name;
S2 := MI_CHILDITEM;
Delete(S1, Pos(S2, S1), Length(S2));
if Child.Name = S1
then
begin
WM.Items[I].Caption := Child.Caption;
Break;
end;
end;
end;
procedure TbsBusinessSkinForm.UpDateChildActiveInMenu;
var
WM: TMenuItem;
MainBSF: TbsBusinessSkinForm;
I: Integer;
S1, S2: String;
begin
MainBSF := BusinessSkinForm.GetBusinessSkinFormComponent(Application.MainForm);
if MainBSF = nil then Exit;
WM := MainBSF.FForm.WindowMenu;
if WM = nil then Exit;
for I := 0 to WM.Count - 1 do
if (Pos(MI_CHILDITEM, WM.Items[I].Name) <> 0) and
(Pos('DIVIDER', WM.Items[I].Name) = 0)
then
begin
S1 := WM.Items[I].Name;
S2 := MI_CHILDITEM;
Delete(S1, Pos(S2, S1), Length(S2));
if MainBSF.FForm.ActiveMDIChild.Name = S1
then
WM.Items[I].Checked := True
else
WM.Items[I].Checked := False;
end;
end;
procedure TbsBusinessSkinForm.AddChildToMenu;
var
WM: TMenuItem;
NewItem, DividerItem: TMenuItem;
MainBSF: TbsBusinessSkinForm;
begin
MainBSF := BusinessSkinForm.GetBusinessSkinFormComponent(Application.MainForm);
if MainBSF = nil then Exit;
WM := MainBSF.FForm.WindowMenu;
if WM = nil then Exit;
if MainBSF.FForm.MDIChildCount = 1
then
begin
DividerItem := TMenuItem.Create(Self);
DividerItem.Caption := '-';
DividerItem.Name := 'DIVIDER' + MI_CHILDITEM;
WM.Add(DividerItem);
end;
NewItem := TMenuItem.Create(Self);
NewItem.Name := Child.Name + MI_CHILDITEM;
NewItem.Caption := Child.Caption;
NewItem.OnClick := MDIItemClick;
WM.Add(NewItem);
end;
procedure TbsBusinessSkinForm.DeleteChildFromMenu;
var
WM, MI: TMenuItem;
MainBSF: TbsBusinessSkinForm;
I: Integer;
S1, S2: String;
begin
MainBSF := BusinessSkinForm.GetBusinessSkinFormComponent(Application.MainForm);
if MainBSF = nil then Exit;
WM := MainBSF.FForm.WindowMenu;
if WM = nil then Exit;
for I := 0 to WM.Count - 1 do
if (Pos(MI_CHILDITEM, WM.Items[I].Name) <> 0) and
(Pos('DIVIDER', WM.Items[I].Name) = 0)
then
begin
S1 := WM.Items[I].Name;
S2 := MI_CHILDITEM;
Delete(S1, Pos(S2, S1), Length(S2));
if Child.Name = S1
then
begin
MI := WM.Items[I];
WM.Delete(I);
MI.Free;
Break;
end;
end;
if MainBSF.FForm.MDIChildCount = 0
then
for I := 0 to WM.Count - 1 do
if (Pos(MI_CHILDITEM, WM.Items[I].Name) <> 0) and
(Pos('DIVIDER', WM.Items[I].Name) <> 0)
then
begin
MI := WM.Items[I];
WM.Delete(I);
MI.Free;
Break;
end;
end;
procedure TbsBusinessSkinForm.SetAlphaBlend(Value: Boolean);
begin
if FAlphaBlend <> Value
then
begin
FAlphaBlend := Value;
if (ComponentState = []) and CheckW2KWXP
then
begin
if FAlphaBlend
then
begin
SetWindowLong(FForm.Handle, GWL_EXSTYLE,
GetWindowLong(FForm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
SetAlphaBlendTransparent(FForm.Handle, FAlphaBlendValue);
end
else
SetWindowLong(FForm.Handle, GWL_EXSTYLE,
GetWindowLong(FForm.Handle, GWL_EXSTYLE) and not WS_EX_LAYERED);
end;
end;
end;
procedure TbsBusinessSkinForm.SetAlphaBlendValue(Value: Byte);
begin
if FAlphaBlendValue <> Value
then
begin
FAlphaBlendValue := Value;
if FAlphaBlend and (ComponentState = []) and CheckW2KWXP
then
SetAlphaBlendTransparent(FForm.Handle, FAlphaBlendValue);
end;
end;
procedure TbsBusinessSkinForm.TrackSystemMenu(X, Y: Integer);
var
MenuItem: TMenuItem;
begin
MenuItem := GetSystemMenu;
SkinMenuOpen;
if MenusSkinData = nil
then
SkinMenu.Popup(nil, SkinData, 0, Rect(X, Y, X, Y), MenuItem, False)
else
SkinMenu.Popup(nil, MenusSkinData, 0, Rect(X, Y, X, Y), MenuItem, False);
end;
function TbsBusinessSkinForm.GetAutoRenderingInActiveImage: Boolean;
begin
if (FSD <> nil) and not (FSD.Empty)
then Result := FSD.AutoRenderingInActiveImage
else Result := False;
end;
procedure TbsBusinessSkinForm.UpDateActiveObjects;
var
i: Integer;
begin
if ObjectList <> nil
then
for i := 0 to ObjectList.Count - 1 do
if not (TbsActiveSkinObject(ObjectList.Items[i]) is TbsSkinCaptionObject)
then
with TbsActiveSkinObject(ObjectList.Items[i]) do
begin
Active := False;
MouseIn := False;
FMorphkf := 0;
end;
end;
procedure TbsBusinessSkinForm.TestMorph;
var
i: Integer;
StopMorph: Boolean;
begin
StopMorph := True;
for i := 0 to ObjectList.Count - 1 do
with TbsActiveSkinObject(ObjectList.Items[i]) do
begin
if Morphing and CanMorphing
then
begin
DoMorphing;
StopMorph := False;
end;
end;
if StopMorph then MorphTimer.Enabled := False;
end;
procedure TbsBusinessSkinForm.SetMenusAlphaBlend(Value: Boolean);
begin
FMenusAlphaBlend := Value;
if SkinMenu <> nil then SkinMenu.AlphaBlend := Value;
end;
procedure TbsBusinessSkinForm.SetMenusAlphaBlendAnimation(Value: Boolean);
begin
FMenusAlphaBlendAnimation := Value;
if SkinMenu <> nil then SkinMenu.AlphaBlendAnimation := Value;
end;
procedure TbsBusinessSkinForm.SetMenusAlphaBlendValue(Value: Byte);
begin
FMenusAlphaBlendValue := Value;
if SkinMenu <> nil then SkinMenu.AlphaBlendValue := Value;
end;
function TbsBusinessSkinForm.IsSizeAble;
begin
Result := (FForm.BorderStyle = bsSizeAble) or
(FForm.BorderStyle = bsSizeToolWin);
end;
function TbsBusinessSkinForm.GetDefCaptionHeight: Integer;