Программирование на 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;

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