{ 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; property DrawStyle: TCDDrawStyle read FDrawStyle write SetDrawStyle; 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); protected procedure RealSetText(const Value: TCaption); override; // to update on caption changes 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 } TCDCustomTabSheet = class(TCustomControl) private CDTabControl: TCDCustomTabControl; FTabVisible: Boolean; public destructor Destroy; override; property TabVisible: Boolean read FTabVisible write FTabVisible; 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; procedure SetTabs(AValue: TStringList); protected constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; function GetTabCount: Integer; procedure CorrectTabIndex(); public CustomDrawer: TCDCustomTabControlDrawer; // Fill the field to use the dsCustom draw mode property Tabs: TStringList read FTabs write SetTabs; 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; // 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; // property OnTabSelected: TTabSelectedEvent read fOnTabSelected write fOnTabSelected; end; { TCDTabSheet } TCDPageControl = class; TCDTabSheet = class(TCDCustomTabSheet) public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EraseBackground(DC: HDC); override; procedure Paint; override; published property Caption; property Color; property Font; property TabVisible: Boolean; end; { TCDPageControl } { TCDPageControlEditor } TCDPageControlEditor = class(TDefaultComponentEditor) private 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(TCDCustomTabControl) private function GetActivePage: TCDTabSheet; function GetPageCount: integer; function GetPageIndex: integer; 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; function FindNextPage(CurPage: TCDTabSheet; GoForward, CheckTabVisible: boolean): TCDTabSheet; procedure SelectNextPage(GoForward: boolean; CheckTabVisible: boolean = True); public function InsertPage(aIndex: integer; S: string): TCDTabSheet; procedure RemovePage(aIndex: integer); function AddPage(S: string): TCDTabSheet; function GetPage(aIndex: integer): TCDTabSheet; property PageCount: integer read GetPageCount; published property ActivePage: TCDTabSheet read GetActivePage write SetActivePage; property DrawStyle: TCDDrawStyle; property Caption; property Color; property Font; property PageIndex: integer read GetPageIndex write SetPageIndex; property ParentColor; property ParentFont; property TabStop default True; end; procedure Register; 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('Custom Drawn', [TCDButton, TCDTrackBar, TCDTabControl, TCDPageControl, TCDGroupBox]); RegisterComponentEditor(TCDPageControl, TCDPageControlEditor); RegisterComponentEditor(TCDTabSheet, TCDPageControlEditor); RegisterNoIcon([TCDTabSheet]); RegisterClasses([TCDTabSheet]); end; { TCDCustomTabSheet } destructor TCDCustomTabSheet.Destroy; var lIndex: Integer; begin // We should support deleting the tabsheet directly too, // and then it should update the tabcontrol // This is important mostly for the designer if CDTabControl <> nil then begin lIndex := CDTabControl.FTabs.IndexOfObject(Self); if lIndex >= 0 then begin CDTabControl.FTabs.Delete(lIndex); CDTabControl.CorrectTabIndex(); end; end; inherited Destroy; 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); var lColor: TColor; lFPColor: TFPColor; x, y: Integer; begin if CDTabControl.Color = clDefault then lColor := ColorToRGB(CDTabControl.GetDefaultColor(dctBrush)) else lColor := ColorToRGB(CDTabControl.Color); // Background lFPColor := TColorToFPColor(lColor); FPImg.FillPixels(lFPColor); end; procedure TCDCustomTabControlDrawerWinCE.DrawToCanvas(ADest: TCanvas); var CaptionHeight: Integer; begin CaptionHeight := GetTabHeight(CDTabControl.FTabIndex); // frame ADest.Pen.Style := psSolid; ADest.Brush.Style := bsClear; ADest.Pen.Color := ColorToRGB($009C9B91); if CDTabControl.GetTabCount = 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 if CDTabControl is TCDPageControl then (CDTabControl as TCDPageControl).SetPageIndex(i) else CDTabControl.SetTabIndex(i); Exit; end; CurStartLeftPos := CurStartLeftPos + lTabWidth; end; end; end; { TCDCustomTabControl } procedure TCDCustomTabControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin TCDCustomTabControlDrawer(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; procedure TCDCustomTabControl.SetTabs(AValue: TStringList); begin if FTabs=AValue then Exit; FTabs.Assign(AValue); CorrectTabIndex(); 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 + [csAcceptsControls, 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; function TCDCustomTabControl.GetTabCount: Integer; begin Result := 0; if FTabs <> nil then Result := FTabs.Count; end; procedure TCDCustomTabControl.CorrectTabIndex; begin if FTabIndex >= FTabs.Count then FTabIndex := FTabs.Count - 1; 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 // Disable this, since although it works in Win32, it doesn't seam to work in LCL-Carbon //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; procedure TCDGroupBox.RealSetText(const Value: TCaption); begin inherited RealSetText(Value); Invalidate; 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; if FCaptionMiddle = 0 then FCaptionMiddle := CDGroupBox.Canvas.Font.Size div 2; if FCaptionMiddle = 0 then FCaptionMiddle := 5; // 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; { TCDTabSheet } constructor TCDTabSheet.Create(AOwner: TComponent); begin inherited Create(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 if CDTabControl <> nil then begin TCDCustomTabControlDrawer(CDTabControl.FCurrentDrawer).DrawTabSheet(Canvas); 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(TComponent(PControl.Tabs.Objects[PControl.PageIndex])); 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 NewPage := PControl.AddPage(''); Hook.PersistentAdded(NewPage, True); end; 1: begin // Insert Page NewPage := PControl.InsertPage(PControl.PageIndex, ''); Hook.PersistentAdded(NewPage, True); end; 2: begin // Delete Page //WriteLn('Delete 1'); NewPage := PControl.ActivePage; if NewPage = nil then Exit; //WriteLn('Delete 2'); PControl.RemovePage(PControl.PageIndex); Hook.PersistentDeleting(NewPage); 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.GetPage(i); 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 } function TCDPageControl.AddPage(S: string): TCDTabSheet; // InsertPage(FPages.Count, S); var NewPage: TCDTabSheet; begin NewPage := TCDTabSheet.Create(Owner); NewPage.Parent := Self; NewPage.CDTabControl := 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); FTabs.AddObject(S, NewPage); SetActivePage(NewPage); Result := NewPage; end; function TCDPageControl.GetPage(AIndex: integer): TCDTabSheet; begin if (AIndex >= 0) and (AIndex < FTabs.Count) then Result := TCDTabSheet(FTabs.Objects[AIndex]) else Result := nil; end; function TCDPageControl.InsertPage(aIndex: integer; S: string): TCDTabSheet; 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); FTabs.InsertObject(AIndex, S, NewPage); SetActivePage(NewPage); Result := NewPage; end; procedure TCDPageControl.RemovePage(aIndex: integer); begin if (AIndex < 0) or (AIndex >= FTabs.Count) then Exit; Application.ReleaseComponent(TComponent(FTabs.Objects[AIndex])); FTabs.Delete(aIndex); if FTabIndex >= FTabs.Count then Dec(FTabIndex); Invalidate; end; function TCDPageControl.FindNextPage(CurPage: TCDTabSheet; GoForward, CheckTabVisible: boolean): TCDTabSheet; var I, TempStartIndex: integer; begin if FTabs.Count <> 0 then begin //StartIndex := FPages.IndexOfObject(CurPage); TempStartIndex := FTabs.IndexOfObject(CurPage); if TempStartIndex = -1 then if GoForward then TempStartIndex := FTabs.Count - 1 else TempStartIndex := 0; I := TempStartIndex; repeat if GoForward then begin Inc(I); if I = FTabs.Count then I := 0; end else begin if I = 0 then I := FTabs.Count; Dec(I); end; Result := TCDTabSheet(FTabs.Objects[I]); 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); ControlStyle := ControlStyle - [csAcceptsControls]; end; destructor TCDPageControl.Destroy; begin inherited Destroy; end; procedure TCDPageControl.SetActivePage(Value: TCDTabSheet); var i: integer; CurPage: TCDTabSheet; begin for i := 0 to FTabs.Count - 1 do begin CurPage := TCDTabSheet(FTabs.Objects[i]); if CurPage = Value then begin PositionTabSheet(CurPage); CurPage.BringToFront; CurPage.Visible := True; // Check first, Tab is Visible? FTabIndex := i; end else if CurPage <> nil then begin //CurPage.Align := alNone; //CurPage.Height := 0; CurPage.Visible := False; end; end; Invalidate; end; procedure TCDPageControl.SetPageIndex(Value: integer); begin if (Value > -1) and (Value < FTabs.Count) then begin FTabIndex := Value; ActivePage := GetPage(Value); end; end; procedure TCDPageControl.UpdateAllDesignerFlags; var i: integer; begin for i := 0 to FTabs.Count - 1 do UpdateDesignerFlags(i); end; procedure TCDPageControl.UpdateDesignerFlags(APageIndex: integer); var CurPage: TCDTabSheet; begin CurPage := GetPage(APageIndex); if APageIndex <> fTabIndex then CurPage.ControlStyle := CurPage.ControlStyle + [csNoDesignVisible] else CurPage.ControlStyle := CurPage.ControlStyle - [csNoDesignVisible]; end; procedure TCDPageControl.PositionTabSheet(ATabSheet: TCDTabSheet); var lTabHeight, lIndex: Integer; begin // ATabSheet.SetBounds(1, 32 + 1, Width - 3, Height - 32 - 4); lIndex := FTabs.IndexOfObject(ATabSheet);; lTabHeight := TCDCustomTabControlDrawer(FCurrentDrawer).GetTabHeight(lIndex); ATabSheet.BorderSpacing.Top := lTabHeight; ATabSheet.BorderSpacing.Left := 2; ATabSheet.BorderSpacing.Right := 3; ATabSheet.BorderSpacing.Bottom := 3; ATabSheet.Align := alClient; end; function TCDPageControl.GetActivePage: TCDTabSheet; begin Result := GetPage(FTabIndex); end; function TCDPageControl.GetPageCount: integer; begin Result := FTabs.Count; end; function TCDPageControl.GetPageIndex: integer; begin Result := FTabIndex; end; end.