unit Unit1;
{$mode objfpc}{$H+}
interface
uses
windows,
Classes,
SysUtils,
Forms,
//CommCtrl,
Controls,
Graphics,
Dialogs,
ComCtrls, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
ImageList1: TImageList;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
TabSheet4: TTabSheet;
TabSheet5: TTabSheet;
procedure FormCreate(Sender: TObject);
procedure PageControl1DragDrop(Sender, Source: TObject; X, Y: Integer);
procedure PageControl1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure PageControl1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
//function GetDroppedIndex(X, Y: Integer): Integer;
//function GetTabIndex(APageControl:TPageControl;X, Y: Integer): Integer;
public
end;
var
Form1: TForm1;
implementation
uses CommCtrl;
{$R *.lfm}
{ TForm1 }
function GetTabIndex(APageControl:TPageControl;X, Y: Integer): Integer;
var TabRect: TRect;
begin
{Le résultat de cette fonction
nous donne l'index de l'onglet qui se trouve aux coordonnées X,Y
(le repère de référence étant la fenêtre du TPageControl)}
Result := APageControl.IndexOfTabAt(X,Y);
// Si la souris se trouve au dessus d'un onglet
if Result>-1 then
begin
// On récupère le rectangle de l'onglet visé
TabRect:=APageControl.TabRect(Result);
// Si on est dans la partie droite de ce rectangle
if x>((TabRect.Left+TabRect.Right) div 2)
// Alors l'index d'insertion est (Index de l'onglet visé)+1
then Inc(Result);
end;
end;
{ I have commented on this code because I cannot find a solution for "APageControl.Canvas" (ericktux 2021)
procedure DrawInsertionPoint(APageControl:TPageControl;X,Y:integer);
var TabRect: TRect;
TabIndex:integer;
X1,X2,Y1,Y2:integer;
begin
// On obtient l'index où serait éventuellement inséré notre onglet
TabIndex:=GetTabIndex(APageControl,x,y);
// La petite ligne indicatrice sera rouge
//APageControl.Canvas.Pen.Color:=clRed; // COMMENTED for me ericktux
if (TabIndex<APageControl.PageCount)
// Si l'onglet ne serait pas déposé en dernière place
then begin
// On prend les coordonnées du "rectangle" de dessin de l'onglet qu'il
// peut remplacer
TabRect:=APageControl.TabRect(TabIndex);
// À partir de là, on calcule les coordonnées (X1,Y1)--(X2,Y2) de
// notre ligne qui sera tracée sur son bord gauche
X1:=TabRect.Left;
X2:=X1;
Y1:=TabRect.Top;
Y2:=TabRect.Bottom;
end
// Si l'onglet serait déposé en dernière place (TabIndex<APageControl.PageCount)
else begin
// On prend les coordonnées du "rectangle" de dessin du dernier onglet
TabRect:=APageControl.TabRect(TabIndex-1);
// Puis on calcule les coordonnées (X1,Y1)--(X2,Y2) de
// notre ligne qui sera tracée sur son bord droit
X1:=TabRect.Right;
X2:=X1;
Y1:=TabRect.Top;
Y2:=TabRect.Bottom;
end;
// On trace notre petite ligne
//APageControl.Canvas.MoveTo(X1,Y1); // COMMENTED for me ericktux
//APageControl.Canvas.LineTo(X2,Y2); // COMMENTED for me ericktux
end;
}
// Procedure chargée de déposer un onglet à la fin d'un glissé-déposé
procedure DoTabDragDrop(Sender, Source: TPageControl; X,
Y: Integer);
const TCM_GETITEMRECT = $130A;
var i: Integer;
SourceIndex,TargetIndex:Integer;
ATabSheet:TTabSheet;
begin
if Sender=Source
// Si le glissé-déposé concerne un TPageControl sur lui même
then begin
{On détermine la nouvelle valeur d'index de l'onglet que l'on dépose}
TargetIndex:=GetTabIndex(Sender,x,y);
{Si on ne le dépose pas "dans le vide"}
if (TargetIndex>-1)
{L'onglet déposé, celui qui est actif (ActivePage), prend sa nouvelle
valeur d'index (PageIndex)}
then begin
// Si le nouvel index est supérieur à l'ancien index,
// on le décrémente, sinon l'onglet est "mal déplacé"
if (TargetIndex>Sender.ActivePage.PageIndex) then dec(TargetIndex);
Sender.ActivePage.PageIndex:=TargetIndex;
end;
end
// Si le glissé-déposé s'effectue entre deux TPageControl différents...
else begin
{On détermine l'index de l'onglet que l'on dépose}
SourceIndex:=Source.ActivePage.PageIndex;
{On détermine la nouvelle valeur d'index de l'onglet que l'on dépose}
TargetIndex:=GetTabIndex(Sender,x,y);
{Si on ne le dépose pas "dans le vide"}
if TargetIndex>-1 then
begin
// On récupère la référence de notre onglet
ATabSheet:=Source.Pages[SourceIndex];
// On l'affecte à son nouveau TPageControl
ATabSheet.PageControl:=Sender;
// Et on lui assigne son nouvel index
ATabSheet.PageIndex:=TargetIndex;
end;
end;
end;
// Événement OnMouseDown de votre TPageControl
// (début du glissé-déposé : on commence le glissement de l'onglet)
procedure TForm1.PageControl1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if (Sender is TPageControl)
{On active la fonctionnalité de glissé-déposé (Drag And Drop)
le paramètre "False" de la fonction BeginDrag() signifie que le pointeur
de la souris ne change pas et que le glissement ne commence que
lorsque l'utilisateur déplace la souris sur une courte distance (1 pixel).}
then (Sender as TPageControl).BeginDrag(False);
end;
// Événement OnDragDrop de votre TPageControl
// (fin du glissé-déposé : on dépose l'onglet)
procedure TForm1.PageControl1DragDrop(Sender, Source: TObject; X,
Y: Integer);
begin
if (Sender is TPageControl) and (Source is TPageControl) then
begin
// Utilisation de notre procedure chargée de déposer
// un onglet à la fin d'un glissé-déposé
DoTabDragDrop((Sender as TPageControl), (Source as TPageControl),X,Y);
{Fin du glissé-déposé --> passage de True en paramètre}
(Source as TPageControl).EndDrag(True);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
end;
// Événement OnDragOver de votre TPageControl
// (Le glissé-déposé est en train de se faire :
// la souris passe au-dessus du TPageControl)
procedure TForm1.PageControl1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
if (Sender is TPageControl) then
begin
//On redessine notre TPageControl (pour effacer notre ligne d'insertion)
(Sender as TPageControl).Repaint; // If you get "error exception" or "access violation" here you comment (ericktux 2021)
//Si la souris quitte notre cible de glissé-déposé on ignore ce qui suit
if State<>dsDragLeave
then begin
Accept := True;
//On dessine le point d'insertion
//DrawInsertionPoint((Sender as TPageControl),X,Y);
end;
end;
end;
end.
end.
Recent
