Программирование на Delphi

FAQ VCL
Компоненты\PageControl

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как динамически добавить закладку во время работы приложения?


procedure TForm1.Button1Click(Sender: TObject);
var
  NewControl: TTabSheet;
begin
  NewControl := TTabSheet.Create(Self);
  NewControl.Parent := Self;
  NewControl.Name := 'NewName';
  NewControl.Caption := 'NewCaption';
  NewControl.PageControl := PageControl1;
end;

Как перестроить вкладки TPageControl с помощью Drag and Drop?


// Способ первый
procedure TForm1.PageControl1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  PageControl1.BeginDrag(False);
end;

procedure TForm1.PageControl1DragDrop(Sender, Source: TObject; X,
  Y: Integer);
const 
  TCM_GETITEMRECT = $130A; 
var 
  i: Integer; 
  r: TRect; 
begin 
  if not (Sender is TPageControl) then
    Exit;

  with PageControl1 do
  begin
    for i := 0 to PageCount-1 do
    begin
      Perform(TCM_GETITEMRECT, i, LPARAM(@r));
      if PtInRect(r, Point(X, Y)) then
      begin
        if i <> ActivePage.PageIndex then
          ActivePage.PageIndex := i;
        Exit;
      end;
    end;
  end;
end;

procedure TForm1.PageControl1DragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
begin
  if Sender is TPageControl then
    Accept := True;
end;

// Способ второй
type
  TForm1 = class(TForm)
    {...}
  private
    StartInd: Integer;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  TCM_GETITEMRECT = $130A;

procedure TForm1.FormCreate(Sender: TObject);
begin
  StartInd := -1;
  PageControl1.DragMode := dmAutomatic;
  Mouse.DragImmediate := False;
end;

procedure TForm1.PageControl1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Sender is TPageControl;
end;

procedure TForm1.PageControl1EndDrag(Sender, Target: TObject; X, Y: Integer);
var
  Point: TPoint;
  Rect: TRect;
  i: Integer;
begin
  if (Sender is TPageControl) and (StartInd > -1) then
    with TPageControl(Sender) do
    begin
      Point := ScreenToClient(Mouse.CursorPos);
      for i := 0 to PageCount-1 do
      begin
        Perform(TCM_GETITEMRECT, i, LParam(@Rect));
        if PtInRect(Rect, Point) then
        begin
          Pages[StartInd].PageIndex := i;
          ActivePageIndex := i;
          Exit;
        end;
      end;
    end;
end;

procedure TForm1.PageControl1StartDrag(Sender: TObject;
  var DragObject: TDragObject);
var
  Point: TPoint;
  Rect: TRect;
  i: Integer;
begin
  StartInd:= -1;
  if Sender is TPageControl then
    with TPageControl(Sender) do
    begin
      Point := ScreenToClient(Mouse.CursorPos);
      for i := 0 to PageCount-1 do
      begin
        Perform(TCM_GETITEMRECT, i, LParam(@Rect));
        if PtInRect(Rect, Point) then
        begin
          StartInd := i;
          Exit;
        end;
      end;
    end;
end;

Как узнать, над какой закладкой находится курсор в TPageControl?


uses
  {...,} CommCtrl;

function ItemAtPos(PageControlHandle: HWND; x, y: Integer): Integer;
var
  HitTestInfo: TTCHitTestInfo;
  HitIndex: Integer;
begin
  HitTestInfo.pt.X := x;
  HitTestInfo.pt.Y := y;
  HitTestInfo.Flags := 0;
  HitIndex := SendMessage(PageControlHandle, TCM_HITTEST, 0, LongInt(@HitTestInfo));
  Result := HitIndex;
end;

procedure TForm1.PageControl1MouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
  Caption := IntToStr(ItemAtPos((Sender as TPageControl).Handle, X, Y));
end;

Как убрать поля в несколько пикселей по краям вкладки TPageControl?


