{ Copyright (C) 2011 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 customdrawncontrols; {$mode objfpc}{$H+} interface uses // FPC Classes, SysUtils, contnrs, Math, types, // fpimage fpcanvas, fpimgcanv, fpimage, // LCL -> Use only TForm, TWinControl, TCanvas, TLazIntfImage Graphics, Controls, LCLType, LCLIntf, IntfGraphics, LMessages, Messages, LCLProc, Forms, // Other LCL units are only for types StdCtrls, ExtCtrls, ComCtrls, // customdrawnutils; const CDDRAWSTYLE_COUNT = 12; TCDEDIT_LEFT_TEXT_SPACING = $400; TCDEDIT_RIGHT_TEXT_SPACING = $401; type TCDDrawStyle = ( // The default is given by the DefaultStyle global variable dsDefault = 0, // Operating system styles dsWinCE, dsWin2000, dsWinXP, dsKDE, dsGNOME, dsMacOSX, dsAndroid, // Other special styles for the user dsExtra1, dsExtra2, dsExtra3, dsExtra4 ); 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); virtual; function GetClientRect: TRect; override; // mouse procedure MouseEnter; override; procedure MouseLeave; override; // property DrawStyle: TCDDrawStyle read FDrawStyle write SetDrawStyle; public // state information IsMouseOver: Boolean; // procedure EraseBackground(DC: HDC); override; procedure Paint; override; end; TCDControlClass = class of TCDControl; { TCDControlDrawer } TCDControlDrawer = class public function GetClientRect(AControl: TCDControl): TRect; virtual; function GetMeasures(AMeasureID: Integer): Integer; virtual; function GetColor(AColorID: Integer): TColor; virtual; procedure DrawToIntfImage(ADest: TFPImageCanvas; AControl: TCDControl); virtual; procedure DrawToCanvas(ADest: TCanvas; AControl: TCDControl); virtual; end; // =================================== // Standard Tab // =================================== TCDButtonControl = class(TCDControl) private // button state FIsDown: Boolean; protected // 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(); virtual; procedure DoButtonUp(); virtual; procedure RealSetText(const Value: TCaption); override; public // button state property IsDown: Boolean read FIsDown write FIsDown; end; { TCDButton } TCDButton = class(TCDButtonControl) private procedure PrepareCurrentDrawer(); override; protected public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; published property Action; property Anchors; property Caption; property Color; property Constraints; property DrawStyle; 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); virtual; abstract; end; { TCDEdit } TCDEdit = class(TCDControl) private FCaretTimer: TTimer; procedure HandleCaretTimer(Sender: TObject); procedure DoDeleteSelection; procedure DoManageVisibleTextStart; procedure PrepareCurrentDrawer(); override; function GetText: string; procedure SetText(AValue: string); protected // keyboard procedure DoEnter; override; procedure DoExit; override; procedure KeyDown(var Key: word; Shift: TShiftState); override; procedure KeyUp(var Key: word; Shift: TShiftState); override; procedure UTF8KeyPress(var UTF8Key: TUTF8Char); 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 // State information FDragDropStarted: boolean; FCaretIsVisible: Boolean; FCaretPos: Integer; // zero-based position FSelStart: Integer; // zero-based position FSelLength: Integer; // zero means no selection. Negative numbers selection to the left from the start and positive ones to the right FVisibleTextStart: Integer; // 1-based constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property Color; property TabStop default True; property Text: string read GetText write SetText; end; { TCDEditDrawer } TCDEditDrawer = class(TCDControlDrawer) public function GetVisibleCharCount(CDEdit: TCDEdit): Integer; virtual; end; {@@ TCDGroupBox is a custom-drawn group box control } { TCDGroupBox } TCDGroupBox = class(TCDControl) private procedure PrepareCurrentDrawer(); override; procedure SetDrawStyle(const AValue: TCDDrawStyle); override; protected procedure RealSetText(const Value: TCaption); override; // to update on caption changes public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EraseBackground(DC: HDC); override; procedure Paint; override; published property DrawStyle; property Caption; property TabStop default False; end; { TCDGroupBoxDrawer } TCDGroupBoxDrawer = class(TCDControlDrawer) public procedure SetClientRectPos(CDGroupBox: TCDGroupBox); virtual; abstract; procedure DrawToIntfImage(ADest: TFPImageCanvas; CDGroupBox: TCDGroupBox); virtual; abstract; procedure DrawToCanvas(ADest: TCanvas; CDGroupBox: TCDGroupBox); virtual; abstract; end; { TCDCheckBox } TCDCheckBox = class(TCDButtonControl) private FAllowGrayed: Boolean; FCheckedState: TCheckBoxState; procedure PrepareCurrentDrawer(); override; protected procedure DoButtonUp(); override; procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EraseBackground(DC: HDC); override; procedure Paint; override; published property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default False; property DrawStyle; property Caption; property TabStop default True; property State: TCheckBoxState read FCheckedState write FCheckedState default cbUnchecked; end; { TCDCheckBoxDrawer } TCDCheckBoxDrawer = class(TCDControlDrawer) public procedure CalculatePreferredSize(CDCheckBox: TCDCheckBox; var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean); virtual; abstract; procedure DrawToIntfImage(ADest: TFPImageCanvas; CDCheckBox: TCDCheckBox); virtual; abstract; procedure DrawToCanvas(ADest: TCanvas; CDCheckBox: TCDCheckBox); virtual; abstract; end; // =================================== // Common Controls Tab // =================================== {@@ TCDTrackBar is a custom-drawn trackbar control } { TCDTrackBar } TCDTrackBar = class(TCDControl) private DragDropStarted: boolean; // fields FMin: integer; FMax: integer; FPosition: integer; FOnChange: TNotifyEvent; procedure PrepareCurrentDrawer(); override; 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(TCDControlDrawer) public procedure DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage; CDTrackBar: TCDTrackBar); virtual; abstract; procedure GetGeometry(var ALeftBorder, ARightBorder: Integer); virtual; abstract; end; { TCDListView } TCDListView = class(TCDControl) private DragDropStarted: boolean; // fields procedure PrepareCurrentDrawer(); override; protected // 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 TabStop default True; end; TCDListViewDrawer = class(TCDControlDrawer) public procedure DrawToIntfImage(ADest: TFPImageCanvas; CDListView: TCDListView); virtual; abstract; procedure DrawToCanvas(ADest: TCanvas; CDListView: TCDListView); virtual; abstract; end; {TCDTabControl} { TCDCustomTabControl } TCDCustomTabControl = class; { TCDCustomTabSheet } TCDCustomTabSheet = class(TCustomControl) private CDTabControl: TCDCustomTabControl; FTabVisible: Boolean; protected procedure RealSetText(const Value: TCaption); override; // to update on caption changes public destructor Destroy; override; property TabVisible: Boolean read FTabVisible write FTabVisible; end; TCDCustomTabControl = class(TCDControl) private FTabIndex: Integer; FTabs: TStringList; FOnChanging: TNotifyEvent; FOnChange: TNotifyEvent; 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 procedure Paint; override; procedure CorrectTabIndex(); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetTabCount: Integer; property Tabs: TStringList read FTabs write SetTabs; property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; property OnChange: TNotifyEvent read FOnChange write FOnChange; property TabIndex: integer read FTabIndex write SetTabIndex; end; { TCDCustomTabControlDrawer } TCDCustomTabControlDrawer = class(TCDControlDrawer) public function GetPageIndexFromXY(x, y: integer): integer; virtual; abstract; function GetTabHeight(AIndex: Integer; CDTabControl: TCDCustomTabControl): Integer; virtual; abstract; function GetTabWidth(ADest: TCanvas; AIndex: Integer; CDTabControl: TCDCustomTabControl): Integer; virtual; abstract; procedure DrawToIntfImage(ADest: TFPImageCanvas; FPImg: TLazIntfImage; CDTabControl: TCDCustomTabControl); virtual; abstract; procedure DrawToCanvas(ADest: TCanvas; CDTabControl: TCDCustomTabControl); virtual; abstract; procedure DrawTabSheet(ADest: TCanvas; CDTabControl: TCDCustomTabControl); virtual; abstract; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer; CDTabControl: TCDCustomTabControl); virtual; abstract; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer; CDTabControl: TCDCustomTabControl); virtual; abstract; end; // TTabSelectedEvent = procedure(Sender: TObject; ATab: TTabItem; // ASelected: boolean) of object; TCDTabControl = class(TCDCustomTabControl) published property Color; property Font; property Tabs; property TabIndex; property OnChanging; property OnChange; 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 } TCDPageControl = class(TCDCustomTabControl) private FOptions: TNoteBookOptions; function GetActivePage: TCDTabSheet; function GetPageCount: integer; function GetPageIndex: integer; procedure SetActivePage(Value: TCDTabSheet); procedure SetOptions(AValue: TNoteBookOptions); procedure SetPageIndex(Value: integer); procedure UpdateAllDesignerFlags; procedure UpdateDesignerFlags(APageIndex: integer); procedure PositionTabSheet(ATabSheet: TCDTabSheet); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; 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; // Used by the property editor in customdrawnextras function FindNextPage(CurPage: TCDTabSheet; GoForward, CheckTabVisible: boolean): TCDTabSheet; procedure SelectNextPage(GoForward: boolean; CheckTabVisible: boolean = True); published property ActivePage: TCDTabSheet read GetActivePage write SetActivePage; property DrawStyle; property Caption; property Color; property Font; property PageIndex: integer read GetPageIndex write SetPageIndex; property Options: TNoteBookOptions read FOptions write SetOptions; property ParentColor; property ParentFont; property TabStop default True; property TabIndex; property OnChanging; property OnChange; end; // Standard Tab procedure RegisterButtonDrawer(ADrawer: TCDButtonDrawer; AStyle: TCDDrawStyle); procedure RegisterEditDrawer(ADrawer: TCDEditDrawer; AStyle: TCDDrawStyle); procedure RegisterGroupBoxDrawer(ADrawer: TCDGroupBoxDrawer; AStyle: TCDDrawStyle); procedure RegisterCheckBoxDrawer(ADrawer: TCDCheckBoxDrawer; AStyle: TCDDrawStyle); // Common Controls Tab procedure RegisterTrackBarDrawer(ADrawer: TCDTrackBarDrawer; AStyle: TCDDrawStyle); procedure RegisterListViewDrawer(ADrawer: TCDListViewDrawer; AStyle: TCDDrawStyle); procedure RegisterCustomTabControlDrawer(ADrawer: TCDCustomTabControlDrawer; AStyle: TCDDrawStyle); var DefaultStyle: TCDDrawStyle = dsWinCE; // For now default to the most complete one, later per platform implementation resourcestring sTABSHEET_DEFAULT_NAME = 'CTabSheet'; var // Standard Tab RegisteredButtonDrawers: array[TCDDrawStyle] of TCDButtonDrawer = (nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil); RegisteredEditDrawers: array[TCDDrawStyle] of TCDEditDrawer = (nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil); RegisteredGroupBoxDrawers: array[TCDDrawStyle] of TCDGroupBoxDrawer = (nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil); RegisteredCheckBoxDrawers: array[TCDDrawStyle] of TCDCheckBoxDrawer = (nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil); // Common Controls Tab RegisteredTrackBarDrawers: array[TCDDrawStyle] of TCDTrackBarDrawer = (nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil); RegisteredListViewDrawers: array[TCDDrawStyle] of TCDListViewDrawer = (nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil); RegisteredCustomTabControlDrawers: array[TCDDrawStyle] of TCDCustomTabControlDrawer = (nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil); procedure RegisterButtonDrawer(ADrawer: TCDButtonDrawer; AStyle: TCDDrawStyle); begin if RegisteredButtonDrawers[AStyle] <> nil then RegisteredButtonDrawers[AStyle].Free; RegisteredButtonDrawers[AStyle] := ADrawer; end; procedure RegisterEditDrawer(ADrawer: TCDEditDrawer; AStyle: TCDDrawStyle); begin if RegisteredEditDrawers[AStyle] <> nil then RegisteredEditDrawers[AStyle].Free; RegisteredEditDrawers[AStyle] := ADrawer; end; procedure RegisterGroupBoxDrawer(ADrawer: TCDGroupBoxDrawer; AStyle: TCDDrawStyle); begin if RegisteredGroupBoxDrawers[AStyle] <> nil then RegisteredGroupBoxDrawers[AStyle].Free; RegisteredGroupBoxDrawers[AStyle] := ADrawer; end; procedure RegisterCheckBoxDrawer(ADrawer: TCDCheckBoxDrawer; AStyle: TCDDrawStyle); begin if RegisteredCheckBoxDrawers[AStyle] <> nil then RegisteredCheckBoxDrawers[AStyle].Free; RegisteredCheckBoxDrawers[AStyle] := ADrawer; end; procedure RegisterTrackBarDrawer(ADrawer: TCDTrackBarDrawer; AStyle: TCDDrawStyle); begin if RegisteredTrackBarDrawers[AStyle] <> nil then RegisteredTrackBarDrawers[AStyle].Free; RegisteredTrackBarDrawers[AStyle] := ADrawer; end; procedure RegisterListViewDrawer(ADrawer: TCDListViewDrawer; AStyle: TCDDrawStyle); begin if RegisteredListViewDrawers[AStyle] <> nil then RegisteredListViewDrawers[AStyle].Free; RegisteredListViewDrawers[AStyle] := ADrawer; end; procedure RegisterCustomTabControlDrawer(ADrawer: TCDCustomTabControlDrawer; AStyle: TCDDrawStyle); begin if RegisteredCustomTabControlDrawers[AStyle] <> nil then RegisteredCustomTabControlDrawers[AStyle].Free; RegisteredCustomTabControlDrawers[AStyle] := ADrawer; end; { TCDControlDrawer } function TCDControlDrawer.GetClientRect(AControl: TCDControl): TRect; begin Result := AControl.BoundsRect; end; function TCDControlDrawer.GetMeasures(AMeasureID: Integer): Integer; begin end; function TCDControlDrawer.GetColor(AColorID: Integer): TColor; begin end; procedure TCDControlDrawer.DrawToIntfImage(ADest: TFPImageCanvas; AControl: TCDControl); begin end; procedure TCDControlDrawer.DrawToCanvas(ADest: TCanvas; AControl: TCDControl); begin end; { TCDEditDrawer } function TCDEditDrawer.GetVisibleCharCount(CDEdit: TCDEdit): Integer; var lMaxWidth: Integer; lText, lLastSearchedText: String; begin { lText := CDEdit.Text; lText := Copy(lText, CDEdit.FVisibleTextStart, Length(lText)); lMaxWidth := CDEdit.Width - GetMeasures(TCDEDIT_LEFT_TEXT_SPACING) - GetMeasures(TCDEDIT_RIGHT_TEXT_SPACING); // First the simplest case: less chars are to the right then the width of the control if CDEdit.Canvas.TextWidth(lText) <= lMaxWidth then Exit(Length(lText)); // Now the more complex case lLastSearchedText := ''; while lLastSearchedText <> lText do begin lLastSearchedText := lText; lTextWidth := CDEdit.Canvas.TextWidth(lText); if lTextWidth < lMaxWidth then lText := Copy(lLastSearchedText, 1, Length(lLastSearchedText) div 2) else if lTextWidth > lMaxWidth then lText := Copy(lLastSearchedText, 1, Length(lLastSearchedText) div 2) else Exit(Length(lText)); end;} end; { TCDListView } procedure TCDListView.PrepareCurrentDrawer; var lDrawStyle: TCDDrawStyle; begin if DrawStyle = dsDefault then lDrawStyle := DefaultStyle else lDrawStyle := DrawStyle; FCurrentDrawer := RegisteredListViewDrawers[lDrawStyle]; if FCurrentDrawer = nil then FCurrentDrawer := RegisteredListViewDrawers[dsWince]; if FCurrentDrawer = nil then raise Exception.Create('No registered list view drawers were found'); end; procedure TCDListView.DoEnter; begin inherited DoEnter; end; procedure TCDListView.DoExit; begin inherited DoExit; end; procedure TCDListView.KeyDown(var Key: word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); end; procedure TCDListView.KeyUp(var Key: word; Shift: TShiftState); begin inherited KeyUp(Key, Shift); end; procedure TCDListView.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin inherited MouseDown(Button, Shift, X, Y); end; procedure TCDListView.MouseMove(Shift: TShiftState; X, Y: integer); begin inherited MouseMove(Shift, X, Y); end; procedure TCDListView.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin inherited MouseUp(Button, Shift, X, Y); end; procedure TCDListView.MouseEnter; begin inherited MouseEnter; end; procedure TCDListView.MouseLeave; begin inherited MouseLeave; end; constructor TCDListView.Create(AOwner: TComponent); begin inherited Create(AOwner); end; destructor TCDListView.Destroy; begin inherited Destroy; end; procedure TCDListView.EraseBackground(DC: HDC); begin inherited EraseBackground(DC); end; procedure TCDListView.Paint; begin inherited Paint; end; { TCDEdit } function TCDEdit.GetText: string; begin Result := Caption; end; procedure TCDEdit.HandleCaretTimer(Sender: TObject); begin FCaretIsVisible := not FCaretIsVisible; Invalidate; end; procedure TCDEdit.DoDeleteSelection; begin FSelStart := 1; FSelLength := 0; end; procedure TCDEdit.DoManageVisibleTextStart; var lTextWidth: Integer; begin // Moved to the left and we need to adjust the text start FVisibleTextStart := Min(FCaretPos+1, FVisibleTextStart); // Moved to the right and we need to adjust the text start // lTextWidth := TCDEditDrawer(FCurrentDrawer).GetVisibleCharCount(Self); // FVisibleTextStart := Max(FCaretPos-lTextWidth, FVisibleTextStart); end; procedure TCDEdit.PrepareCurrentDrawer; var lDrawStyle: TCDDrawStyle; begin if DrawStyle = dsDefault then lDrawStyle := DefaultStyle else lDrawStyle := DrawStyle; FCurrentDrawer := RegisteredEditDrawers[lDrawStyle]; if FCurrentDrawer = nil then FCurrentDrawer := RegisteredEditDrawers[dsWince]; if FCurrentDrawer = nil then raise Exception.Create('No registered edit drawers were found'); end; procedure TCDEdit.SetText(AValue: string); begin Caption := AValue; end; procedure TCDEdit.DoEnter; begin inherited DoEnter; FCaretTimer.Enabled := True; FCaretIsVisible := True; Invalidate; end; procedure TCDEdit.DoExit; begin inherited DoExit; FCaretTimer.Enabled := False; FCaretIsVisible := False; Invalidate; end; procedure TCDEdit.KeyDown(var Key: word; Shift: TShiftState); var lLeftText, lRightText, lOldText: String; begin inherited KeyDown(Key, Shift); lOldText := Text; case Key of // Backspace VK_BACK: begin // Selection backspace if FSelLength > 0 then DoDeleteSelection() // Normal backspace else if FCaretPos > 0 then begin lLeftText := Copy(lOldText, 1, FCaretPos-1); lRightText := Copy(lOldText, FCaretPos+1, Length(lOldText)); Text := lLeftText + lRightText; Dec(FCaretPos); DoManageVisibleTextStart(); Invalidate; end; end; // DEL VK_DELETE: begin // Selection delete if FSelLength > 0 then DoDeleteSelection() // Normal delete else if FCaretPos < Length(lOldText) then begin lLeftText := Copy(lOldText, 1, FCaretPos); lRightText := Copy(lOldText, FCaretPos+2, Length(lOldText)); Text := lLeftText + lRightText; Invalidate; end; end; VK_LEFT: begin if (FCaretPos > 0) then begin // Selecting to the left if ssShift in Shift then begin Dec(FSelLength); if FSelStart < 0 then FSelStart := FCaretPos; end // Normal move to the left else FSelLength := 0; Dec(FCaretPos); DoManageVisibleTextStart(); FCaretIsVisible := True; Invalidate; end; end; VK_RIGHT: begin if FCaretPos < Length(lOldText) then begin // Selecting to the right if ssShift in Shift then begin Inc(FSelLength); if FSelStart < 0 then FSelStart := FCaretPos; end // Normal move to the right else FSelLength := 0; Inc(FCaretPos); DoManageVisibleTextStart(); FCaretIsVisible := True; Invalidate; end; end; end; // case end; procedure TCDEdit.KeyUp(var Key: word; Shift: TShiftState); begin inherited KeyUp(Key, Shift); end; procedure TCDEdit.UTF8KeyPress(var UTF8Key: TUTF8Char); var lLeftText, lRightText, lOldText: String; begin inherited UTF8KeyPress(UTF8Key); // LCL Carbon sends Backspace as a UTF-8 Char // Don't handle it here because it is already handled in KeyDown if UTF8Key = #8 then Exit; DoDeleteSelection; // Normal characters lOldText := Text; lLeftText := Copy(lOldText, 1, FCaretPos); lRightText := Copy(lOldText, FCaretPos+1, Length(lOldText)); Text := lLeftText + UTF8Key + lRightText; Inc(FCaretPos); FCaretIsVisible := True; Invalidate; end; procedure TCDEdit.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin inherited MouseDown(Button, Shift, X, Y); end; procedure TCDEdit.MouseMove(Shift: TShiftState; X, Y: integer); begin inherited MouseMove(Shift, X, Y); end; procedure TCDEdit.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin inherited MouseUp(Button, Shift, X, Y); end; procedure TCDEdit.MouseEnter; begin inherited MouseEnter; end; procedure TCDEdit.MouseLeave; begin inherited MouseLeave; end; constructor TCDEdit.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 100; Height := 30; TabStop := True; ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csReplicatable]; // State information FVisibleTextStart := 1; FSelStart := -1; // Caret code FCaretTimer := TTimer.Create(Self); FCaretTimer.OnTimer := @HandleCaretTimer; FCaretTimer.Interval := 500; FCaretTimer.Enabled := False; DrawStyle := dsWinCE; PrepareCurrentDrawer(); end; destructor TCDEdit.Destroy; begin inherited Destroy; end; { TCDCheckBox } procedure TCDCheckBox.PrepareCurrentDrawer; var lDrawStyle: TCDDrawStyle; begin if DrawStyle = dsDefault then lDrawStyle := DefaultStyle else lDrawStyle := DrawStyle; FCurrentDrawer := RegisteredCheckBoxDrawers[lDrawStyle]; if FCurrentDrawer = nil then FCurrentDrawer := RegisteredCheckBoxDrawers[dsWince]; if FCurrentDrawer = nil then raise Exception.Create('No registered check box drawers were found'); end; procedure TCDCheckBox.DoButtonUp; begin inherited DoButtonUp; if AllowGrayed then begin case FCheckedState of cbUnchecked: FCheckedState := cbGrayed; cbGrayed: FCheckedState := cbChecked; else FCheckedState := cbUnchecked; end; end else begin if FCheckedState in [cbUnchecked, cbGrayed] then FCheckedState := cbChecked else FCheckedState := cbUnchecked; end; Invalidate; end; procedure TCDCheckBox.CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean); begin TCDCheckBoxDrawer(FCurrentDrawer).CalculatePreferredSize( Self, PreferredWidth, PreferredHeight, WithThemeSpace) end; constructor TCDCheckBox.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 75; Height := 17; TabStop := True; ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csReplicatable]; AutoSize := True; DrawStyle := dsWinXP; PrepareCurrentDrawer(); end; destructor TCDCheckBox.Destroy; begin inherited Destroy; end; procedure TCDCheckBox.EraseBackground(DC: HDC); begin end; procedure TCDCheckBox.Paint; var AImage: TLazIntfImage = nil; ABmp: TBitmap = nil; lCanvas: TFPImageCanvas = nil; begin 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 TCDCheckBoxDrawer(FCurrentDrawer).DrawToIntfImage(lCanvas, Self); ABmp.LoadFromIntfImage(AImage); // Second step of the drawing: LCL TCustomCanvas for easy font access TCDCheckBoxDrawer(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; { TCDCustomTabSheet } procedure TCDCustomTabSheet.RealSetText(const Value: TCaption); var lIndex: Integer; begin inherited RealSetText(Value); lIndex := CDTabControl.Tabs.IndexOfObject(Self); if lIndex >= 0 then CDTabControl.Tabs.Strings[lIndex] := Value; CDTabControl.Invalidate; end; 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; { TCDCustomTabControl } procedure TCDCustomTabControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin TCDCustomTabControlDrawer(FCurrentDrawer).MouseDown(Button, Shift, X, Y, Self); inherited MouseDown(Button, Shift, X, Y); end; procedure TCDCustomTabControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin TCDCustomTabControlDrawer(FCurrentDrawer).MouseUp(Button, Shift, X, Y, Self); inherited MouseUp(Button, Shift, X, Y); end; procedure TCDCustomTabControl.PrepareCurrentDrawer; var lDrawStyle: TCDDrawStyle; begin if DrawStyle = dsDefault then lDrawStyle := DefaultStyle else lDrawStyle := DrawStyle; FCurrentDrawer := RegisteredCustomTabControlDrawers[lDrawStyle]; if FCurrentDrawer = nil then FCurrentDrawer := RegisteredCustomTabControlDrawers[dsWince]; if FCurrentDrawer = nil then raise Exception.Create('No registered custom tab control drawers were found'); end; procedure TCDCustomTabControl.SetTabIndex(AValue: Integer); begin if FTabIndex = AValue then Exit; if Assigned(OnChanging) then OnChanging(Self); FTabIndex := AValue; if Assigned(OnChange) then OnChange(Self); 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; FDrawStyle := dsWinCE; PrepareCurrentDrawer(); 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, Self); ABmp.LoadFromIntfImage(AImage); ABmp.Canvas.Font.Assign(Font); TCDCustomTabControlDrawer(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; function TCDCustomTabControl.GetTabCount: Integer; begin Result := 0; if FTabs <> nil then Result := FTabs.Count; end; procedure TCDCustomTabControl.CorrectTabIndex; begin if FTabIndex >= FTabs.Count then SetTabIndex(FTabs.Count - 1); 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; procedure TCDControl.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; procedure TCDControl.MouseEnter; begin IsMouseOver := True; inherited MouseEnter; end; procedure TCDControl.MouseLeave; begin IsMouseOver := True; inherited MouseLeave; 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 TCDButtonControl.DoEnter; begin Invalidate; inherited DoEnter; end; procedure TCDButtonControl.DoExit; begin Invalidate; inherited DoExit; end; procedure TCDButtonControl.KeyDown(var Key: word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); if (Key = VK_SPACE) or (Key = VK_RETURN) then DoButtonDown(); end; procedure TCDButtonControl.KeyUp(var Key: word; Shift: TShiftState); begin if (Key = VK_SPACE) or (Key = VK_RETURN) then DoButtonUp(); inherited KeyUp(Key, Shift); end; procedure TCDButtonControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin if not Focused then SetFocus; DoButtonDown(); inherited MouseDown(Button, Shift, X, Y); end; procedure TCDButtonControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); begin DoButtonUp(); inherited MouseUp(Button, Shift, X, Y); end; procedure TCDButtonControl.MouseEnter; begin IsMouseOver := True; Invalidate; inherited MouseEnter; end; procedure TCDButtonControl.MouseLeave; begin IsMouseOver := False; Invalidate; inherited MouseLeave; end; procedure TCDButtonControl.DoButtonDown(); begin if not FIsDown then begin FIsDown := True; Invalidate; end; end; procedure TCDButtonControl.DoButtonUp(); begin if FIsDown then begin FIsDown := False; Invalidate; end; end; procedure TCDButtonControl.RealSetText(const Value: TCaption); begin inherited RealSetText(Value); Invalidate; end; procedure TCDButton.PrepareCurrentDrawer; var lDrawStyle: TCDDrawStyle; begin if DrawStyle = dsDefault then lDrawStyle := DefaultStyle else lDrawStyle := DrawStyle; FCurrentDrawer := RegisteredButtonDrawers[lDrawStyle]; if FCurrentDrawer = nil then FCurrentDrawer := RegisteredButtonDrawers[dsWince]; if FCurrentDrawer = nil then raise Exception.Create('No registered button drawers were found'); end; constructor TCDButton.Create(AOwner: TComponent); begin inherited Create(AOwner); TabStop := True; Width := 120; Height := 43; //Color := clTeal; ParentFont := True; Color := $00F1F5F5; FDrawStyle := dsAndroid; PrepareCurrentDrawer(); end; destructor TCDButton.Destroy; begin inherited Destroy; 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); Canvas.Draw(0, 0, ABmp); finally if lCanvas <> nil then lCanvas.Free; if AImage <> nil then AImage.Free; ABmp.Free; end; end; { TCDGroupBox } procedure TCDGroupBox.PrepareCurrentDrawer(); var lDrawStyle: TCDDrawStyle; begin if DrawStyle = dsDefault then lDrawStyle := DefaultStyle else lDrawStyle := DrawStyle; FCurrentDrawer := RegisteredGroupBoxDrawers[lDrawStyle]; if FCurrentDrawer = nil then FCurrentDrawer := RegisteredGroupBoxDrawers[dsWince]; if FCurrentDrawer = nil then raise Exception.Create('No registered group box drawers were found'); end; procedure TCDGroupBox.SetDrawStyle(const AValue: TCDDrawStyle); begin if FDrawStyle = AValue then exit; FDrawStyle := AValue; Invalidate; PrepareCurrentDrawer(); TCDGroupBoxDrawer(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; ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csDoubleClicks, csReplicatable]; DrawStyle := dsWinCE; PrepareCurrentDrawer(); 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 TCDGroupBoxDrawer(FCurrentDrawer).DrawToIntfImage(lCanvas, Self); ABmp.LoadFromIntfImage(AImage); // Second step of the drawing: LCL TCustomCanvas for easy font access TCDGroupBoxDrawer(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; { TCDTrackBar } procedure TCDTrackBar.PrepareCurrentDrawer; var lDrawStyle: TCDDrawStyle; begin if DrawStyle = dsDefault then lDrawStyle := DefaultStyle else lDrawStyle := DrawStyle; FCurrentDrawer := RegisteredTrackBarDrawers[lDrawStyle]; if FCurrentDrawer = nil then FCurrentDrawer := RegisteredTrackBarDrawers[dsWince]; if FCurrentDrawer = nil then raise Exception.Create('No registered track bar drawers were found'); end; 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 TCDTrackBarDrawer(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; DrawStyle := dsExtra1; PrepareCurrentDrawer(); 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 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 TCDTrackBarDrawer(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; { 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, CDTabControl); end; 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 SetTabIndex(FTabIndex-1); 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? SetTabIndex(i); end else if CurPage <> nil then begin //CurPage.Align := alNone; //CurPage.Height := 0; CurPage.Visible := False; end; end; Invalidate; end; procedure TCDPageControl.SetOptions(AValue: TNoteBookOptions); begin if FOptions=AValue then Exit; FOptions:=AValue; end; procedure TCDPageControl.SetPageIndex(Value: integer); begin if (Value > -1) and (Value < FTabs.Count) then begin SetTabIndex(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, Self); 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; var i: Integer; finalization // Free all drawers // Standard Tab for i := 0 to CDDRAWSTYLE_COUNT-1 do begin if RegisteredButtonDrawers[TCDDrawStyle(i)] <> nil then begin RegisteredButtonDrawers[TCDDrawStyle(i)].Free; RegisteredButtonDrawers[TCDDrawStyle(i)] := nil; end; end; for i := 0 to CDDRAWSTYLE_COUNT-1 do begin if RegisteredEditDrawers[TCDDrawStyle(i)] <> nil then begin RegisteredEditDrawers[TCDDrawStyle(i)].Free; RegisteredEditDrawers[TCDDrawStyle(i)] := nil; end; end; for i := 0 to CDDRAWSTYLE_COUNT-1 do begin if RegisteredGroupBoxDrawers[TCDDrawStyle(i)] <> nil then begin RegisteredGroupBoxDrawers[TCDDrawStyle(i)].Free; RegisteredGroupBoxDrawers[TCDDrawStyle(i)] := nil; end; end; for i := 0 to CDDRAWSTYLE_COUNT-1 do begin if RegisteredCheckBoxDrawers[TCDDrawStyle(i)] <> nil then begin RegisteredCheckBoxDrawers[TCDDrawStyle(i)].Free; RegisteredCheckBoxDrawers[TCDDrawStyle(i)] := nil; end; end; // Common Controls Tab for i := 0 to CDDRAWSTYLE_COUNT-1 do begin if RegisteredTrackBarDrawers[TCDDrawStyle(i)] <> nil then begin RegisteredTrackBarDrawers[TCDDrawStyle(i)].Free; RegisteredTrackBarDrawers[TCDDrawStyle(i)] := nil; end; end; for i := 0 to CDDRAWSTYLE_COUNT-1 do begin if RegisteredListViewDrawers[TCDDrawStyle(i)] <> nil then begin RegisteredListViewDrawers[TCDDrawStyle(i)].Free; RegisteredListViewDrawers[TCDDrawStyle(i)] := nil; end; end; for i := 0 to CDDRAWSTYLE_COUNT-1 do begin if RegisteredCustomTabControlDrawers[TCDDrawStyle(i)] <> nil then begin RegisteredCustomTabControlDrawers[TCDDrawStyle(i)].Free; RegisteredCustomTabControlDrawers[TCDDrawStyle(i)] := nil; end; end; end.