{ Copyright (C) 2010 Felipe Monteiro de Carvalho License: The same modifying LGPL with static linking exception as the LCL This unit should be a repository for various custom drawn components, such as a custom drawn version of TButton, of TEdit, of TPageControl, etc, eventually forming a full set of custom drawn components. } unit customdrawnextras; {$mode objfpc}{$H+} interface uses Classes, SysUtils, Graphics, Controls, LCLType, LCLIntf, IntfGraphics, Math, types, customdrawnutils, contnrs, componenteditors, LMessages, Messages, LCLProc, PropEdits, ExtCtrls, ImgList, Forms, Menus, // fpimage fpcanvas, fpimgcanv, fpimage {$ifdef CUSTOMDRAWN_USE_FREETYPE} // font support , ftfont {$endif} ; type // commented items are not yet supported TBitmappedButtonOption = (bboUseImageForSelection {bboUseImageForMouseOver, bboDrawFocusRectangle,} (*bboCheckable,*)); TBitmappedButtonOptions = set of TBitmappedButtonOption; // commented items are not yet supported TBitmappedButtonState = (bbsNormal, bbsDown, bbsMouseOver, bbsFocused (* bbsChecked, bbsCheckedSelected, bbsCheckedDown { is going to be unchecked }*)); TCDDrawStyle = ( // Operating system styles dsWinCE, dsWin2000, dsAndroid, dsXPTaskBar, // Other special styles dsGrad, // Defined by the user dsCustom); { TCustomBitmappedButton } TCustomBitmappedButton = class(TCustomControl) private FOnChange: TNotifyEvent; BmpBuffer: TBitmap; StrBuffer: TStringList; protected FImageBtn: TPicture; FImageBtnDown: TPicture; FImageBtnMouseOver: TPicture; FImageBtnFocused: TPicture; FImageBtnChecked: TPicture; FOptions: TBitmappedButtonOptions; FState: TBitmappedButtonState; // keyboard procedure DoEnter; override; procedure DoExit; override; procedure KeyDown(var Key: word; Shift: TShiftState); override; procedure KeyUp(var Key: word; Shift: TShiftState); override; // mouse procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; procedure MouseEnter; override; procedure MouseLeave; override; // button state change procedure DoButtonDown(); procedure DoButtonUp(); // inherited procedure RealSetText(const Value: TCaption); override; protected // Properties property ImageBtn: TPicture read FImageBtn; property ImageBtnDown: TPicture read FImageBtnDown; property ImageBtnFocused: TPicture read FImageBtnFocused; property Options: TBitmappedButtonOptions read FOptions write FOptions; // Events property OnChange: TNotifyEvent read FOnChange write FOnChange; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EraseBackground(DC: HDC); override; procedure Paint; override; function GetStateBitmap(): TBitmap; end; {@@ TBitmappedButton is a simple custom drawn button which bases it's drawing on provided raster images. Currently the following states are supported: normal, down and focused. The Caption of this button may have multiple lines of text, separated by any line separator. The text is drawn centralized in the button. Some work was done trying to achieve alpha blending for the button, but this wasn't successfull. It would work like this: The button may be drawn flat or alpha blended using a separate image for the Alpha channel. While pixels in the alpha channel will result in the button pixel being fully drawn, while black pixels represent pixels which aren't drawn. grey pixels are alpha blended. } TBitmappedButton = class(TCustomBitmappedButton) published // LCL properties and events property Action; property Anchors; property AnchorSide; // property BidiMode; // property BorderSpacing; // property Cancel; property Caption; property Constraints; // property Default; // property DragCursor; // property DragKind; // property DragMode; property Enabled; property Font; // property ParentBidiMode; // property ModalResult; property OnChangeBounds; property OnClick; property OnContextPopup; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnResize; property OnStartDrag; property OnUTF8KeyPress; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property TabStop; property Visible; // Specific properties property ImageBtn; property ImageBtnDown; property ImageBtnFocused; property Options; end; TCDControlDrawer = class; { TCDControl } TCDControl = class(TCustomControl) protected FDrawStyle: TCDDrawStyle; FCurrentDrawer: TCDControlDrawer; //constructor Create(AOwner: TComponent); override; //destructor Destroy; override; procedure PrepareCurrentDrawer(); virtual; procedure SetDrawStyle(const AValue: TCDDrawStyle); function GetClientRect: TRect; override; procedure EraseBackground(DC: HDC); override; public end; TCDControlDrawer = class public function GetClientRect(AControl: TCDControl): TRect; virtual; abstract; //procedure DrawToIntfImage(ADest: TFPImageCanvas; AControl: TCDControl); // virtual; abstract; //procedure DrawToCanvas(ADest: TCanvas; AControl: TCDControl); virtual; abstract; end; TCDButtonDrawer = class; TCDButtonDrawerWinCE = class; TCDButtonDrawerAndroid = class; TCDButtonDrawerXPTB = class; TCDButtonDrawerGrad = class; TCDButtonDrawerWin2k = class; { TCDButton } TCDButton = class(TCDControl) private //FCurrentDrawer: TCDButtonDrawer; FDrawerWinCE: TCDButtonDrawerWinCE; FDrawerAndroid: TCDButtonDrawerAndroid; FDrawerXPTB: TCDButtonDrawerXPTB; FDrawerGrad: TCDButtonDrawerGrad; FDrawerWin2k: TCDButtonDrawerWin2k; procedure PrepareCurrentDrawer(); override; protected FState: TBitmappedButtonState; // keyboard procedure DoEnter; override; procedure DoExit; override; procedure KeyDown(var Key: word; Shift: TShiftState); override; procedure KeyUp(var Key: word; Shift: TShiftState); override; // mouse procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; procedure MouseEnter; override; procedure MouseLeave; override; // button state change procedure DoButtonDown(); procedure DoButtonUp(); procedure RealSetText(const Value: TCaption); override; public CustomDrawer: TCDButtonDrawer; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; published property Action; property Anchors; property Caption; property Color; property Constraints; property DrawStyle: TCDDrawStyle read FDrawStyle write SetDrawStyle; property Enabled; property Font; property OnChangeBounds; property OnClick; property OnContextPopup; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnResize; property OnStartDrag; property OnUTF8KeyPress; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property TabStop; property Visible; end; { TCDButtonDrawer } TCDButtonDrawer = class(TCDControlDrawer) public function GetClientRect(AControl: TCDControl): TRect; override; procedure DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); virtual; abstract; procedure DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); virtual; abstract; end; { TCDButtonDrawerWinCE } TCDButtonDrawerWinCE = class(TCDButtonDrawer) public procedure DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); override; procedure DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); override; end; { TCDButtonDrawerAndroid } TCDButtonDrawerAndroid = class(TCDButtonDrawer) public procedure DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); override; procedure DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); override; end; TCDButtonDrawerXPTB = class(TCDButtonDrawer) public procedure DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); override; procedure DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); override; end; TCDButtonDrawerGrad = class(TCDButtonDrawer) public procedure DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); override; procedure DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); override; end; TCDButtonDrawerWin2k = class(TCDButtonDrawer) public procedure DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); override; procedure DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); override; end; {@@ TCDGroupBox is a custom-drawn group box control } TCDGroupBoxDrawer = class; TCDGroupBoxDrawerWinCE = class; { TCDGroupBox } TCDGroupBox = class(TCustomControl) private FDrawStyle: TCDDrawStyle; FCurrentDrawer: TCDGroupBoxDrawer; FDrawerWinCE: TCDGroupBoxDrawerWinCE; procedure PrepareCurrentDrawer(); procedure SetDrawStyle(const AValue: TCDDrawStyle); public CustomDrawer: TCDGroupBoxDrawer; // Fill the field to use the dsCustom draw mode constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EraseBackground(DC: HDC); override; procedure Paint; override; published property DrawStyle: TCDDrawStyle read FDrawStyle write SetDrawStyle; property Caption; property TabStop default False; end; { TCDGroupBoxDrawer } TCDGroupBoxDrawer = class public procedure SetClientRectPos(CDGroupBox: TCDGroupBox); virtual; abstract; procedure DrawToIntfImage(ADest: TFPImageCanvas; CDGroupBox: TCDGroupBox); virtual; abstract; procedure DrawToCanvas(ADest: TCanvas; CDGroupBox: TCDGroupBox); virtual; abstract; end; { TCDGroupBoxDrawerWinCE } TCDGroupBoxDrawerWinCE = class(TCDGroupBoxDrawer) public FCaptionMiddle: integer; procedure SetClientRectPos(CDGroupBox: TCDGroupBox); override; procedure DrawToIntfImage(ADest: TFPImageCanvas; CDGroupBox: TCDGroupBox); override; procedure DrawToCanvas(ADest: TCanvas; CDGroupBox: TCDGroupBox); override; end; {@@ TCDTrackBar is a custom-drawn trackbar control } TCDTrackBarDrawer = class; { TCDTrackBar } TCDTrackBar = class(TCustomControl) private DragDropStarted: boolean; // fields FMin: integer; FMax: integer; FPosition: integer; FOnChange: TNotifyEvent; FCurrentDrawer: TCDTrackBarDrawer; procedure SetMax(Value: integer); procedure SetMin(Value: integer); procedure SetPosition(Value: integer); // function GetPositionFromMousePos(X, Y: Integer): integer; protected procedure Changed; virtual; // keyboard procedure DoEnter; override; procedure DoExit; override; procedure KeyDown(var Key: word; Shift: TShiftState); override; procedure KeyUp(var Key: word; Shift: TShiftState); override; // mouse procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; procedure MouseMove(Shift: TShiftState; X, Y: integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; procedure MouseEnter; override; procedure MouseLeave; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EraseBackground(DC: HDC); override; procedure Paint; override; published property Color; property Max: integer read FMax write SetMax default 10; property Min: integer read FMin write SetMin default 0; property OnChange: TNotifyEvent read FOnChange write FOnChange; property Position: integer read FPosition write SetPosition; property TabStop default True; end; { TCDTrackBarDrawer } TCDTrackBarDrawer = class public procedure DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage; CDTrackBar: TCDTrackBar); virtual; abstract; procedure GetGeometry(var ALeftBorder, ARightBorder: Integer); virtual; abstract; end; { TCDTrackBarDrawerGraph } TCDTrackBarDrawerGraph = class(TCDTrackBarDrawer) public procedure DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage; CDTrackBar: TCDTrackBar); override; procedure GetGeometry(var ALeftBorder, ARightBorder: Integer); override; end; {TCDTabControl} { TCDCustomTabControl } TCDCustomTabControl = class; TCDCustomTabControlDrawer = class; TCDCustomTabControlDrawerWinCE = class; TCDCustomTabSheet = class(TCustomControl) private FIndex: integer; CDTabControl: TCDCustomTabControl; end; TCDCustomTabControl = class(TCDControl) private FTabIndex: Integer; FTabs: TStringList; FDrawerWinCE: TCDCustomTabControlDrawerWinCE; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; //procedure MouseMove(Shift: TShiftState; X, Y: integer); override; //procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; //procedure MouseEnter; override; //procedure MouseLeave; override; procedure PrepareCurrentDrawer(); override; procedure SetTabIndex(AValue: Integer); virtual; protected constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; public CustomDrawer: TCDCustomTabControlDrawer; // Fill the field to use the dsCustom draw mode property Tabs: TStringList read FTabs; end; { TCDCustomTabControlDrawer } TCDCustomTabControlDrawer = class(TCDControlDrawer) public CDTabControl: TCDCustomTabControl; function GetPageIndexFromXY(x, y: integer): integer; virtual; abstract; function GetTabHeight(AIndex: Integer): Integer; virtual; abstract; function GetTabWidth(ADest: TCanvas; AIndex: Integer): Integer; virtual; abstract; procedure DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage); virtual; abstract; procedure DrawToCanvas(ADest: TCanvas); virtual; abstract; procedure DrawTabSheet(ADest: TCanvas); virtual; abstract; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); virtual; abstract; end; { TCDCustomTabControlDrawerWinCE } TCDCustomTabControlDrawerWinCE = class(TCDCustomTabControlDrawer) private StartIndex: integer; //FEndIndex LeftmostTabVisibleIndex: Integer; procedure DrawCaptionBar(ADest: TCanvas; lRect: TRect; CL: TColor); procedure DrawTabs(ADest: TCanvas); procedure DrawTab(ADest: TCanvas; AIndex: Integer; ACurStartLeftPos: Integer); public function GetPageIndexFromXY(x, y: integer): integer; override; function GetTabHeight(AIndex: Integer): Integer; override; function GetTabWidth(ADest: TCanvas; AIndex: Integer): Integer; override; function GetClientRect(AControl: TCDControl): TRect; override; procedure DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage); override; procedure DrawToCanvas(ADest: TCanvas); override; procedure DrawTabSheet(ADest: TCanvas); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; end; TCDTabSheet = class; TTabItem = class(TCollectionItem) private FTitle: string; FSelected: boolean; FData: TObject; FModified: boolean; FImageIndex: TImageIndex; FWidth: integer; FTabPage: TCDTabSheet; procedure SetSelected(Value: boolean); procedure SetModified(Value: boolean); procedure DoChange; procedure SetTitle(Value: string); procedure SetImageIndex(Value: TImageIndex); protected FStartPos: integer; FSize: integer; function GetDisplayName: string; override; public constructor Create(aCollection: TCollection); override; destructor Destroy; override; property Data: TObject read FData write FData; published property Width: integer read FWidth write FWidth; property Title: string read FTitle write SetTitle; property Selected: boolean read FSelected write SetSelected; property Modified: boolean read Fmodified write SetModified; property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1; property TabPage: TCDTabSheet read FTabPage write FTabPage; end; TTabItemList = class(TCollection) protected procedure DoSelected(ATab: TTabItem; ASelected: boolean); dynamic; procedure DoChanged(ATab: TTabItem); dynamic; procedure SetItem(Index: integer; Value: TTabItem); function GetItem(Index: integer): TTabItem; public function IndexOf(ATab: TTabItem): integer; function Add: TTabItem; property Items[Index: integer]: TTabItem read GetItem write SetItem; default; end; TTabSelectedEvent = procedure(Sender: TObject; ATab: TTabItem; ASelected: boolean) of object; TCDTabControl = class(TCDCustomTabControl) published property Color; property Font; property TabIndex: integer read FTabIndex write SetTabIndex; property Tabs: TStringList read FTabs; // property OnTabSelected: TTabSelectedEvent read fOnTabSelected write fOnTabSelected; end; { TCDTabSheet } TCDPageControl = class; TCDTabSheet = class(TCustomControl) private FIndex: integer; public StoredWidth: Integer; CDPageControl: TCDPageControl; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EraseBackground(DC: HDC); override; procedure Paint; override; published property Caption; property Color; property Font; property Index: integer read FIndex write FIndex; end; { TCDPageControl } TCDPageControlDrawer = class; TCDPageControlDrawerWinCE = class; { TCDPageControlEditor } TCDPageControlEditor = class(TDefaultComponentEditor) procedure ShowPageMenuItemClick(Sender: TObject); public procedure ExecuteVerb(Index: integer); override; function GetVerb(Index: integer): string; override; function GetVerbCount: integer; override; procedure PrepareItem(Index: integer; const AnItem: TMenuItem); override; procedure AddMenuItemsForPages(ParentMenuItem: TMenuItem); virtual; function PControl: TCDPageControl; virtual; end; TCDPageControl = class(TCDControl) private FActivePage: TCDTabSheet; //FCurrentDrawer: TCDPageControlDrawer; FDrawerWinCE: TCDPageControlDrawerWinCE; FPages: TTabItemList; FMDownL, FMDownR: boolean; FMEnterL, FMEnterR: boolean; FPageIndex: integer; //FPageCount function GetPageCount: integer; procedure SetDrawStyle(AValue: TCDDrawStyle); procedure SetMouseUP; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; //procedure MouseMove(Shift: TShiftState; X, Y: integer); override; //procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; //procedure MouseEnter; override; //procedure MouseLeave; override; procedure PrepareCurrentDrawer(); override; procedure SetActivePage(Value: TCDTabSheet); procedure SetPageIndex(Value: integer); procedure UpdateAllDesignerFlags; procedure UpdateDesignerFlags(APageIndex: integer); procedure PositionTabSheet(ATabSheet: TCDTabSheet); protected constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; function FindNextPage(CurPage: TCDTabSheet; GoForward, CheckTabVisible: boolean): TCDTabSheet; procedure SelectNextPage(GoForward: boolean; CheckTabVisible: boolean = True); procedure SetCDPages(Value: TTabItemList); public CustomDrawer: TCDPageControlDrawer; // Fill the field to use the dsCustom draw mode procedure InsertPage(aIndex: integer; S: string); procedure RemovePage(aIndex: integer); procedure AddPage(S: string); function GetPage(aIndex: integer): TCDTabSheet; published property ActivePage: TCDTabSheet read FActivePage write SetActivePage; property DrawStyle: TCDDrawStyle read FDrawStyle write SetDrawStyle; property Caption; property Color; property Font; //property PageCount: integer read FPageCount; property PageIndex: integer read FPageIndex write SetPageIndex; property Pages: TTabItemList read FPages write SetCDPages; property PageCount: integer read GetPageCount; property ParentColor; property ParentFont; property TabStop default True; end; { TCDTrackBarDrawer } TCDPageControlDrawer = class(TCDControlDrawer) public CDPageControl: TCDPageControl; function GetPageIndexFromXY(x, y: integer): integer; virtual; abstract; function GetTabHeight(AIndex: Integer): Integer; virtual; abstract; function GetTabWidth(ADest: TCanvas; AIndex: Integer): Integer; virtual; abstract; procedure DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage); virtual; abstract; procedure DrawToCanvas(ADest: TCanvas); virtual; abstract; procedure DrawTabSheet(ADest: TCanvas; ATabSheet: TCDTabSheet); virtual; abstract; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); virtual; abstract; end; { TCDPageControlDrawerWinCE } TCDPageControlDrawerWinCE = class(TCDPageControlDrawer) private StartIndex: integer; //FEndIndex LeftmostTabVisibleIndex: Integer; procedure DrawTabs(ADest: TCanvas); procedure DrawTab(ADest: TCanvas; AIndex: Integer; ACurStartLeftPos: Integer; ACurPage: TCDTabSheet); public function GetPageIndexFromXY(x, y: integer): integer; override; function GetTabHeight(AIndex: Integer): Integer; override; function GetTabWidth(ADest: TCanvas; AIndex: Integer): Integer; override; function GetClientRect(AControl: TCDControl): TRect; override; procedure DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage); override; procedure DrawToCanvas(ADest: TCanvas); override; procedure DrawTabSheet(ADest: TCanvas; ATabSheet: TCDTabSheet); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override; end; procedure Register; function CheckTabButton(RWidth: integer; aItem: TTabItemList): boolean; implementation uses ObjInspStrConsts; const INT_BitmappedButton_LineSpacing = 2; MaskBaseColor = $00111111; resourcestring sTABSHEET_DEFAULT_NAME = 'CTabSheet'; sNEXT_PAGE = 'Ne&xt Page'; sPREV_PAGE = '&Previouse Page'; procedure Register; begin RegisterComponents('Common Controls', [TCDButton, TCDTrackBar, TCDTabControl, TCDPageControl, TCDGroupBox]); RegisterComponentEditor(TCDPageControl, TCDPageControlEditor); RegisterComponentEditor(TCDTabSheet, TCDPageControlEditor); RegisterNoIcon([TCDTabSheet]); RegisterClasses([TCDTabSheet]); end; function CheckTabButton(RWidth: integer; aItem: TTabItemList): boolean; var i, j: integer; begin Result := False; j := 0; for i := 0 to aItem.Count - 1 do begin j := j + aItem[i].Width; if j > RWidth - 6 then begin Result := True; break; end; end; end; { TCDCustomTabControlDrawerWinCE } procedure TCDCustomTabControlDrawerWinCE.DrawCaptionBar(ADest: TCanvas; lRect: TRect; CL: TColor); begin { CaptionHeight := GetTabHeight(CDPageControl.PageIndex, CDPageControl) - 4; RButtHeight := GetTabHeight(CDPageControl.PageIndex, CDPageControl); aRect := lRect; ADest.Pen.Style := psSolid; ADest.Brush.Style := bsSolid; ADest.Pen.FPColor := TColorToFPColor(ColorToRGB(CL)); //TColorToFPColor(ColorToRGB($009C9B91)); ADest.Brush.FPColor := TColorToFPColor(ColorToRGB(CL)); aRect.Left := lRect.Left; aRect.Top := lRect.Top; aRect.Bottom := lRect.Bottom; aRect.Right := lRect.Right; ADest.RecTangle(lRect); if CDPageControl.FPages.Count = 0 then begin ADest.Brush.Color := clWhite; ADest.Pen.Color := $009C9B91; ADest.RecTangle(Rect(aRect.Left, aRect.Top, aRect.Right + 1, aRect.Bottom + 2)); ADest.Pen.Color := clWhite; ADest.Line(aRect.Left + 1, aRect.Bottom + 1, aRect.Right, aRect.Bottom + 1); Exit; end; aRect.Left := lRect.Left + 2; aRect.Top := lRect.Top + 3; //ADest.TextStyle.Opaque :=false; //SetBkMode(ADest.Handle, TRANSPARENT); if ADest.Brush.Style = bsSolid then SetBkMode(ADest.Handle, OPAQUE) else SetBkMode(ADest.Handle, TRANSPARENT); for i := StartIndex to CDPageControl.FPages.Count - 1 do begin aText := CDPageControl.FPages[i].TabPage.Caption; rWidth := (CaptionHeight - ADest.TextHeight(aText)) + ADest.TextWidth(aText); CDPageControl.FPages[i].Width := rWidth; if aRect.Left + rWidth > lRect.Right - 6 then Break else aRect.Right := aRect.Left + rWidth; if CDPageControl.PageIndex = i then begin cRect := aRect; if i = StartIndex then cRect.Left := aRect.Left - 2 else cRect.Left := aRect.Left - 4; cRect.Right := aRect.Right + 4; cRect.Top := cRect.Top - 2; bText := CDPageControl.FPages[i].TabPage.Caption; end else DrawTabHead(aDest, aRect, CDPageControl.Color, False); MaskColor := MaskBaseColor + i - StartIndex; //DrawTabHeadMask(MaskHeadBmp.Canvas, aRect, MaskColor, False); ADest.TextOut(aRect.Left + (aRect.Right - aRect.Left - ADest.TextWidth(aText)) div 2, aRect.Top + (aRect.Bottom - aRect.Top - ADest.TextHeight(aText)) div 2, aText); aRect.Left := aRect.Right + 3; end; ADest.Line(lRect.Left, lRect.Bottom - 1, cRect.Left, lRect.Bottom - 1); ADest.Line(cRect.Right, lRect.Bottom - 1, lRect.Right, lRect.Bottom - 1); DrawTabHead(aDest, cRect, clWhite, True); ADest.TextOut(cRect.Left + (cRect.Right - cRect.Left - ADest.TextWidth(bText)) div 2, cRect.Top + (cRect.Bottom - cRect.Top - ADest.TextHeight(bText)) div 2, bText); if not CheckTabButton(lRect.Right - lRect.Left, CDPageControl.FPages) then Exit; aRect.Left := lRect.Right - RButtHeight * 2 - 3; aRect.Top := 1; aRect.Bottom := RButtHeight + 1; aRect.Right := lRect.Right - RButtHeight; //if FMDownL then // GradFill(ADest, aRect, $00F1A079, $00EFAF9B) //else GradFill(ADest, aRect, $00FDD9CB, $00F2C9B8); aRect.Left := lRect.Right - RButtHeight - 1; aRect.Top := 1; aRect.Bottom := RButtHeight + 1; aRect.Right := lRect.Right; GradFill(ADest, aRect, $00FDD9CB, $00F2C9B8); ADest.Pen.FPColor := TColorToFPColor(ColorToRGB($0085614D)); bRect.Top := 1; bRect.Left := lRect.Right - RButtHeight * 2 - 3; bRect.Right := lRect.Right; bRect.Bottom := RButtHeight + 1; DrawArrow(ADest, bRect, True); DrawArrow(ADest, bRect, False); ADest.Pen.FPColor := TColorToFPColor(ColorToRGB(clWhite)); ADest.Line(lRect.Right - RButtHeight * 2 - 3, 1, lRect.Right, 1); ADest.Line(lRect.Right, 1, lRect.Right, RButtHeight + 1); ADest.Line(lRect.Right, RButtHeight + 1, lRect.Right - RButtHeight * 2 - 3, RButtHeight + 1); ADest.Line(lRect.Right - RButtHeight * 2 - 3, RButtHeight + 1, lRect.Right - RButtHeight * 2 - 3, 1); ADest.Pen.FPColor := TColorToFPColor(ColorToRGB($00E5BAA7)); ADest.Brush.Style := bsClear; ADest.Rectangle(lRect.Right - RButtHeight * 2 - 2, 2, lRect.Right - 1, RButtHeight + 1); CornerColor := TColorToFPColor(ColorToRGB($00F6E3D9)); ADest.Colors[lRect.Right - RButtHeight * 2 - 2, 2] := CornerColor; ADest.Colors[lRect.Right - RButtHeight * 2 - 2, RButtHeight] := CornerColor; ADest.Colors[lRect.Right - 1, 2] := CornerColor; ADest.Colors[lRect.Right - 1, RButtHeight] := CornerColor; ADest.Pen.FPColor := TColorToFPColor(ColorToRGB(clWhite)); ADest.Line(lRect.Right - 51, 1, lRect.Right, 1); ADest.Line(lRect.Right, 1, lRect.Right, 25); ADest.Line(lRect.Right, 25, lRect.Right - 51, 25); ADest.Line(lRect.Right - 51, 25, lRect.Right - 51, 1); ADest.Pen.FPColor := TColorToFPColor(ColorToRGB($00FFFFFF));} end; procedure TCDCustomTabControlDrawerWinCE.DrawTabs(ADest: TCanvas); var IsPainting: Boolean = False; CurStartLeftPos: Integer = 0; i: Integer; begin for i := 0 to CDTabControl.Tabs.Count - 1 do begin if i = LeftmostTabVisibleIndex then IsPainting := True; if IsPainting then begin DrawTab(ADest, i, CurStartLeftPos); CurStartLeftPos := CurStartLeftPos + GetTabWidth(ADest, i); end; end; end; procedure TCDCustomTabControlDrawerWinCE.DrawTab(ADest: TCanvas; AIndex: Integer; ACurStartLeftPos: Integer); var IsSelected: Boolean; lTabWidth, lTabHeight, lTabTopPos: Integer; Points: array of TPoint; lCaption: String; begin IsSelected := CDTabControl.FTabIndex = AIndex; if IsSelected then begin lTabTopPos := 0; lTabHeight := GetTabHeight(AIndex); end else begin lTabTopPos := 5; lTabHeight := GetTabHeight(AIndex)-5; end; lTabWidth := GetTabWidth(ADest, AIndex); // Fill the area inside the outer border ADest.Pen.Style := psClear; ADest.Brush.Style := bsSolid; ADest.Brush.Color := clWhite; SetLength(Points, 5); Points[0] := Point(ACurStartLeftPos, lTabTopPos); Points[1] := Point(ACurStartLeftPos+lTabWidth-5, lTabTopPos); Points[2] := Point(ACurStartLeftPos+lTabWidth, lTabTopPos+5); Points[3] := Point(ACurStartLeftPos+lTabWidth, lTabTopPos+lTabHeight); Points[4] := Point(ACurStartLeftPos, lTabTopPos+lTabHeight); ADest.Polygon(Points); // Draw the outer border only in the top and right sides, // and bottom if unselected ADest.Pen.Style := psSolid; ADest.Brush.Style := bsClear; ADest.Pen.Color := ColorToRGB($009C9B91); ADest.MoveTo(ACurStartLeftPos+1, lTabTopPos); ADest.LineTo(ACurStartLeftPos+lTabWidth-5, lTabTopPos); ADest.LineTo(ACurStartLeftPos+lTabWidth, lTabTopPos+5); ADest.LineTo(ACurStartLeftPos+lTabWidth, lTabTopPos+lTabHeight); // If it is selected, add a selection frame if IsSelected then begin ADest.Pen.Color := ColorToRGB($00D6C731); ADest.Pen.Style := psSolid; ADest.Brush.Style := bsClear; ADest.Rectangle( ACurStartLeftPos+3, lTabTopPos+3, ACurStartLeftPos+lTabWidth-5, lTabTopPos+lTabHeight-5 ); end; // Now the text lCaption := CDTabControl.Tabs.Strings[AIndex]; ADest.TextOut(ACurStartLeftPos+5, lTabTopPos+5, lCaption); end; function TCDCustomTabControlDrawerWinCE.GetPageIndexFromXY(x, y: integer ): integer; begin Result := 1; end; function TCDCustomTabControlDrawerWinCE.GetTabHeight(AIndex: Integer): Integer; begin if CDTabControl.Font.Size = 0 then Result := 32 else Result := CDTabControl.Font.Size + 22; end; function TCDCustomTabControlDrawerWinCE.GetTabWidth(ADest: TCanvas; AIndex: Integer): Integer; const TCDTabControl_WinCE_TabCaptionExtraWidth = 20; var lCaption: string; begin lCaption := CDTabControl.Tabs.Strings[AIndex]; Result := ADest.TextWidth(lCaption) + TCDTabControl_WinCE_TabCaptionExtraWidth; end; function TCDCustomTabControlDrawerWinCE.GetClientRect(AControl: TCDControl ): TRect; var lCaptionHeight: Integer; begin lCaptionHeight := GetTabHeight(CDTabControl.FTabIndex) - 4; Result := Rect(5, lCaptionHeight + 1, CDTabControl.Width - 10, CDTabControl.Height - lCaptionHeight - 5); end; procedure TCDCustomTabControlDrawerWinCE.DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage); begin end; procedure TCDCustomTabControlDrawerWinCE.DrawToCanvas(ADest: TCanvas); var CaptionHeight: Integer; lColor: TColor; begin CaptionHeight := GetTabHeight(CDTabControl.FTabIndex); if CDTabControl.Color = clDefault then lColor := clSilver else lColor := ColorToRGB(CDTabControl.Color); // Background ADest.Brush.Color := lColor; ADest.Brush.Style := bsSolid; ADest.Pen.Style := psClear; ADest.Rectangle(0, 0, CDTabControl.Width, CDTabControl.Height); // Frame detail ADest.Pixels[CDTabControl.Width - 1, CaptionHeight] := lColor; // frame ADest.Pen.Style := psSolid; ADest.Brush.Style := bsClear; ADest.Pen.Color := ColorToRGB($009C9B91); if CDTabControl.Tabs.Count = 0 then ADest.Rectangle(0, 0, CDTabControl.Width - 2, CDTabControl.Height - 2) else ADest.Rectangle(0, CaptionHeight, CDTabControl.Width - 2, CDTabControl.Height - 2); ADest.Pen.Color := ColorToRGB($00BFCED0); ADest.Line(CDTabControl.Width - 1, CaptionHeight + 1, CDTabControl.Width - 1, CDTabControl.Height - 1); ADest.Line(CDTabControl.Width - 1, CDTabControl.Height - 1, 1, CDTabControl.Height - 1); // Tabs ADest.Font.Name := CDTabControl.Font.Name; ADest.Font.Size := CDTabControl.Font.Size; // DrawCaptionBar(ADest, Rect(0, 0, CDPageControl.Width - // 2, CaptionHeight + 1), CDPageControl.Color, CDPageControl); DrawTabs(ADest); end; procedure TCDCustomTabControlDrawerWinCE.DrawTabSheet(ADest: TCanvas); begin ADest.Brush.Color := CDTabControl.Color; ADest.Brush.Style := bsSolid; ADest.Pen.Style := psClear; ADest.Rectangle(0, 0, CDTabControl.Width, CDTabControl.Height); end; procedure TCDCustomTabControlDrawerWinCE.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); var i: Integer; CurPage: TCDTabSheet; CurStartLeftPos: Integer = 0; VisiblePagesStarted: Boolean = False; lTabWidth: Integer; begin for i := 0 to CDTabControl.Tabs.Count - 1 do begin if i = LeftmostTabVisibleIndex then VisiblePagesStarted := True; if VisiblePagesStarted then begin lTabWidth := GetTabWidth(CDTabControl.Canvas, i); if (X > CurStartLeftPos) and (X < CurStartLeftPos + lTabWidth) and (Y < GetTabHeight(i)) then begin CDTabControl.SetTabIndex(i); Exit; end; CurStartLeftPos := CurStartLeftPos + lTabWidth; end; end; end; { TCDCustomTabControl } procedure TCDCustomTabControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin TCDPageControlDrawer(FCurrentDrawer).MouseDown(Button, Shift, X, Y); inherited MouseDown(Button, Shift, X, Y); end; procedure TCDCustomTabControl.PrepareCurrentDrawer; begin case FDrawStyle of dsWince: FCurrentDrawer := FDrawerWinCE; dsCustom: FCurrentDrawer := CustomDrawer; end; end; procedure TCDCustomTabControl.SetTabIndex(AValue: Integer); begin if FTabIndex = AValue then Exit; FTabIndex := AValue; Invalidate; end; constructor TCDCustomTabControl.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 232; Height := 184; TabStop := True; FDrawerWinCE := TCDCustomTabControlDrawerWinCE.Create; TCDCustomTabControlDrawerWinCE(FDrawerWinCE).CDTabControl := Self; CustomDrawer := FDrawerWinCE; // Dummy to avoid designer crashes FCurrentDrawer := FDrawerWinCE; FDrawStyle := dsWinCE; ParentColor := True; ParentFont := True; ControlStyle := ControlStyle + [csDesignInteractive]; // FTabs should hold only visible tabs FTabs := TStringList.Create; end; destructor TCDCustomTabControl.Destroy; begin FTabs.Free; inherited Destroy; end; procedure TCDCustomTabControl.Paint; var AImage: TLazIntfImage = nil; ABmp: TBitmap = nil; lCanvas: TFPImageCanvas = nil; begin ABmp := TBitmap.Create; try ABmp.Width := Width; ABmp.Height := Height; AImage := ABmp.CreateIntfImage; lCanvas := TFPImageCanvas.Create(AImage); TCDCustomTabControlDrawer(FCurrentDrawer).DrawToIntfImage(lCanvas, AImage); ABmp.LoadFromIntfImage(AImage); ABmp.Canvas.Font.Assign(Font); TCDCustomTabControlDrawer(FCurrentDrawer).DrawToCanvas(ABmp.Canvas); Canvas.Draw(0, 0, ABmp); finally if lCanvas <> nil then lCanvas.Free; if AImage <> nil then AImage.Free; ABmp.Free; end; end; { TCustomBitmappedButton } procedure TCustomBitmappedButton.DoEnter; begin DoButtonUp(); inherited DoEnter; end; procedure TCustomBitmappedButton.DoExit; begin DoButtonUp(); inherited DoExit; end; procedure TCustomBitmappedButton.KeyDown(var Key: word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); if Key = VK_SPACE then DoButtonDown(); end; procedure TCustomBitmappedButton.KeyUp(var Key: word; Shift: TShiftState); begin DoButtonUp(); inherited KeyUp(Key, Shift); end; procedure TCustomBitmappedButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin DoButtonDown(); inherited MouseDown(Button, Shift, X, Y); end; procedure TCustomBitmappedButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin DoButtonUp(); inherited MouseUp(Button, Shift, X, Y); end; procedure TCustomBitmappedButton.MouseEnter; begin inherited MouseEnter; end; procedure TCustomBitmappedButton.MouseLeave; begin inherited MouseLeave; end; procedure TCustomBitmappedButton.DoButtonDown(); var NewState: TBitmappedButtonState; begin NewState := bbsDown; case FState of bbsNormal, bbsFocused: NewState := bbsDown; // bbsChecked, bbsCheckedSelected: NewState := bbsCheckedDown; end; if NewState <> FState then begin FState := NewState; Invalidate; end; end; procedure TCustomBitmappedButton.DoButtonUp(); var NewState: TBitmappedButtonState; begin if Focused then NewState := bbsFocused else NewState := bbsNormal; { case FState of bbsCheckedDown: begin if Focused then NewState := bbsCheckedSelected else NewState := bbsChecked; end; end;} if NewState <> FState then begin FState := NewState; Invalidate; end; end; procedure TCustomBitmappedButton.RealSetText(const Value: TCaption); begin inherited RealSetText(Value); // Makes sure that caption changes are drawn Invalidate; end; constructor TCustomBitmappedButton.Create(AOwner: TComponent); begin inherited Create(AOwner); BmpBuffer := TBitmap.Create; StrBuffer := TStringList.Create; FImageBtn := TPicture.Create; FImageBtnDown := TPicture.Create; FImageBtnMouseOver := TPicture.Create; FImageBtnFocused := TPicture.Create; FImageBtnChecked := TPicture.Create; FOptions := [{bboDrawSelectionRectangle}]; TabStop := True; end; destructor TCustomBitmappedButton.Destroy; begin if Assigned(FImageBtn) then FImageBtn.Free; if Assigned(FImageBtnDown) then FImageBtnDown.Free; if Assigned(FImageBtnMouseOver) then FImageBtnMouseOver.Free; if Assigned(FImageBtnFocused) then FImageBtnFocused.Free; if Assigned(FImageBtnChecked) then FImageBtnChecked.Free; BmpBuffer.Free; StrBuffer.Free; inherited Destroy; end; procedure TCustomBitmappedButton.EraseBackground(DC: HDC); begin // The correct implementation is doing nothing end; procedure TCustomBitmappedButton.Paint; var lTextX, lTextY, lTextCX, lTextCY, lTmp, lTextHeightPlusLineSpacing: integer; i: integer; begin // First draw the button image BmpBuffer.Width := Width; BmpBuffer.Height := Height; BmpBuffer.Canvas.Draw(0, 0, GetStateBitmap()); // Now measure the text position BmpBuffer.Canvas.Font.Assign(Self.Font); BmpBuffer.Canvas.Brush.Style := bsClear; StrBuffer.Text := Caption; lTextCX := 0; for i := 0 to StrBuffer.Count - 1 do begin lTmp := BmpBuffer.Canvas.TextWidth(StrBuffer.Strings[i]); lTextCX := Max(lTextCX, lTmp); end; lTextHeightPlusLineSpacing := BmpBuffer.Canvas.TextHeight(Caption) + INT_BitmappedButton_LineSpacing; lTextCY := BmpBuffer.Canvas.TextHeight(Caption) * StrBuffer.Count + INT_BitmappedButton_LineSpacing * (StrBuffer.Count - 1); lTextX := Width div 2 - lTextCX div 2; lTextY := Height div 2 - lTextCY div 2; // Draw the text for i := 0 to StrBuffer.Count - 1 do begin BmpBuffer.Canvas.TextOut(lTextX, lTextY + lTextHeightPlusLineSpacing * i, StrBuffer.Strings[i]); end; // And flush the buffer to the screen Canvas.Draw(0, 0, BmpBuffer); end; function TCustomBitmappedButton.GetStateBitmap(): TBitmap; begin case FState of bbsDown: Result := FImageBtnDown.Bitmap; // bbsMouseOver: Result := FImageBtnMouseOver; bbsFocused: begin if bboUseImageForSelection in Options then Result := FImageBtnFocused.Bitmap else Result := FImageBtn.Bitmap; end; // bbsChecked: Result := FImageBtnChecked; else Result := FImageBtn.Bitmap; end; end; { TCDControl } procedure TCDControl.PrepareCurrentDrawer; begin end; procedure TCDControl.SetDrawStyle(const AValue: TCDDrawStyle); begin if FDrawStyle = AValue then exit; FDrawStyle := AValue; Invalidate; PrepareCurrentDrawer(); //FCurrentDrawer.SetClientRectPos(Self); end; function TCDControl.GetClientRect: TRect; begin if FCurrentDrawer = nil then Result := inherited GetClientRect() else Result := FCurrentDrawer.GetClientRect(Self); end; procedure TCDControl.EraseBackground(DC: HDC); begin end; { TCDButtonDrawer } function TCDButtonDrawer.GetClientRect(AControl: TCDControl): TRect; var CDButton: TCDButton absolute AControl; begin Result := Rect(1, 1, CDButton.Width - 1, CDButton.Height - 1); end; procedure TCDButton.DoEnter; begin DoButtonUp(); inherited DoEnter; end; procedure TCDButton.DoExit; begin DoButtonUp(); inherited DoExit; end; procedure TCDButton.KeyDown(var Key: word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); if (Key = VK_SPACE) or (Key = VK_RETURN) then DoButtonDown(); end; procedure TCDButton.KeyUp(var Key: word; Shift: TShiftState); begin DoButtonUp(); inherited KeyUp(Key, Shift); end; procedure TCDButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin if not Focused then SetFocus; DoButtonDown(); inherited MouseDown(Button, Shift, X, Y); end; procedure TCDButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin DoButtonUp(); inherited MouseUp(Button, Shift, X, Y); end; procedure TCDButton.MouseEnter; begin inherited MouseEnter; end; procedure TCDButton.MouseLeave; begin inherited MouseLeave; end; procedure TCDButton.DoButtonDown(); var NewState: TBitmappedButtonState; begin NewState := bbsDown; case FState of bbsNormal, bbsFocused: NewState := bbsDown; end; if NewState <> FState then begin FState := NewState; Invalidate; end; end; procedure TCDButton.DoButtonUp(); var NewState: TBitmappedButtonState; begin if Focused then NewState := bbsFocused else NewState := bbsNormal; if NewState <> FState then begin FState := NewState; Invalidate; end; end; procedure TCDButton.PrepareCurrentDrawer; begin case DrawStyle of dsWince: FCurrentDrawer := FDrawerWinCE; dsCustom: FCurrentDrawer := CustomDrawer; dsAndroid: FCurrentDrawer := FDrawerAndroid; dsXPTaskbar: FCurrentDrawer := FDrawerXPTB; dsGrad: FCurrentDrawer := FDrawerGrad; dsWin2000: FCurrentDrawer := FDrawerWin2k; end; end; procedure TCDButton.RealSetText(const Value: TCaption); begin inherited RealSetText(Value); Invalidate; end; constructor TCDButton.Create(AOwner: TComponent); begin inherited Create(AOwner); TabStop := True; FDrawerWinCE := TCDButtonDrawerWinCE.Create; CustomDrawer := FDrawerWinCE; // Dummy to avoid designer crashes FDrawerAndroid := TCDButtonDrawerAndroid.Create; FDrawerXPTB := TCDButtonDrawerXPTB.Create; FDrawerGrad := TCDButtonDrawerGrad.Create; FDrawerWin2k := TCDButtonDrawerWin2k.Create; Width := 120; Height := 43; //Color := clTeal; ParentFont := True; FDrawStyle := dsAndroid; Color := $00F1F5F5; end; destructor TCDButton.Destroy; begin inherited Destroy; end; procedure DrawCDButtonDown(Canvas: TCanvas; CDButton: TCDButton); begin with Canvas do begin Brush.Style := bsSolid; Brush.Color := CDButton.Color; Pen.Color := Brush.Color; Rectangle(0, 0, Width, Height); FillRect(0, 0, Width, Height); Brush.Color := GetAColor(CDButton.Color, 93); Pen.Color := GetAColor(Brush.Color, 76); RoundRect(0, 0, Width, Height, 8, 8); end; end; procedure TCDButton.Paint; var AImage: TLazIntfImage = nil; ABmp: TBitmap = nil; lCanvas: TFPImageCanvas = nil; pColor: TColor; begin // inherited Paint; PrepareCurrentDrawer(); ABmp := TBitmap.Create; try ABmp.Width := Width; ABmp.Height := Height; AImage := ABmp.CreateIntfImage; lCanvas := TFPImageCanvas.Create(AImage); // First step of the drawing: FCL TFPCustomCanvas for fast pixel access TCDButtonDrawer(FCurrentDrawer).DrawToIntfImage(lCanvas, Self); ABmp.LoadFromIntfImage(AImage); // Second step of the drawing: LCL TCustomCanvas for easy font access TCDButtonDrawer(FCurrentDrawer).DrawToCanvas(ABmp.Canvas, Self, FState); Canvas.Draw(0, 0, ABmp); finally if lCanvas <> nil then lCanvas.Free; if AImage <> nil then AImage.Free; ABmp.Free; end; end; { TCDButtonDrawerGrad } procedure TCDButtonDrawerGrad.DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); begin end; procedure TCDButtonDrawerGrad.DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); var TmpB: TBitmap; Str: string; begin // Button shape -> This crashes in Gtk2 TmpB := TBitmap.Create; TmpB.Width := CDButton.Width; TmpB.Height := CDButton.Height; TmpB.Canvas.Brush.Color := CDButton.Color; TmpB.Canvas.Brush.Style := bsSolid; TmpB.Canvas.RoundRect(0, 0, TmpB.Width, TmpB.Height, 8, 8); // CDButton.SetShape(TmpB); with TmpB.Canvas do begin Brush.Style := bsSolid; Brush.Color := CDButton.Parent.Color; Pen.Color := Brush.Color; Rectangle(0, 0, Width, Height); FillRect(0, 0, Width, Height); Brush.Color := GetAColor(CDButton.Color, 90); end; // Button image case FState of bbsDown: begin DrawCDButtonDown(TmpB.Canvas, CDButton); end; bbsFocused: //GradientFill(GetUColor(CDButton.Color, 50), GetAColor(CDButton.Color, 60), TmpB.Canvas); GradientFill(clWhite, GetAColor(CDButton.Color, 96), TmpB.Canvas); else //GradientFill(GetUColor(CDButton.Color, 10), GetAColor(CDButton.Color, 20), TmpB.Canvas); GradientFill(clWhite, CDButton.Color, TmpB.Canvas); end; ADest.Draw(0, 0, TmpB); TmpB.Free; // Button text {$ifndef CUSTOMDRAWN_USE_FREETYPE} ADest.Font.Assign(CDButton.Font); ADest.Brush.Style := bsClear; ADest.Pen.Style := psSolid; Str := CDButton.Caption; ADest.TextOut((CDButton.Width - ADest.TextWidth(Str)) div 2, (CDButton.Height - ADest.TextHeight(Str)) div 2, Str); {$endif} end; { TCDButtonDrawerWinCE } procedure TCDButtonDrawerWinCE.DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); begin end; procedure TCDButtonDrawerWinCE.DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); var TmpB: TBitmap; Str: string; begin // Button shape -> This crashes in Gtk2 TmpB := TBitmap.Create; TmpB.Width := CDButton.Width; TmpB.Height := CDButton.Height; TmpB.Canvas.Brush.Color := CDButton.Color; TmpB.Canvas.Brush.Style := bsSolid; TmpB.Canvas.RoundRect(0, 0, TmpB.Width, TmpB.Height, 8, 8); // CDButton.SetShape(TmpB); // Button image case FState of bbsDown: begin with TmpB.Canvas do begin Brush.Style := bsSolid; Brush.Color := GetAColor(CDButton.Color, 90); Pen.Color := clBlack; Pen.Style := psSolid; Rectangle(0, 0, Width, Height); end; end; bbsFocused: with TmpB.Canvas do begin Brush.Style := bsSolid; Brush.Color := GetAColor(CDButton.Color, 99); Pen.Color := clBlack; Pen.Style := psSolid; Rectangle(0, 0, Width, Height); Rectangle(1, 1, Width - 1, Height - 1); // The border is thicken when focused end; else with TmpB.Canvas do begin Brush.Style := bsSolid; Brush.Color := CDButton.Color; Pen.Color := clBlack; Pen.Style := psSolid; Rectangle(0, 0, Width, Height); end; end; ADest.Draw(0, 0, TmpB); TmpB.Free; // Button text {$ifndef CUSTOMDRAWN_USE_FREETYPE} ADest.Font.Assign(CDButton.Font); ADest.Brush.Style := bsClear; ADest.Pen.Style := psSolid; Str := CDButton.Caption; ADest.TextOut((CDButton.Width - ADest.TextWidth(Str)) div 2, (CDButton.Height - ADest.TextHeight(Str)) div 2, Str); {$endif} end; procedure TCDButtonDrawerWin2k.DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); begin end; procedure TCDButtonDrawerWin2k.DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); var TmpB: TBitmap; Str: string; begin // Button shape -> This crashes in Gtk2 TmpB := TBitmap.Create; TmpB.Width := CDButton.Width; TmpB.Height := CDButton.Height; TmpB.Canvas.Brush.Color := CDButton.Color; TmpB.Canvas.Brush.Style := bsSolid; TmpB.Canvas.RoundRect(0, 0, TmpB.Width, TmpB.Height, 8, 8); with TmpB.Canvas do begin Brush.Style := bsSolid; Brush.Color := CDButton.Color; Pen.Color := clWhite; Pen.Style := psSolid; Rectangle(0, 0, Width - 1, Height - 1); Pen.Color := clWhite; Line(0, 0, Width - 1, 0); Line(0, 0, 0, Height - 1); Pen.Color := clGray; Line(0, Height - 1, Width - 1, Height - 1); Line(Width - 1, Height - 1, Width - 1, -1); Pen.Color := $0099A8AC; Line(1, Height - 2, Width - 2, Height - 2); Line(Width - 2, Height - 2, Width - 2, 0); Pen.Color := $00E2EFF1; Line(1, 1, Width - 2, 1); Line(1, 1, 1, Height - 2); end; // Button image case FState of bbsDown: begin with TmpB.Canvas do begin Brush.Style := bsSolid; Brush.Color := CDButton.Color; Pen.Color := clWhite; Pen.Style := psSolid; Rectangle(0, 0, Width - 1, Height - 1); Pen.Color := clGray; Line(0, 0, Width - 1, 0); Line(0, 0, 0, Height - 1); Pen.Color := clWhite; Line(0, Height - 1, Width - 1, Height - 1); Line(Width - 1, Height - 1, Width - 1, -1); Pen.Color := $00E2EFF1; Line(1, Height - 2, Width - 2, Height - 2); Line(Width - 2, Height - 2, Width - 2, 0); Pen.Color := $0099A8AC; Line(1, 1, Width - 2, 1); Line(1, 1, 1, Height - 2); end; end; bbsFocused: with TmpB.Canvas do DrawFocusRect(Rect(3, 3, Width - 4, Height - 4)) else begin end; end; ADest.Draw(0, 0, TmpB); TmpB.Free; // Button text {$ifndef CUSTOMDRAWN_USE_FREETYPE} ADest.Font.Assign(CDButton.Font); ADest.Brush.Style := bsClear; ADest.Pen.Style := psSolid; Str := CDButton.Caption; if FState = bbsDown then ADest.TextOut((CDButton.Width - ADest.TextWidth(Str)) div 2 + 1, (CDButton.Height - ADest.TextHeight(Str)) div 2 + 1, Str) else ADest.TextOut((CDButton.Width - ADest.TextWidth(Str)) div 2, (CDButton.Height - ADest.TextHeight(Str)) div 2, Str); {$endif} end; procedure TCDButtonDrawerAndroid.DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); begin end; procedure TCDButtonDrawerAndroid.DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); var //TmpB: TBitmap; Str: string; begin // Button shape -> This crashes in Gtk2 { TmpB.Canvas.Brush.Color := CDButton.Color; TmpB.Canvas.Brush.Style := bsSolid; TmpB.Canvas.RoundRect(0, 0, TmpB.Width, TmpB.Height, 8, 8); CDButton.SetShape(TmpB); ADest.Draw(0, 0, TmpB); TmpB.Free; } ADest.Brush.Color := CDButton.Parent.Color; ADest.Brush.Style := bsSolid; ADest.Pen.Color := ADest.Brush.Color; ADest.RecTangle(0, 0, CDButton.Width, CDButton.Height); // Button image case FState of bbsDown: begin DrawCDButtonDown(ADest, CDButton); end; bbsFocused: begin DrawAndroidButton(ADest, GetAColor(CDButton.Color, 98)); end; else DrawAndroidButton(ADest, GetAColor(CDButton.Color, 96)); end; // Button text {$ifndef CUSTOMDRAWN_USE_FREETYPE} ADest.Font.Assign(CDButton.Font); ADest.Brush.Style := bsClear; ADest.Pen.Style := psSolid; Str := CDButton.Caption; ADest.TextOut((CDButton.Width - ADest.TextWidth(Str)) div 2, (CDButton.Height - ADest.TextHeight(Str)) div 2, Str); {$endif} end; procedure TCDButtonDrawerXPTB.DrawToIntfImage(ADest: TFPImageCanvas; CDButton: TCDButton); begin end; procedure TCDButtonDrawerXPTB.DrawToCanvas(ADest: TCanvas; CDButton: TCDButton; FState: TBitmappedButtonState); var Str: string; begin case FState of bbsDown: begin DrawCDButtonDown(ADest, CDButton); end; bbsFocused: begin DrawXPTaskbarButton(ADest, GetAColor(CDButton.Color, 98)); end; else DrawXPTaskbarButton(ADest, CDButton.Color); end; // Button text {$ifndef CUSTOMDRAWN_USE_FREETYPE} ADest.Font.Assign(CDButton.Font); ADest.Brush.Style := bsClear; ADest.Pen.Style := psSolid; Str := CDButton.Caption; ADest.TextOut((CDButton.Width - ADest.TextWidth(Str)) div 2, (CDButton.Height - ADest.TextHeight(Str)) div 2, Str); {$endif} end; { TCDGroupBox } procedure TCDGroupBox.PrepareCurrentDrawer(); begin case DrawStyle of dsWince: FCurrentDrawer := FDrawerWinCE; dsCustom: FCurrentDrawer := CustomDrawer; end; end; procedure TCDGroupBox.SetDrawStyle(const AValue: TCDDrawStyle); begin if FDrawStyle = AValue then exit; FDrawStyle := AValue; Invalidate; PrepareCurrentDrawer(); FCurrentDrawer.SetClientRectPos(Self); end; constructor TCDGroupBox.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 100; Height := 100; TabStop := False; FDrawerWinCE := TCDGroupBoxDrawerWinCE.Create; CustomDrawer := FDrawerWinCE; // Dummy to avoid designer crashes ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csDoubleClicks, csReplicatable]; end; destructor TCDGroupBox.Destroy; begin inherited Destroy; end; procedure TCDGroupBox.EraseBackground(DC: HDC); begin end; procedure TCDGroupBox.Paint; var AImage: TLazIntfImage = nil; ABmp: TBitmap = nil; lCanvas: TFPImageCanvas = nil; begin inherited Paint; PrepareCurrentDrawer(); ABmp := TBitmap.Create; try ABmp.Width := Width; ABmp.Height := Height; AImage := ABmp.CreateIntfImage; lCanvas := TFPImageCanvas.Create(AImage); // First step of the drawing: FCL TFPCustomCanvas for fast pixel access FCurrentDrawer.DrawToIntfImage(lCanvas, Self); ABmp.LoadFromIntfImage(AImage); // Second step of the drawing: LCL TCustomCanvas for easy font access FCurrentDrawer.DrawToCanvas(ABmp.Canvas, Self); Canvas.Draw(0, 0, ABmp); finally if lCanvas <> nil then lCanvas.Free; if AImage <> nil then AImage.Free; ABmp.Free; end; end; { TCDGroupBoxDrawerWinCE } procedure TCDGroupBoxDrawerWinCE.SetClientRectPos(CDGroupBox: TCDGroupBox); var lRect: TRect; lCaptionHeight: integer; begin lCaptionHeight := 10; lRect := Rect(1, lCaptionHeight, CDGroupBox.Width - 1, CDGroupBox.Height - 1); CDGroupBox.AdjustClientRect(lRect); end; procedure TCDGroupBoxDrawerWinCE.DrawToIntfImage(ADest: TFPImageCanvas; CDGroupBox: TCDGroupBox); {$ifdef CUSTOMDRAWN_USE_FREETYPE} var AFont: TFreeTypeFont = nil; {$endif} begin FCaptionMiddle := CDGroupBox.Canvas.TextHeight('Ź') div 2; // Background if CDGroupBox.Parent = nil then ADest.Brush.FPColor := colLtGray else if CDGroupBox.Parent.Color = clDefault then ADest.Brush.FPColor := TColorToFPColor(ColorToRGB(clForm)) else ADest.Brush.FPColor := TColorToFPColor(ColorToRGB(CDGroupBox.Parent.Color)); ADest.Brush.Style := bsSolid; ADest.Pen.Style := psClear; ADest.Rectangle(0, 0, CDGroupBox.Width, CDGroupBox.Height); // frame ADest.Pen.FPColor := colBlack; ADest.Pen.Style := psSolid; ADest.Brush.Style := bsClear; ADest.Rectangle(0, FCaptionMiddle, CDGroupBox.Width - 1, CDGroupBox.Height - 1); {$ifdef CUSTOMDRAWN_USE_FREETYPE} // Caption background and caption // initialize free type font manager opcftfont.InitEngine; // FontMgr.SearchPath:='/usr/share/fonts/truetype/'; AFont := TFreeTypeFont.Create; try // Text background ADest.Pen.Style := psClear; ADest.Brush.Style := bsSolid; // The brush color was already set previously and is already correct // ADest.Rectangle(5, 0, AFont.GetTextWidth(CDGroupBox.Caption) + 5, 10); // paint text ADest.Pen.Style := psSolid; ADest.Brush.Style := bsClear; ADest.Font := AFont; ADest.Font.Name := 'Arial'; ADest.Font.Size := 10; ADest.TextOut(5, 10, CDGroupBox.Caption); finally AFont.Free; end; {$endif} end; procedure TCDGroupBoxDrawerWinCE.DrawToCanvas(ADest: TCanvas; CDGroupBox: TCDGroupBox); begin {$ifndef CUSTOMDRAWN_USE_FREETYPE} if CDGroupBox.Parent = nil then ADest.Brush.Color := clLtGray else if CDGroupBox.Parent.Color = clDefault then ADest.Brush.Color := ColorToRGB(clForm) else ADest.Brush.Color := ColorToRGB(CDGroupBox.Parent.Color); // paint text ADest.Pen.Style := psSolid; ADest.Brush.Style := bsSolid; // This will fill the text background ADest.Font.Size := 10; ADest.TextOut(FCaptionMiddle, 0, CDGroupBox.Caption); {$endif} end; { TCDTrackBar } procedure TCDTrackBar.SetMax(Value: integer); begin if Value = FMax then Exit; FMax := Value; Invalidate; end; procedure TCDTrackBar.SetMin(Value: integer); begin if Value = FMin then Exit; FMin := Value; Invalidate; end; procedure TCDTrackBar.SetPosition(Value: integer); begin if Value = FPosition then Exit; FPosition := Value; Invalidate; end; function TCDTrackBar.GetPositionFromMousePos(X, Y: integer): integer; var lLeftBorder, lRightBorder: Integer; begin FCurrentDrawer.GetGeometry(lLeftBorder, lRightBorder); if X > Width - lRightBorder then Result := FMax else if X < lLeftBorder then Result := FMin else Result := FMin + (X - lLeftBorder) * (FMax - FMin + 1) div (Width - lRightBorder - lLeftBorder); // sanity check if Result > FMax then Result := FMax; if Result < FMin then Result := FMin; end; procedure TCDTrackBar.Changed; begin end; procedure TCDTrackBar.DoEnter; begin inherited DoEnter; end; procedure TCDTrackBar.DoExit; begin inherited DoExit; end; procedure TCDTrackBar.KeyDown(var Key: word; Shift: TShiftState); var NewPosition: Integer; begin inherited KeyDown(Key, Shift); if (Key = 37) or (Key = 40) then NewPosition := FPosition - (FMax - FMin) div 10; if (Key = 38) or (Key = 39) then NewPosition := FPosition + (FMax - FMin) div 10; // sanity check if NewPosition > FMax then NewPosition := FMax; if NewPosition < FMin then NewPosition := FMin; Position := NewPosition; end; procedure TCDTrackBar.KeyUp(var Key: word; Shift: TShiftState); begin inherited KeyUp(Key, Shift); end; procedure TCDTrackBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); var NewPosition: Integer; begin SetFocus; NewPosition := GetPositionFromMousePos(X, Y); DragDropStarted := True; Position := NewPosition; inherited MouseDown(Button, Shift, X, Y); end; procedure TCDTrackBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin DragDropStarted := False; inherited MouseUp(Button, Shift, X, Y); end; procedure TCDTrackBar.MouseMove(Shift: TShiftState; X, Y: integer); var NewPosition: Integer; begin if DragDropStarted then begin NewPosition := GetPositionFromMousePos(X, Y); Position := NewPosition; end; inherited MouseMove(Shift, X, Y); end; procedure TCDTrackBar.MouseEnter; begin inherited MouseEnter; end; procedure TCDTrackBar.MouseLeave; begin inherited MouseLeave; end; constructor TCDTrackBar.Create(AOwner: TComponent); begin inherited Create(AOwner); Height := 25; Width := 100; FCurrentDrawer := TCDTrackBarDrawerGraph.Create; Color := clBtnFace; FMax := 10; FMin := 0; TabStop := True; end; destructor TCDTrackBar.Destroy; begin FCurrentDrawer.Free; inherited Destroy; end; procedure TCDTrackBar.EraseBackground(DC: HDC); begin //inherited EraseBackground(DC); end; procedure TCDTrackBar.Paint; var AImage: TLazIntfImage = nil; ABmp: TBitmap = nil; lCanvas: TFPImageCanvas = nil; begin inherited Paint; ABmp := TBitmap.Create; try ABmp.Width := Width; ABmp.Height := Height; AImage := ABmp.CreateIntfImage; lCanvas := TFPImageCanvas.Create(AImage); // First step of the drawing: FCL TFPCustomCanvas for fast pixel access FCurrentDrawer.DrawToIntfImage(lCanvas, AImage, Self); ABmp.LoadFromIntfImage(AImage); Canvas.Draw(0, 0, ABmp); finally if lCanvas <> nil then lCanvas.Free; if AImage <> nil then AImage.Free; ABmp.Free; end; end; { TCDTrackBarDrawer } procedure TCDTrackBarDrawerGraph.DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage; CDTrackBar: TCDTrackBar); const CDBarEdge = 18; var lDrawingBottom, StepsCount, i: Integer; pStart, pEnd: integer; // for drawing the decorative bars dRect: TRect; pStepWidth, pHalfStepWidth: Integer; begin // Sanity check if CDTrackBar.Max - CDTrackBar.Min <= 0 then raise Exception.Create('[TCDTrackBarDrawerGraph.DrawToIntfImage] Max-Min must be at least 1'); // Preparations StepsCount := CDTrackBar.Max - CDTrackBar.Min + 1; pStepWidth := (CDTrackBar.Width - CDBarEdge) div StepsCount; pHalfStepWidth := (CDTrackBar.Width - CDBarEdge) div (StepsCount * 2); // The bottom part of the drawing lDrawingBottom := CDTrackBar.Height - 10; // Background if CDTrackBar.Parent = nil then ADest.Brush.FPColor := colLtGray else ADest.Brush.FPColor := TColorToFPColor(ColorToRGB(CDTrackBar.Color)); ADest.Brush.Style := bsSolid; ADest.Pen.Style := psClear; ADest.Rectangle(0, 0, CDTrackBar.Width, CDTrackBar.Height); ADest.Brush.FPColor := TColorToFPColor(ColorToRGB($006BB6E6)); // Draws the double-sided arrow in the center of the slider ADest.Pen.Style := psSolid; ADest.Pen.FPColor := TColorToFPColor(ColorToRGB($006BB6E6)); ADest.Line(0, lDrawingBottom, CDTrackBar.Width, lDrawingBottom); ADest.Line(3, lDrawingBottom - 1, 6, lDrawingBottom - 1); ADest.Line(5, lDrawingBottom - 2, 6, lDrawingBottom - 2); ADest.Line(3, lDrawingBottom + 1, 6, lDrawingBottom + 1); ADest.Line(5, lDrawingBottom + 2, 6, lDrawingBottom + 2); ADest.Line(CDTrackBar.Width - 1 - 3, lDrawingBottom - 1, CDTrackBar.Width - 1 - 6, lDrawingBottom - 1); ADest.Line(CDTrackBar.Width - 1 - 5, lDrawingBottom - 2, CDTrackBar.Width - 1 - 6, lDrawingBottom - 2); ADest.Line(CDTrackBar.Width - 1 - 3, lDrawingBottom + 1, CDTrackBar.Width - 1 - 6, lDrawingBottom + 1); ADest.Line(CDTrackBar.Width - 1 - 5, lDrawingBottom + 2, CDTrackBar.Width - 1 - 6, lDrawingBottom + 2); ADest.Pen.FPColor := TColorToFPColor(ColorToRGB(clGray)); ADest.Brush.FPColor := TColorToFPColor(ColorToRGB($00F0F0F0)); // Draws the decorative bars and also the slider button pStart := 10 - 1; for i := 0 to StepsCount - 1 do begin // Draw the decorative bars dRect := Bounds( pStart + pHalfStepWidth, lDrawingBottom - 5 - i, Round(pStepWidth)-3, 4 + i); ADest.Brush.Style := bsSolid; ADest.Pen.Style := psSolid; ADest.Pen.FPColor := colBlack; if i + CDTrackBar.Min <= CDTrackBar.Position then ADest.Brush.FPColor := colDkGray else ADest.Brush.FPColor := colWhite; ADest.Rectangle(dRect); // Draw the slider if i + CDTrackBar.Min = CDTrackBar.Position then begin ADest.Brush.FPColor := TColorToFPColor(ColorToRGB($006BB6E6)); ADest.Brush.Style := bsSolid; ADest.Rectangle(pStart, lDrawingBottom + 1, pStart + 10, lDrawingBottom + 6); ADest.Pen.FPColor := TColorToFPColor(ColorToRGB($005BA6C6)); ADest.RecTangle(pStart, lDrawingBottom + 2, pStart + 10, lDrawingBottom + 7); ADest.Pen.FPColor := TColorToFPColor(ColorToRGB($006BB6E6)); ADest.RecTangle(pStart, lDrawingBottom, pStart + 10, lDrawingBottom + 2); end; pStart := pStart + pStepWidth; end; ADest.Pen.FPColor := TColorToFPColor(ColorToRGB($007BC6F6)); ADest.Line(7, lDrawingBottom - 1, CDTrackBar.Width - 8, lDrawingBottom - 1); ADest.Line(7, lDrawingBottom + 1, CDTrackBar.Width - 8, lDrawingBottom + 1); ADest.Colors[2, lDrawingBottom - 1] := ADest.Pen.FPColor; ADest.Colors[4, lDrawingBottom - 2] := ADest.Pen.FPColor; ADest.Colors[2, lDrawingBottom + 1] := ADest.Pen.FPColor; ADest.Colors[4, lDrawingBottom + 2] := ADest.Pen.FPColor; ADest.Colors[6, lDrawingBottom - 3] := ADest.Pen.FPColor; ADest.Colors[6, lDrawingBottom + 3] := ADest.Pen.FPColor; ADest.Colors[CDTrackBar.Width - 1 - 2, lDrawingBottom - 1] := ADest.Pen.FPColor; ADest.Colors[CDTrackBar.Width - 1 - 4, lDrawingBottom - 2] := ADest.Pen.FPColor; ADest.Colors[CDTrackBar.Width - 1 - 2, lDrawingBottom + 1] := ADest.Pen.FPColor; ADest.Colors[CDTrackBar.Width - 1 - 4, lDrawingBottom + 2] := ADest.Pen.FPColor; ADest.Colors[CDTrackBar.Width - 1 - 6, lDrawingBottom - 3] := ADest.Pen.FPColor; ADest.Colors[CDTrackBar.Width - 1 - 6, lDrawingBottom + 3] := ADest.Pen.FPColor; end; procedure TCDTrackBarDrawerGraph.GetGeometry(var ALeftBorder, ARightBorder: Integer); begin ALeftBorder := 9; ARightBorder := 9; end; {TCDTabControlItemList} constructor TTabItem.Create(aCollection: TCollection); begin inherited Create(ACollection); fImageIndex := -1; end; destructor TTabItem.Destroy; begin inherited; end; procedure TTabItem.SetModified(Value: boolean); begin if fModified <> Value then begin fModified := Value; DoChange; end; end; procedure TTabItem.SetSelected(Value: boolean); var i: integer; begin if FSelected <> Value then begin FSelected := Value; if FSelected then begin with (GetOwner as TTabItemList) do begin for i := 0 to Count - 1 do begin if (Items[i] <> Self) and (Items[i].Selected) then begin Items[i].Selected := False; end; end; end; end; (Collection as TTabItemList).DoSelected(Self, FSelected); end; end; function TTabItem.GetDisplayName: string; begin {if FCaption <> '' then Result := FCaption else } Result := inherited GetDisplayName; end; procedure TTabItem.DoChange; begin (Collection as TTabItemList).DoChanged(Self); end; procedure TTabItem.SetTitle(Value: string); begin if FTitle <> Value then begin FTitle := Value; //DoChange; end; end; procedure TTabItem.SetImageIndex(Value: TImageIndex); begin if FImageIndex <> Value then begin FImageIndex := Value; DoChange; end; end; { TTabItemList } procedure TTabItemList.DoSelected(ATab: TTabItem; ASelected: boolean); begin // (GetOwner as TCDPageControl).TabSelected(ATab, ASelected); end; procedure TTabItemList.DoChanged(ATab: TTabItem); begin (GetOwner as TCDPageControl).Invalidate; end; procedure TTabItemList.SetItem(Index: integer; Value: TTabItem); begin inherited SetItem(Index, Value); end; function TTabItemList.GetItem(Index: integer): TTabItem; begin Result := inherited GetItem(Index) as TTabItem; end; function TTabItemList.IndexOf(ATab: TTabItem): integer; var i, c: integer; begin c := Count; for i := 0 to c - 1 do if Items[i] = ATab then begin Result := i; Exit; end; Result := -1; end; function TTabItemList.Add: TTabItem; begin Result := TTabItem(inherited add); Result.Title := 'Title' + IntToStr(Count - 1); end; { TCDTabSheet } constructor TCDTabSheet.Create(AOwner: TComponent); begin inherited Create(AOwner); //Parent := TCDPageControl(AOwner); TabStop := False; ParentColor := True; parentFont := True; ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csDesignFixedBounds, csDoubleClicks, csDesignInteractive]; //ControlStyle := ControlStyle + [csAcceptsControls, csDesignFixedBounds, // csNoDesignVisible, csNoFocus]; end; destructor TCDTabSheet.Destroy; begin inherited Destroy; end; procedure TCDTabSheet.EraseBackground(DC: HDC); begin end; procedure TCDTabSheet.Paint; begin inherited Paint; if CDPageControl <> nil then begin TCDPageControlDrawer(CDPageControl.FCurrentDrawer).DrawTabSheet(Canvas, Self); end; end; { TCDPageControlEditor } procedure TCDPageControlEditor.ShowPageMenuItemClick(Sender: TObject); var AMenuItem: TMenuItem; NewPageIndex: integer; begin AMenuItem := TMenuItem(Sender); if (AMenuItem = nil) or (not (AMenuItem is TMenuItem)) then exit; NewPageIndex := AMenuItem.MenuIndex; if (NewPageIndex < 0) or (NewPageIndex >= PControl.PageCount) then exit; PControl.PageIndex := NewPageIndex; GetDesigner.SelectOnlyThisComponent(PControl.Pages[PControl.PageIndex].TabPage); end; procedure TCDPageControlEditor.ExecuteVerb(Index: integer); var NewPage: TCDTabSheet; Hook: TPropertyEditorHook; PageComponent: TPersistent; OldPage: longint; begin if not GetHook(Hook) then exit; case Index of 0: begin // New Page PControl.AddPage(''); NewPage := PControl.ActivePage; Hook.PersistentAdded(NewPage, True); Designer.Modified; //Hook.PersistentAdded(NewPage,true); //Designer.Modified; end; 1: begin // Insert Page PControl.InsertPage(PControl.PageIndex, ''); Hook.PersistentAdded(PControl.ActivePage, True); Modified; end; 2: begin // Delete Page with PControl do begin NewPage := ActivePage; if NewPage = nil then Exit; RemovePage(NewPage.Index); end; end; 3: begin // Next Page PControl.ActivePage := PControl.FindNextPage(PControl.ActivePage, True, False); end; 4: begin // Previous Page PControl.ActivePage := PControl.FindNextPage(PControl.ActivePage, False, False); end; end; Modified; if Designer <> nil then Designer.Modified; PControl.Invalidate; end; function TCDPageControlEditor.GetVerb(Index: integer): string; begin case Index of 0: Result := nbcesAddPage; 1: Result := nbcesInsertPage; 2: Result := nbcesDeletePage; 3: Result := sNEXT_PAGE; 4: Result := sPREV_PAGE; 5: Result := nbcesShowPage; end; end; function TCDPageControlEditor.GetVerbCount: integer; begin Result := 6; end; procedure TCDPageControlEditor.PrepareItem(Index: integer; const AnItem: TMenuItem); begin inherited PrepareItem(Index, AnItem); case Index of 0: ; 1: AnItem.Enabled := PControl.PageIndex >= 0; 2: AnItem.Enabled := PControl.PageIndex >= 0; 3: AnItem.Enabled := PControl.PageIndex < PControl.PageCount - 1; 4: AnItem.Enabled := PControl.PageIndex > 0; 5: AddMenuItemsForPages(AnItem); end; end; procedure TCDPageControlEditor.AddMenuItemsForPages(ParentMenuItem: TMenuItem); var i: integer; NewMenuItem: TMenuItem; TabPage: TCDTabSheet; begin ParentMenuItem.Enabled := PControl.PageCount > 0; for i := 0 to PControl.PageCount - 1 do begin TabPage := PControl.Pages.Items[i].TabPage; NewMenuItem := TMenuItem.Create(ParentMenuItem); NewMenuItem.Name := 'ShowPage' + IntToStr(i); NewMenuItem.Caption := TabPage.Name + ' "' + TabPage.Caption + '"'; NewMenuItem.OnClick := @ShowPageMenuItemClick; ParentMenuItem.Add(NewMenuItem); end; end; function TCDPageControlEditor.PControl: TCDPageControl; begin if Component is TCDPageControl then Result := TCDPageControl(Component) else if Component is TCDTabSheet then Result := TCDPageControl(TCDTabSheet(Component).Parent); end; { TCDPageControl } procedure TCDPageControl.AddPage(S: string); // InsertPage(FPages.Count, S); var NewPage: TCDTabSheet; begin NewPage := TCDTabSheet.Create(Owner); NewPage.Parent := Self; //Name := Designer.CreateUniqueComponentName(ClassName); NewPage.Name := GetUniqueName(sTABSHEET_DEFAULT_NAME, Self.Owner); if S = '' then NewPage.Caption := NewPage.Name else NewPage.Caption := S; PositionTabSheet(NewPage); SetActivePage(NewPage); //FPages.AddObject(NewPage.Name, NewPage); FPages.Insert(FPages.Count); FPages.Items[FPages.Count - 1].DisplayName := NewPage.Name; FPages.Items[FPages.Count - 1].TabPage := NewPage; NewPage.Index := FPages.Count - 1; FPageIndex := FPages.Count - 1; //FPageCount := PageCount + 1; enD; function TCDPageControl.GetPage(aIndex: integer): TCDTabSheet; begin Result := FPages[aIndex].TabPage; end; procedure TCDPageControl.InsertPage(aIndex: integer; S: string); var NewPage: TCDTabSheet; begin NewPage := TCDTabSheet.Create(Owner); NewPage.Parent := Self; //Name := Designer.CreateUniqueComponentName(ClassName); NewPage.Name := GetUniqueName(sTABSHEET_DEFAULT_NAME, Self.Owner); if S = '' then NewPage.Caption := NewPage.Name else NewPage.Caption := S; PositionTabSheet(NewPage); SetActivePage(NewPage); //FPages.AddObject(NewPage.Name, NewPage); FPages.Insert(aIndex); FPages.Items[aIndex].DisplayName := NewPage.Name; FPages.Items[aIndex].TabPage := NewPage; NewPage.Index := FPages.Count - 1; FPageIndex := aIndex; //FPageCount := PageCount + 1; end; procedure TCDPageControl.RemovePage(aIndex: integer); begin if aIndex > 0 then PageIndex := aIndex - 1 else Exit; {if not GetHook(Hook) then exit; PageComponent := TPersistent(NewPage); Hook.DeletePersistent(PageComponent); } //if NewPage <> nil then // NewPage.Free; Application.ReleaseComponent(FPages[aIndex].TabPage); //Owner.RemoveComponent(FPages[aIndex].TabPage); //FPages[aIndex].TabPage := nil; FPages.Delete(aIndex); //Owner.RemoveComponent(NewPage); //if PControl.PageCount > 1 then // PControl.FPageCount := PControl.PageCount - 1; end; procedure TCDPageControl.PrepareCurrentDrawer(); begin case DrawStyle of dsWince: FCurrentDrawer := FDrawerWinCE; dsCustom: FCurrentDrawer := CustomDrawer; end; end; function TCDPageControl.FindNextPage(CurPage: TCDTabSheet; GoForward, CheckTabVisible: boolean): TCDTabSheet; var I, TempStartIndex: integer; begin if FPages.Count <> 0 then begin //StartIndex := FPages.IndexOfObject(CurPage); TempStartIndex := CurPage.Index; if TempStartIndex = -1 then if GoForward then TempStartIndex := FPages.Count - 1 else TempStartIndex := 0; I := TempStartIndex; repeat if GoForward then begin Inc(I); if I = FPages.Count then I := 0; end else begin if I = 0 then I := FPages.Count; Dec(I); end; Result := FPages[I].TabPage; if not CheckTabVisible or Result.Visible then Exit; until I = TempStartIndex; end; Result := nil; end; procedure TCDPageControl.SelectNextPage(GoForward: boolean; CheckTabVisible: boolean = True); var Page: TCDTabSheet; begin Page := FindNextPage(ActivePage, GoForward, CheckTabVisible); if (Page <> nil) and (Page <> ActivePage) then SetActivePage(Page); end; constructor TCDPageControl.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 232; Height := 184; TabStop := True; FDrawerWinCE := TCDPageControlDrawerWinCE.Create; TCDPageControlDrawer(FDrawerWinCE).CDPageControl := Self; CustomDrawer := FDrawerWinCE; // Dummy to avoid designer crashes FDrawStyle := dsWinCE; ParentColor := True; ParentFont := True; ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csDesignInteractive]; FPages := TTabItemList.Create(TTabItem); end; destructor TCDPageControl.Destroy; begin FPages.Free; inherited Destroy; end; procedure TCDPageControl.SetActivePage(Value: TCDTabSheet); var i: integer; CurPage: TCDTabSheet; begin for i := 0 to FPages.Count - 1 do begin CurPage := FPages[i].TabPage; if CurPage = Value then begin PositionTabSheet(CurPage); CurPage.BringToFront; // Check first, Tab is Visible? FPageIndex := i; end else begin CurPage.Align := alNone; CurPage.Height := 0; end; end; FActivePage := Value; Invalidate; end; procedure TCDPageControl.SetPageIndex(Value: integer); begin if (Value > -1) and (Value < FPages.Count) then begin FPageIndex := Value; ActivePage := FPages[Value].TabPage; Invalidate; end; end; procedure TCDPageControl.Paint; var AImage: TLazIntfImage = nil; ABmp: TBitmap = nil; lCanvas: TFPImageCanvas = nil; begin // inherited Paint; PrepareCurrentDrawer(); ABmp := TBitmap.Create; try ABmp.Width := Width; ABmp.Height := Height; AImage := ABmp.CreateIntfImage; lCanvas := TFPImageCanvas.Create(AImage); // First step of the drawing: FCL TFPCustomCanvas for fast pixel access TCDPageControlDrawer(FCurrentDrawer).DrawToIntfImage(lCanvas, AImage); ABmp.LoadFromIntfImage(AImage); ABmp.Canvas.Font.Assign(Font); // Second step of the drawing: LCL TCustomCanvas for easy font access TCDPageControlDrawer(FCurrentDrawer).DrawToCanvas(ABmp.Canvas); Canvas.Draw(0, 0, ABmp); finally if lCanvas <> nil then lCanvas.Free; if AImage <> nil then AImage.Free; ABmp.Free; end; end; procedure TCDPageControl.SetCDPages(Value: TTabItemList); begin FPages.Assign(Value); end; procedure TCDPageControl.UpdateAllDesignerFlags; var i: integer; begin for i := 0 to FPages.Count - 1 do UpdateDesignerFlags(i); end; procedure TCDPageControl.UpdateDesignerFlags(APageIndex: integer); begin if APageIndex <> fPageIndex then FPages[APageIndex].TabPage.ControlStyle := FPages[APageIndex].TabPage.ControlStyle + [csNoDesignVisible] else FPages[APageIndex].TabPage.ControlStyle := FPages[APageIndex].TabPage.ControlStyle - [csNoDesignVisible]; end; procedure TCDPageControl.PositionTabSheet(ATabSheet: TCDTabSheet); begin ATabSheet.SetBounds(1, 32 + 1, Width - 3, Height - 32 - 4); ATabSheet.BorderSpacing.Top := 32 + 2; ATabSheet.BorderSpacing.Left := 2; ATabSheet.BorderSpacing.Right := 3; ATabSheet.BorderSpacing.Bottom := 3; ATabSheet.Align := alClient; end; procedure TCDPageControl.SetMouseUP; begin FMDownL := False; FMDownR := False; end; function TCDPageControl.GetPageCount: integer; begin Result := FPages.Count; end; procedure TCDPageControl.SetDrawStyle(AValue: TCDDrawStyle); begin if FDrawStyle=AValue then Exit; FDrawStyle:=AValue; end; procedure TCDPageControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin TCDPageControlDrawer(FCurrentDrawer).MouseDown(Button, Shift, X, Y); inherited MouseDown(Button, Shift, X, Y); end; { TCDPageControlDrawerWinCE } procedure TCDPageControlDrawerWinCE.DrawTabs(ADest: TCanvas); var CurVisibleIndex: Integer = 0; IsPainting: Boolean = False; CurPage: TCDTabSheet; CurStartLeftPos: Integer = 0; i: Integer; begin for i := 0 to CDPageControl.Pages.Count - 1 do begin CurPage := CDPageControl.GetPage(i); if CurPage.Visible then begin if CurVisibleIndex = LeftmostTabVisibleIndex then IsPainting := True; if IsPainting then begin DrawTab(ADest, i, CurStartLeftPos, CurPage); CurStartLeftPos := CurStartLeftPos + GetTabWidth(ADest, i); end; Inc(CurVisibleIndex); end; end; end; procedure TCDPageControlDrawerWinCE.DrawTab(ADest: TCanvas; AIndex: Integer; ACurStartLeftPos: Integer; ACurPage: TCDTabSheet); var IsSelected: Boolean; lTabWidth, lTabHeight, lTabTopPos: Integer; Points: array of TPoint; begin IsSelected := CDPageControl.ActivePage = ACurPage; if IsSelected then begin lTabTopPos := 0; lTabHeight := GetTabHeight(AIndex); end else begin lTabTopPos := 5; lTabHeight := GetTabHeight(AIndex)-5; end; lTabWidth := GetTabWidth(ADest, AIndex); // Fill the area inside the outer border ADest.Pen.Style := psClear; ADest.Brush.Style := bsSolid; ADest.Brush.Color := clWhite; SetLength(Points, 5); Points[0] := Point(ACurStartLeftPos, lTabTopPos); Points[1] := Point(ACurStartLeftPos+lTabWidth-5, lTabTopPos); Points[2] := Point(ACurStartLeftPos+lTabWidth, lTabTopPos+5); Points[3] := Point(ACurStartLeftPos+lTabWidth, lTabTopPos+lTabHeight); Points[4] := Point(ACurStartLeftPos, lTabTopPos+lTabHeight); ADest.Polygon(Points); // Draw the outer border only in the top and right sides, // and bottom if unselected ADest.Pen.Style := psSolid; ADest.Brush.Style := bsClear; ADest.Pen.Color := ColorToRGB($009C9B91); ADest.MoveTo(ACurStartLeftPos+1, lTabTopPos); ADest.LineTo(ACurStartLeftPos+lTabWidth-5, lTabTopPos); ADest.LineTo(ACurStartLeftPos+lTabWidth, lTabTopPos+5); ADest.LineTo(ACurStartLeftPos+lTabWidth, lTabTopPos+lTabHeight); // If it is selected, add a selection frame if IsSelected then begin ADest.Pen.Color := ColorToRGB($00D6C731); ADest.Pen.Style := psSolid; ADest.Brush.Style := bsClear; ADest.Rectangle( ACurStartLeftPos+3, lTabTopPos+3, ACurStartLeftPos+lTabWidth-5, lTabTopPos+lTabHeight-5 ); end; // Now the text ADest.TextOut(ACurStartLeftPos+5, lTabTopPos+5, ACurPage.Caption); end; function TCDPageControlDrawerWinCE.GetPageIndexFromXY(x, y: integer): integer; begin Result := 1; //if MaskHeadBmp.Canvas.Pixels[x, y] = clWhite then // Result := -1 //else // Result := MaskHeadBmp.Canvas.Pixels[x, y] - MaskBaseColor + StartIndex; //if (PageIndex <> Result) and (PageIndex > -1) then // PageIndex := Result; end; function TCDPageControlDrawerWinCE.GetTabHeight(AIndex: Integer): Integer; //var // CurPage: TCDTabSheet; begin //CurPage := CDPageControl.GetPage(AIndex); if CDPageControl.Font.Size = 0 then Result := 32 else Result := CDPageControl.Font.Size + 22; end; function TCDPageControlDrawerWinCE.GetTabWidth(ADest: TCanvas; AIndex: Integer): Integer; const TCDPageControl_WinCE_TabCaptionExtraWidth = 20; var CurPage: TCDTabSheet; begin CurPage := CDPageControl.GetPage(AIndex); if ADest <> nil then begin Result := ADest.TextWidth(CurPage.Caption) + TCDPageControl_WinCE_TabCaptionExtraWidth; CurPage.StoredWidth := Result; end else Result := CurPage.StoredWidth; end; function TCDPageControlDrawerWinCE.GetClientRect(AControl: TCDControl): TRect; var lCaptionHeight: Integer; begin lCaptionHeight := GetTabHeight(CDPageControl.PageIndex) - 4; Result := Rect(5, lCaptionHeight + 1, CDPageControl.Width - 10, CDPageControl.Height - lCaptionHeight - 5); end; procedure TCDPageControlDrawerWinCE.DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage); begin end; procedure TCDPageControlDrawerWinCE.DrawToCanvas(ADest: TCanvas); var CaptionHeight: Integer; lColor: TColor; begin CaptionHeight := GetTabHeight(CDPageControl.PageIndex); if CDPageControl.Color = clDefault then lColor := clSilver else lColor := ColorToRGB(CDPageControl.Color); // Background ADest.Brush.Color := lColor; ADest.Brush.Style := bsSolid; ADest.Pen.Style := psClear; ADest.Rectangle(0, 0, CDPageControl.Width, CDPageControl.Height); // Frame detail ADest.Pixels[CDPageControl.Width - 1, CaptionHeight] := lColor; // frame ADest.Pen.Style := psSolid; ADest.Brush.Style := bsClear; ADest.Pen.Color := ColorToRGB($009C9B91); if CDPageControl.Pages.Count = 0 then ADest.Rectangle(0, 0, CDPageControl.Width - 2, CDPageControl.Height - 2) else ADest.Rectangle(0, CaptionHeight, CDPageControl.Width - 2, CDPageControl.Height - 2); ADest.Pen.Color := ColorToRGB($00BFCED0); ADest.Line(CDPageControl.Width - 1, CaptionHeight + 1, CDPageControl.Width - 1, CDPageControl.Height - 1); ADest.Line(CDPageControl.Width - 1, CDPageControl.Height - 1, 1, CDPageControl.Height - 1); // Tabs ADest.Font.Name := CDPageControl.Font.Name; ADest.Font.Size := CDPageControl.Font.Size; // DrawCaptionBar(ADest, Rect(0, 0, CDPageControl.Width - // 2, CaptionHeight + 1), CDPageControl.Color, CDPageControl); DrawTabs(ADest); end; procedure TCDPageControlDrawerWinCE.DrawTabSheet(ADest: TCanvas; ATabSheet: TCDTabSheet); begin ADest.Brush.Color := CDPageControl.Color; ADest.Brush.Style := bsSolid; ADest.Pen.Style := psClear; ADest.Rectangle(0, 0, ATabSheet.Width, ATabSheet.Height); end; procedure TCDPageControlDrawerWinCE.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); var i: Integer; CurPage: TCDTabSheet; CurVisibleIndex: Integer = 0; CurStartLeftPos: Integer = 0; VisiblePagesStarted: Boolean = False; begin for i := 0 to CDPageControl.Pages.Count - 1 do begin CurPage := CDPageControl.GetPage(i); if CurPage.Visible then begin if CurVisibleIndex = LeftmostTabVisibleIndex then VisiblePagesStarted := True; if VisiblePagesStarted then begin if (X > CurStartLeftPos) and (X < CurStartLeftPos + GetTabWidth(nil, i)) and (Y < GetTabHeight(i)) then begin CDPageControl.ActivePage := CurPage; Exit; end; CurStartLeftPos := CurStartLeftPos + GetTabWidth(nil, i); end; Inc(CurVisibleIndex); end; end; end; end.