// Способ первый
type
  TPageControl = class(Vcl.ComCtrls.TPageControl)
  protected
    procedure AdjustClientRect(var Rect: TRect); override;
  end;

  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    {...}
  end;

implementation

procedure TPageControl.AdjustClientRect(var Rect: TRect);
var
  Edge, Border: Integer;
begin
  inherited;

  Edge := GetSystemMetrics(SM_CYEDGE);
  Border := GetSystemMetrics(SM_CYBORDER);

  if not (csDesigning in ComponentState) then
  begin
    Rect.Top := TabRect(0).Height + Edge + Border;
    Rect.Left := Border;
    Rect.Right := Width - (Border * 2);
    Rect.Bottom := Height - (Border * 2);
  end;
end;

// Способ второй
uses
  {...,} Winapi.CommCtrl;

type
  TPageControl = class(Vcl.ComCtrls.TPageControl)
  private
    procedure TCMAdjustRect(var Msg: TMessage); message TCM_ADJUSTRECT;
  end;

  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    {...}
  end;

implementation

{ TPageControl }

procedure TPageControl.TCMAdjustRect(var Msg: TMessage);
begin
  inherited;

  if Msg.WParam = 0 then
    InflateRect(PRect(Msg.LParam)^, 4, 4)
  else
    InflateRect(PRect(Msg.LParam)^, -4, -4);
end;

// Способ третий
type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    procedure FormCreate(Sender: TObject);
  private
    FOriginalPageControlWndProc: TWndMethod;
    procedure PageControlWndProc(var Message: TMessage);
  public
  end;

implementation

{$R *.dfm}

uses
  {...,} Winapi.CommCtrl;

procedure TForm1.FormCreate(Sender: TObject);
begin
  with PageControl1 do
  begin
    FOriginalPageControlWndProc := WindowProc;
    WindowProc := PageControlWndProc;
    Realign;
  end;
end;

procedure TForm1.PageControlWndProc(var Message: TMessage);
begin
  FOriginalPageControlWndProc(Message);
  with Message do
    if (Msg = TCM_ADJUSTRECT) and (Message.WParam = 0) then
      InflateRect(PRect(LParam)^, 4, 4);
end;

Как скрыть заголовки вкладок у TPageControl?


uses
  {...,} Vcl.ComCtrls;

type
  TPageControl = class(Vcl.ComCtrls.TPageControl)
  private
    FHideTabs: Boolean;
    procedure SetHideTabs(const Value: boolean);
  protected
    procedure AdjustClientRect(var Rect: TRect); override;
  public
    constructor Create(AOwner: TComponent); override;
    property HideTabs: Boolean read FHideTabs write SetHideTabs default False;
    property Color;
    property ParentColor;
  end;

implementation

{ TPageControl }

constructor TPageControl.Create(AOwner: TComponent);
begin
  inherited;
  FHideTabs := False;
end;

procedure TPageControl.AdjustClientRect(var Rect: TRect);
begin
  inherited;
  if HideTabs and not (csDesigning in ComponentState) then
  begin
    Rect.Top := 0;
    Rect.Left := 0;
    Rect.Right := Width;
    Rect.Bottom := Height;
  end;
end;

procedure TPageControl.SetHideTabs(const Value: boolean);
begin
  if FHideTabs = Value then
    Exit;

  FHideTabs := Value;
  RecreateWnd;
end;

{ TForm1 }

// Скрыть вкладки
procedure TForm1.Button1Click(Sender: TObject);
begin
  PageControl1.HideTabs := True;
end;

// Показать вкладки
procedure TForm1.Button2Click(Sender: TObject);
begin
  PageControl1.HideTabs := False;
end;

Как добавить бордюр к TPageControl?


uses
  {...,} Vcl.ComCtrls;
  
type
  TPageControl = class(Vcl.ComCtrls.TPageControl)
  public
    property BevelEdges;
    property BevelInner;
    property BevelOuter;
    property BevelKind default bkNone;
    property BevelWidth;
  end;

implementation

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  PageControl1.BevelEdges := [beLeft, beTop, beRight, beBottom];
  PageControl1.BevelKind := bkSoft;
  PageControl1.BevelOuter := bvRaised;
  PageControl1.BevelWidth := 1;
end;

Как запретить переключение между вкладками в TPageControl?


procedure TForm1.PageControl1Changing(Sender: TObject;
  var AllowChange: Boolean);
begin
  AllowChange := False;
end;

Как определить количество рядов вкладок в TPageControl?


procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(PageControl1.RowCount));
end;

Как в TPageControl прокручивать вкладки колесом мыши без активации вкладок?


type
  TPageControl = class(Vcl.ComCtrls.TPageControl)
  private
    procedure WMMouseWheel(var Msg: TWMMouseWheel); message WM_MOUSEWHEEL;
    // или можно переопределить процедуру MouseWheelHandler
    // procedure MouseWheelHandler(var Message: TMessage); override;
  end;

implementation

uses
  {...,} Math;

procedure TPageControl.WMMouseWheel(var Msg: TWMMouseWheel);
{$DEFINE SCROLL_ONLY_HEADER} // Чтобы скролл работал только тогда,
                             // когда курсор мыши находится в
                             // области заголовков страниц
{$IFDEF SCROLL_ONLY_HEADER}
var
  Pt: TPoint;
{$ENDIF}
begin
  {$IFDEF SCROLL_ONLY_HEADER}
  Pt := Msg.Pos;
  Pt := ScreenToClient(Pt);
  {$ENDIF}

  inherited;

  {$IFDEF SCROLL_ONLY_HEADER}
  if (Pt.Y < 0) or (Pt.Y > RowCount * IfThen(TabHeight = 0, TabRect(0).Height, TabHeight)) then
    Exit;
  if (Pt.X < 0) or (Pt.X > Width) then
    Exit;
  {$ENDIF}

  ScrollTabs(Sign(Msg.WheelDelta) * -1);
end;

Как в TPageControl прокручивать вкладки колесом мыши с активацией вкладок?


type
  TPageControl = class(Vcl.ComCtrls.TPageControl)
  private
    procedure WMMouseWheel(var Msg: TWMMouseWheel); message WM_MOUSEWHEEL;
    // или можно переопределить процедуру MouseWheelHandler
    // procedure MouseWheelHandler(var Message: TMessage); override;
  end;

implementation

uses
  {...,} Math;

procedure TPageControl.WMMouseWheel(var Msg: TWMMouseWheel);
{$DEFINE SCROLL_ONLY_HEADER} // Чтобы скролл работал только тогда,
                             // когда курсор мыши находится в
                             // области заголовков страниц
const
{$J+}
  CanScrollForward: Boolean = True;
  CanScrollBackward: Boolean = False;
{$J-}
{$IFDEF SCROLL_ONLY_HEADER}
var
  Pt: TPoint;
{$ENDIF}
begin
  CanScrollForward := ActivePageIndex < PageCount-1;
  CanScrollBackward := ActivePageIndex > 0;

  {$IFDEF SCROLL_ONLY_HEADER}
  Pt := Msg.Pos;
  Pt := ScreenToClient(Pt);
  {$ENDIF}

  inherited;

  {$IFDEF SCROLL_ONLY_HEADER}
  if (Pt.Y < 0) or (Pt.Y > RowCount * IfThen(TabHeight = 0, TabRect(0).Height, TabHeight)) then
    Exit;
  if (Pt.X < 0) or (Pt.X > Width) then
    Exit;
  {$ENDIF}

  if Msg.WheelDelta < 0 then
  begin
    if CanScrollForward then
      SelectNextPage(True);
  end
  else
  begin
    if CanScrollBackward then
      SelectNextPage(False);
  end;
end;

При использовании материала - ссылка на сайт обязательна