unit TabControl;
interface
uses
SysUtils, Windows, Messages, Types, Classes, Controls, Graphics, Menus,
ActiveX, System.Win.ComObj, ShlObj;
var
CF_RTAB: TClipFormat;
CF_RTABDATA: TClipFormat;
const
CFSTR_RTABCTLTAB = 'RejbrandTabControlTab';
CFSTR_RTABCTLTABDATA = 'RejbrandTabControlTabData';
var
FORMATETC_RTABCTLTAB: TFormatEtc =
(
cfFormat: 0;
ptd: nil;
dwAspect: DVASPECT_CONTENT;
lindex: -1;
tymed: TYMED_HGLOBAL
);
FORMATETC_RTABCTLTABDATA: TFormatEtc =
(
cfFormat: 0;
ptd: nil;
dwAspect: DVASPECT_CONTENT;
lindex: -1;
tymed: TYMED_HGLOBAL;
);
type
PRTabInfo = ^TRTabInfo;
TRTabInfo = record
Len: integer;
Wnd: HWND;
Idx: integer;
TabName: array[0..1024] of char;
end;
TTabMovedEvent = procedure(Sender: TObject; TabIndex, InsertionPos: integer) of object;
TTabCanInsertEvent = procedure(Sender: TObject; const Data: pointer; const Len: UInt64;
InsertionPos: integer; var CanInsert: boolean) of object;
TTabInsertedEvent = procedure(Sender: TObject; const Data: pointer;
const Len: UInt64; InsertionPos: integer) of object;
TTabCanSendAwayEvent = procedure(Sender: TObject; TabIndex: integer;
var Data: pointer; var Len: UInt64; var CanSend: boolean) of object;
TTabSentAwayEvent = procedure(Sender: TObject; TabIndex: integer) of object;
TSimpleTabControl = class(TCustomControl, IDropTarget, IDropSource, IDataObject)
strict private type
TEnumFormatEtc = class(TInterfacedObject, IEnumFORMATETC)
strict private
FIndex: integer;
public
function Next(celt: Longint; out elt;
pceltFetched: PLongint): HResult; stdcall;
function Skip(celt: Longint): HResult; stdcall;
function Reset: HResult; stdcall;
function Clone(out Enum: IEnumFormatEtc): HResult; stdcall;
end;
private const
FMT_RTAB = 0;
FMT_RTABDATA = 1;
private class var
Formats: TFormatEtcArray;
private const
DEFAULT_PADDING = 4;
DEFAULT_TAB_WIDTH = 160;
DEFAULT_ACTIVE_TAB_COLOR = clWhite;
DEFAULT_ACTIVE_TAB_TEXT_COLOR = clBlack;
DEFAULT_BORDER_COLOR = clBlack;
DEFAULT_INACTIVE_TAB_COLOR = clBtnFace;
DEFAULT_INACTIVE_TAB_TEXT_COLOR = clBtnText;
private var
FItems: TStrings;
FColor: TColor;
FCurrentTabWidth: integer;
FDefaultTabWidth: integer;
FFont: TFont;
FActiveTabColor: TColor;
FInactiveTabColor: TColor;
FActiveTabTextColor: TColor;
FInactiveTabTextColor: TColor;
FActiveTab: integer;
FPadding: integer;
FOnChange: TNotifyEvent;
FClickFocuses: boolean;
FBorderColor: TColor;
FTabPopupMenu: TPopupMenu;
FOverflows: array of boolean;
FDragDataObj: IDataObject;
FDragCompatFmt: boolean;
FExpectDragDrop: boolean;
FDragTabIndex: integer;
FPrevCursorX, FPrevCursorY: integer;
FMouseDownX, FMouseDownY: integer;
FInsertionPoint: integer;
FOnTabMoved: TTabMovedEvent;
FOnTabCanInsert: TTabCanInsertEvent;
FOnTabInserted: TTabInsertedEvent;
FAllowReorder: boolean;
FAllowInsert: boolean;
FAllowSendAway: boolean;
FOnTabCanSendAwayEvent: TTabCanSendAwayEvent;
FOnTabSentAwayEvent: TTabSentAwayEvent;
FInternalDrop: boolean;
FXDRAG, FYDRAG: integer;
procedure ItemsChanged(Sender: TObject);
procedure SetColor(const Value: TColor);
procedure SetDefaultTabWidth(const Value: integer);
procedure SetFont(const Value: TFont);
procedure FontChanged(Sender: TObject);
procedure SetActiveTabColor(const Value: TColor);
procedure SetInactiveTabColor(const Value: TColor);
procedure SetActiveTabTextColor(const Value: TColor);
procedure SetInactiveTabTextColor(const Value: TColor);
procedure SetActiveTab(const Value: integer);
function GetTabRect(const TabIndex: integer): TRect;
function GetInsertionPointRect(AIndex: integer): TRect;
procedure SetItems(const Value: TStrings);
procedure SetPadding(const Value: integer);
procedure DoChange;
procedure SetBorderColor(const Value: TColor);
function UpdateTabWidth: boolean;
procedure DoTabMoved(TabIndex, InsertionPos: integer);
function GetMatchingFormatIdx(const AFormatEtc: TFormatEtc): integer;
procedure DoTabCanInsert(const Data: pointer; const Len: UInt64;
InsertionPos: integer; out CanInsert: boolean);
procedure DoTabInserted(const Data: pointer; const Len: UInt64;
InsertionPos: integer);
procedure DoTabCanSendAway(TabIndex: integer; out Data: pointer;
out Len: UInt64; out CanSend: boolean);
procedure DoTabSentAway(TabIndex: integer);
protected
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure WndProc(var Message: TMessage); override;
procedure CMEnabledchanged(var Message: TMessage);
message CM_ENABLEDCHANGED;
procedure WMContextMenu(var Message: TWMContextMenu);
message WM_CONTEXTMENU;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure CreateWnd; override;
procedure DestroyWnd; override;
procedure RemoveInsertionPoint;
procedure DrawInsertionPoint(const AIndex: integer);
function IDropTarget.DragEnter = DropTargetDragEnter;
function DropTargetDragEnter(const dataObj: IDataObject;
grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HRESULT;
stdcall;
function IDropTarget.DragOver = DropTargetDragOver;
function DropTargetDragOver(grfKeyState: Longint; pt: TPoint;
var dwEffect: Longint): HRESULT;
stdcall;
function IDropTarget.DragLeave = DropTargetDragLeave;
function DropTargetDragLeave: HRESULT;
stdcall;
function IDropTarget.Drop = DropTargetDrop;
function DropTargetDrop(const dataObj: IDataObject; grfKeyState:
Longint; pt: TPoint; var dwEffect: Longint): HRESULT; stdcall;
function GiveFeedback(dwEffect: Longint): HRESULT; stdcall;
function QueryContinueDrag(fEscapePRessed: BOOL; grfKeyState: Longint): HRESULT;
stdcall;
class function CreateHGlobal(Data: pointer; Len: UInt64; uFlags: DWORD;
out hGlobal: HGLOBAL): HRESULT; static;
function DAdvise(const formatetc: tagFORMATETC; advf: Integer;
const advSink: IAdviseSink; out dwConnection: Integer): HRESULT; stdcall;
function DUnadvise(dwConnection: Integer): HRESULT; stdcall;
function EnumDAdvise(out enumAdvise: IEnumSTATDATA): HRESULT; stdcall;
function EnumFormatEtc(dwDirection: Integer;
out enumFormatEtc: IEnumFORMATETC): HRESULT; stdcall;
function GetCanonicalFormatEtc(const formatetc: tagFORMATETC;
out formatetcOut: tagFORMATETC): HRESULT; stdcall;
function GetData(const formatetcIn: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT; stdcall;
function GetDataHere(const formatetc: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT; stdcall;
function QueryGetData(const formatetc: tagFORMATETC): HRESULT; stdcall;
function SetData(const formatetc: tagFORMATETC; var medium: tagSTGMEDIUM;
fRelease: LongBool): HRESULT; stdcall;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetTabAtPoint(const APoint: TPoint): integer;
function GetTabSepAtPoint(const APoint: TPoint): integer;
function MoveTab(TabIndex: integer; InsertionPos: integer): boolean;
function InsertExternalTab(TabControl: HWND; TabIndex: integer;
const TabName: string; dataObj: IDataObject; InsertionPos: integer): boolean;
published
property AllowReorder: boolean read FAllowReorder write FAllowReorder default false;
property AllowInsert: boolean read FAllowInsert write FAllowInsert default false;
property AllowSendAway: boolean read FAllowSendAway write FAllowSendAway default false;
property Align;
property Anchors;
property Cursor;
property Enabled;
property Margins;
property ClickFocuses: boolean read FClickFocuses write FClickFocuses default false;
property BorderColor: TColor read FBorderColor write SetBorderColor default DEFAULT_BORDER_COLOR;
property Items: TStrings read FItems write SetItems;
property Color: TColor read FColor write SetColor default clBtnFace;
property DefaultTabWidth: integer read FDefaultTabWidth write SetDefaultTabWidth default DEFAULT_TAB_WIDTH;
property Font: TFont read FFont write SetFont;
property InactiveTabColor: TColor read FInactiveTabColor write SetInactiveTabColor default DEFAULT_INACTIVE_TAB_COLOR;
property ActiveTabColor: TColor read FActiveTabColor write SetActiveTabColor default DEFAULT_ACTIVE_TAB_COLOR;
property InactiveTabTextColor: TColor read FInactiveTabTextColor write SetInactiveTabTextColor default DEFAULT_INACTIVE_TAB_TEXT_COLOR;
property ActiveTabTextColor: TColor read FActiveTabTextColor write SetActiveTabTextColor default DEFAULT_ACTIVE_TAB_TEXT_COLOR;
property ActiveTab: integer read FActiveTab write SetActiveTab default 0;
property Padding: integer read FPadding write SetPadding default DEFAULT_PADDING;
property PopupMenu;
property TabPopupMenu: TPopupMenu read FTabPopupMenu write FTabPopupMenu;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnTabMoved: TTabMovedEvent read FOnTabMoved write FOnTabMoved;
property OnTabCanInsert: TTabCanInsertEvent read FOnTabCanInsert write FOnTabCanInsert;
property OnTabInserted: TTabInsertedEvent read FOnTabInserted write FOnTabInserted;
property OnTabCanSendAway: TTabCanSendAwayEvent read FOnTabCanSendAwayEvent write FOnTabCanSendAwayEvent;
property OnTabSentAway: TTabSentAwayEvent read FOnTabSentAwayEvent write FOnTabSentAwayEvent;
property TabStop;
property TabOrder;
property OnClick;
property OnEnter;
property OnExit;
property OnMouseLeave;
property OnMouseEnter;
property OnMouseDown;
property OnMouseUp;
property OnKeyPress;
property OnKeyDown;
property OnKeyUp;
end;
procedure Register;
implementation
uses Math;
procedure Register;
begin
RegisterComponents('Rejbrand 2015', [TSimpleTabControl]);
end;
procedure TSimpleTabControl.CMEnabledchanged(var Message: TMessage);
begin
Invalidate;
end;
procedure TSimpleTabControl.CMHintShow(var Message: TCMHintShow);
var
TabIndex: integer;
begin
TabIndex := GetTabAtPoint(Message.HintInfo^.CursorPos);
if InRange(TabIndex, 0, FItems.Count - 1) and InRange(TabIndex, low(FOverflows), high(FOverflows)) then
begin
if FOverflows[TabIndex] then
begin
Message.HintInfo^.CursorRect := GetTabRect(TabIndex);
Message.HintInfo^.HintStr := FItems[TabIndex];
Message.HintInfo^.HideTimeout := 60000;
end;
end;
end;
constructor TSimpleTabControl.Create(AOwner: TComponent);
begin
inherited;
Width := 400;
Height := 32;
FInsertionPoint := -1;
FDragTabIndex := -1;
FClickFocuses := false;
FActiveTab := 0;
FPadding := DEFAULT_PADDING;
FBorderColor := DEFAULT_BORDER_COLOR;
FActiveTabColor := DEFAULT_ACTIVE_TAB_COLOR;
FInactiveTabColor := DEFAULT_INACTIVE_TAB_COLOR;
FActiveTabTextColor := DEFAULT_ACTIVE_TAB_TEXT_COLOR;
FInactiveTabTextColor := DEFAULT_INACTIVE_TAB_TEXT_COLOR;
FDefaultTabWidth := DEFAULT_TAB_WIDTH;
FColor := clBtnFace;
FFont := TFont.Create;
FFont.OnChange := FontChanged;
FItems := TStringList.Create;
TStringList(FItems).OnChange := ItemsChanged;
ShowHint := true;
OleInitialize(nil);
FXDRAG := Abs(GetSystemMetrics(SM_CXDRAG));
FYDRAG := Abs(GetSystemMetrics(SM_CYDRAG));
end;
class function TSimpleTabControl.CreateHGlobal(Data: pointer; Len: UInt64;
uFlags: DWORD; out hGlobal: HGLOBAL): HRESULT;
var
p: pointer;
begin
hGlobal := GlobalAlloc(uFlags, Len);
if hGlobal <> 0 then
begin
p := GlobalLock(hGlobal);
if Assigned(p) then
begin
CopyMemory(p, Data, Len);
GlobalUnlock(hGlobal);
end
else
begin
GlobalFree(hGlobal);
hGlobal := 0;
end;
end;
result := IfThen(hGlobal <> 0, S_OK, E_OUTOFMEMORY);
end;
procedure TSimpleTabControl.CreateWnd;
begin
inherited;
OleCheck(RegisterDragDrop(Handle, Self));
end;
function TSimpleTabControl.DAdvise(const formatetc: tagFORMATETC; advf: Integer;
const advSink: IAdviseSink; out dwConnection: Integer): HRESULT;
begin
result := OLE_E_ADVISENOTSUPPORTED;
end;
destructor TSimpleTabControl.Destroy;
begin
OleUninitialize;
FFont.Free;
FItems.Free;
inherited;
end;
procedure TSimpleTabControl.DestroyWnd;
begin
RevokeDragDrop(Handle);
inherited;
end;
procedure TSimpleTabControl.DoChange;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure TSimpleTabControl.DrawInsertionPoint(const AIndex: integer);
var
OldInsertionPoint: integer;
begin
if AIndex <> FInsertionPoint then
begin
OldInsertionPoint := FInsertionPoint;
FInsertionPoint := AIndex;
if OldInsertionPoint <> -1 then
InvalidateRect(Handle, GetInsertionPointRect(OldInsertionPoint), false);
InvalidateRect(Handle, GetInsertionPointRect(AIndex), false);
end;
end;
function TSimpleTabControl.DropTargetDragEnter(const dataObj: IDataObject;
grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HRESULT;
begin
FDragDataObj := dataObj;
FDragCompatFmt := dataObj.QueryGetData(FORMATETC_RTABCTLTAB) = S_OK;
if FDragCompatFmt then
dwEffect := dwEffect and DROPEFFECT_MOVE
else
dwEffect := DROPEFFECT_NONE;
result := S_OK;
end;
function TSimpleTabControl.DropTargetDragLeave: HRESULT;
begin
FDragCompatFmt := false;
FDragDataObj := nil;
result := S_OK;
RemoveInsertionPoint;
end;
function TSimpleTabControl.DropTargetDragOver(grfKeyState: Longint; pt: TPoint;
var dwEffect: Longint): HRESULT;
var
TabIndex: integer;
begin
if FDragCompatFmt then
dwEffect := dwEffect and DROPEFFECT_MOVE
else
dwEffect := DROPEFFECT_NONE;
result := S_OK;
TabIndex := GetTabSepAtPoint(ScreenToClient(pt));
if FDragCompatFmt then
DrawInsertionPoint(TabIndex);
end;
function TSimpleTabControl.DropTargetDrop(const dataObj: IDataObject;
grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HRESULT;
var
TabIndex: integer;
medium: TStgMedium;
TabRec: PRTabInfo;
begin
FDragCompatFmt := dataObj.QueryGetData(FORMATETC_RTABCTLTAB) = S_OK;
if FDragCompatFmt then
dwEffect := dwEffect and DROPEFFECT_MOVE
else
dwEffect := DROPEFFECT_NONE;
RemoveInsertionPoint;
case dwEffect of
DROPEFFECT_MOVE:
begin
result := E_UNEXPECTED;
if dataObj.GetData(FORMATETC_RTABCTLTAB, medium) = S_OK then
try
if medium.tymed = TYMED_HGLOBAL then
if GlobalSize(medium.hGlobal) >= sizeof(TRTabInfo) then
begin
TabRec := GlobalLock(medium.hGlobal);
if Assigned(TabRec) then
try
if TabRec.Len = sizeof(TRTabInfo) then
begin
TabIndex := GetTabSepAtPoint(ScreenToClient(pt));
if TabRec.Wnd = Self.Handle then
begin
if MoveTab(TabRec.Idx, TabIndex) then
begin
result := S_OK;
FInternalDrop := true;
end;
end
else
begin
if InsertExternalTab(TabRec.Wnd, TabRec.Idx,
TabRec.TabName, dataObj, TabIndex) then
result := S_OK;
end;
end
finally
GlobalUnlock(medium.hGlobal);
end
end
finally
ReleaseStgMedium(medium);
end
end;
DROPEFFECT_NONE:
result := S_OK;
else
result := E_UNEXPECTED;
end;
end;
function TSimpleTabControl.DUnadvise(dwConnection: Integer): HRESULT;
begin
result := OLE_E_ADVISENOTSUPPORTED;
end;
function TSimpleTabControl.EnumDAdvise(out enumAdvise: IEnumSTATDATA): HRESULT;
begin
result := OLE_E_ADVISENOTSUPPORTED;
end;
function TSimpleTabControl.EnumFormatEtc(dwDirection: Integer;
out enumFormatEtc: IEnumFORMATETC): HRESULT;
begin
if dwDirection = DATADIR_GET then
begin
enumFormatEtc := TEnumFormatEtc.Create;
result := S_OK;
end
else
begin
enumFormatEtc := nil;
result := E_NOTIMPL;
end;
end;
procedure TSimpleTabControl.FontChanged(Sender: TObject);
begin
Invalidate;
end;
function TSimpleTabControl.GetCanonicalFormatEtc(const formatetc: tagFORMATETC;
out formatetcOut: tagFORMATETC): HRESULT;
begin
formatetcOut := formatetc;
formatetcOut.ptd := nil;
result := DATA_S_SAMEFORMATETC;
end;
function TSimpleTabControl.GetData(const formatetcIn: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT;
var
TabRec: TRTabInfo;
TabName: string;
TabData: pointer;
TabDataLen: UInt64;
CanSend: boolean;
begin
FillChar(medium, sizeof(medium), 0);
if InRange(FDragTabIndex, 0, FItems.Count - 1) then
TabName := FItems[FDragTabIndex];
case GetMatchingFormatIdx(formatetcIn) of
FMT_RTAB:
begin
FillChar(TabRec, sizeof(TabRec), 0);
TabRec.Len := sizeof(TabRec);
TabRec.Wnd := Self.Handle;
TabRec.Idx := FDragTabIndex;
if TabName.Length <= 1024 then
begin
if not TabName.IsEmpty then
Move(TabName[1], TabRec.TabName[0], TabName.Length * sizeof(char));
end
else
Exit(E_UNEXPECTED);
medium.tymed := TYMED_HGLOBAL;
result := CreateHGlobal(@TabRec, sizeof(TabRec), GMEM_MOVEABLE,
medium.hGlobal);
end;
FMT_RTABDATA:
begin
if FAllowSendAway then
DoTabCanSendAway(FDragTabIndex, TabData, TabDataLen, CanSend);
try
if not FAllowSendAway or not CanSend then
Exit(E_UNEXPECTED);
medium.tymed := TYMED_HGLOBAL;
result := CreateHGlobal(TabData, TabDataLen, GMEM_MOVEABLE,
medium.hGlobal);
finally
FreeMem(TabData);
end;
end
else
result := DV_E_FORMATETC;
end;
end;
function TSimpleTabControl.GetDataHere(const formatetc: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT;
begin
result := E_NOTIMPL;
end;
function TSimpleTabControl.GetInsertionPointRect(AIndex: integer): TRect;
begin
result := Rect(FCurrentTabWidth * AIndex - 2,
0,
FCurrentTabWidth * AIndex + 2,
ClientHeight);
end;
function TSimpleTabControl.GetTabAtPoint(const APoint: TPoint): integer;
begin
result := APoint.X div FCurrentTabWidth;
if not InRange(result, 0, FItems.Count - 1) then
result := -1;
end;
function TSimpleTabControl.GetTabRect(const TabIndex: integer): TRect;
begin
result.Left := TabIndex * FCurrentTabWidth;
result.Right := result.Left + FCurrentTabWidth;
result.Top := 0;
result.Bottom := ClientHeight;
end;
function TSimpleTabControl.GetTabSepAtPoint(const APoint: TPoint): integer;
begin
result := EnsureRange((APoint.X + FCurrentTabWidth div 2) div FCurrentTabWidth,
0, FItems.Count);
end;
function TSimpleTabControl.GiveFeedback(dwEffect: Longint): HRESULT;
begin
result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
function TSimpleTabControl.InsertExternalTab(TabControl: HWND; TabIndex: integer;
const TabName: string; dataObj: IDataObject; InsertionPos: integer): boolean;
var
medium: TStgMedium;
buf: pointer;
len: UInt64;
begin
if not FAllowInsert then
Exit(false);
if TabName.IsEmpty then
Exit(false);
InsertionPos := EnsureRange(InsertionPos, 0, FItems.Count);
result := false;
if dataObj.GetData(FORMATETC_RTABCTLTABDATA, medium) = S_OK then
try
if medium.tymed = TYMED_HGLOBAL then
begin
buf := GlobalLock(medium.hGlobal);
if Assigned(buf) then
try
len := GlobalSize(medium.hGlobal);
DoTabCanInsert(buf, len, InsertionPos, result);
if result then
begin
FItems.Insert(InsertionPos, TabName);
if InsertionPos <= FActiveTab then
ActiveTab := FActiveTab + 1;
DoTabInserted(buf, len, InsertionPos);
end;
finally
GlobalUnlock(medium.hGlobal);
end;
end;
finally
ReleaseStgMedium(medium);
end;
end;
procedure TSimpleTabControl.ItemsChanged(Sender: TObject);
begin
UpdateTabWidth;
Invalidate;
end;
procedure TSimpleTabControl.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_RIGHT:
if FActiveTab < FItems.Count - 1 then
begin
SetActiveTab(FActiveTab + 1);
DoChange;
end;
VK_LEFT:
if FActiveTab > 0 then
begin
SetActiveTab(FActiveTab - 1);
DoChange;
end;
VK_HOME:
if FActiveTab <> 0 then
begin
SetActiveTab(0);
DoChange;
end;
VK_END:
if FActiveTab <> FItems.Count - 1 then
begin
SetActiveTab(FItems.Count - 1);
DoChange;
end;
end;
end;
procedure TSimpleTabControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
tab: integer;
begin
if FClickFocuses and CanFocus then SetFocus;
FPrevCursorX := X;
FPrevCursorY := Y;
FMouseDownX := X;
FMouseDownY := Y;
tab := GetTabAtPoint(Point(X, Y));
if (tab <> -1) and (tab <> FActiveTab) then
begin
SetActiveTab(tab);
DoChange;
end;
FExpectDragDrop := (tab <> -1) and (Button = mbLeft);
FDragTabIndex := tab;
inherited;
end;
procedure TSimpleTabControl.MouseMove(Shift: TShiftState; X, Y: Integer);
var
ΔX, ΔY: integer;
DropEffect: integer;
Res: HRESULT;
begin
inherited;
ΔX := X - FPrevCursorX;
ΔY := Y - FPrevCursorY;
if FExpectDragDrop and ((Abs(X - FMouseDownX) > FXDRAG) or (Abs(Y - FMouseDownY) > FYDRAG)) and (csLButtonDown in ControlState) then
begin
FExpectDragDrop := false;
FInternalDrop := false;
Res := DoDragDrop(Self, Self, DROPEFFECT_MOVE, DropEffect);
if (Res = DRAGDROP_S_DROP) and (DropEffect = DROPEFFECT_MOVE) and not FInternalDrop then
DoTabSentAway(FDragTabIndex);
FDragTabIndex := -1;
end;
FPrevCursorX := X;
FPrevCursorY := Y;
end;
procedure TSimpleTabControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
FExpectDragDrop := false;
end;
function TSimpleTabControl.MoveTab(TabIndex, InsertionPos: integer): boolean;
var
MovingActive: boolean;
NewActiveTab: integer;
begin
if not FAllowReorder then
Exit(false);
result := InRange(TabIndex, 0, FItems.Count - 1);
if result then
begin
InsertionPos := EnsureRange(InsertionPos, 0, FItems.Count);
MovingActive := TabIndex = FActiveTab;
if (InsertionPos = TabIndex) or (InsertionPos = TabIndex + 1) then
Exit(true);
NewActiveTab := IfThen(MovingActive, InsertionPos, FActiveTab);
FItems.BeginUpdate;
try
FItems.Insert(InsertionPos, FItems[TabIndex]);
if not MovingActive and (InsertionPos <= NewActiveTab) then
inc(NewActiveTab);
if TabIndex < InsertionPos then
begin
FItems.Delete(TabIndex);
if TabIndex < NewActiveTab then
dec(NewActiveTab);
end
else
begin
FItems.Delete(TabIndex + 1);
if TabIndex + 1 < NewActiveTab then
dec(NewActiveTab);
end;
finally
FItems.EndUpdate;
end;
ActiveTab := NewActiveTab;
DoTabMoved(TabIndex, InsertionPos);
end;
end;
procedure TSimpleTabControl.DoTabMoved(TabIndex, InsertionPos: integer);
begin
if Assigned(FOnTabMoved) then
FOnTabMoved(Self, TabIndex, InsertionPos);
end;
procedure TSimpleTabControl.DoTabSentAway(TabIndex: integer);
begin
if Assigned(FOnTabSentAwayEvent) then
FOnTabSentAwayEvent(Self, TabIndex);
end;
procedure TSimpleTabControl.DoTabCanInsert(const Data: pointer;
const Len: UInt64; InsertionPos: integer; out CanInsert: boolean);
begin
CanInsert := true;
if Assigned(FOnTabCanInsert) then
FOnTabCanInsert(Self, Data, Len, InsertionPos, CanInsert);
end;
procedure TSimpleTabControl.DoTabCanSendAway(TabIndex: integer;
out Data: pointer; out Len: UInt64; out CanSend: boolean);
begin
Data := nil;
Len := 0;
CanSend := true;
if Assigned(FOnTabCanSendAwayEvent) then
FOnTabCanSendAwayEvent(Self, TabIndex, Data, Len, CanSend);
end;
procedure TSimpleTabControl.DoTabInserted(const Data: pointer;
const Len: UInt64; InsertionPos: integer);
begin
if Assigned(FOnTabInserted) then
FOnTabInserted(Self, Data, Len, InsertionPos);
end;
procedure TSimpleTabControl.Paint;
var
i: Integer;
R, R2: TRect;
S: string;
h: integer;
begin
inherited;
SetLength(FOverflows, FItems.Count);
Canvas.Brush.Color := FColor;
Canvas.FillRect(ClientRect);
Canvas.Font.Assign(FFont);
Canvas.Pen.Width := 1;
for i := 0 to FItems.Count - 1 do
begin
R := GetTabRect(i);
S := FItems[i];
if FActiveTab = i then
Canvas.Font.Style := [fsBold]
else
Canvas.Font.Style := [];
if not Enabled then
begin
Canvas.Brush.Color := clBtnFace;
Canvas.Font.Color := clBtnText;
end
else if FActiveTab = i then
begin
Canvas.Brush.Color := FActiveTabColor;
Canvas.Font.Color := FActiveTabTextColor;
end
else
begin
Canvas.Brush.Color := FInactiveTabColor;
Canvas.Font.Color := FInactiveTabTextColor;
end;
Canvas.FillRect(R);
InflateRect(R, -FPadding, 0);
DrawText(Canvas.Handle, PChar(S), Length(S),
R, DT_SINGLELINE or DT_VCENTER or DT_LEFT or DT_END_ELLIPSIS or DT_NOPREFIX);
R2 := R;
DrawText(Canvas.Handle, PChar(S), Length(S),
R2, DT_SINGLELINE or DT_VCENTER or DT_LEFT or DT_NOPREFIX or DT_CALCRECT);
FOverflows[i] := R2.Right > R.Right;
if Focused and (FActiveTab = i) then
begin
h := DrawText(Canvas.Handle, PChar(S), Length(S), R,
DT_SINGLELINE or DT_VCENTER or DT_LEFT or DT_END_ELLIPSIS or DT_NOPREFIX or DT_CALCRECT);
R.Top := ClientHeight div 2 - h div 2;
R.Bottom := R.Top + h;
InflateRect(R, 2, 0);
Canvas.DrawFocusRect(R);
end;
end;
for i := 0 to FItems.Count - 1 do
begin
R := GetTabRect(i);
Canvas.Pen.Color := FBorderColor;
if FActiveTab = i then
begin
Canvas.MoveTo(R.Left, R.Bottom);
Canvas.LineTo(R.Left, R.Top);
Canvas.LineTo(R.Right, R.Top);
Canvas.LineTo(R.Right, R.Bottom);
end
else
begin
Canvas.MoveTo(R.Left, R.Bottom - 1);
Canvas.LineTo(R.Right, R.Bottom - 1);
end;
if i = FItems.Count - 1 then
begin
Canvas.MoveTo(R.Right, R.Bottom - 1);
Canvas.LineTo(ClientWidth, R.Bottom - 1);
end;
if (i > 0) and (FActiveTab <> i - 1) and (FActiveTab <> i) then
begin
Canvas.Pen.Color := FColor;
Canvas.MoveTo(R.Left, R.Top);
Canvas.LineTo(R.Left, R.Bottom - 1);
end;
end;
if FInsertionPoint <> -1 then
begin
Canvas.Pen.Color := clRed;
Canvas.Pen.Width := 2;
Canvas.MoveTo(FInsertionPoint * FCurrentTabWidth, 0);
Canvas.LineTo(FInsertionPoint * FCurrentTabWidth, ClientHeight);
end;
end;
function TSimpleTabControl.QueryContinueDrag(fEscapePRessed: BOOL;
grfKeyState: Longint): HRESULT;
begin
if fEscapePressed then
result := DRAGDROP_S_CANCEL
else if (grfKeyState and MK_LBUTTON) = 0 then
result := DRAGDROP_S_DROP
else
result := S_OK;
end;
function TSimpleTabControl.QueryGetData(const formatetc: tagFORMATETC): HRESULT;
begin
result := IfThen(GetMatchingFormatIdx(formatetc) <> -1, S_OK, S_FALSE);
end;
function TSimpleTabControl.GetMatchingFormatIdx(
const AFormatEtc: TFormatEtc): integer;
var
i: integer;
begin
for i := 0 to high(Formats) do
if
(Formats[i].cfFormat = AFormatEtc.cfFormat)
and
((Formats[i].tymed and AFormatEtc.tymed) <> 0)
and
(Formats[i].dwAspect = AFormatEtc.dwAspect)
and
(Formats[i].lindex = AFormatEtc.lindex)
then
Exit(i);
result := -1;
end;
procedure TSimpleTabControl.RemoveInsertionPoint;
var
OldInsertionPoint: integer;
begin
OldInsertionPoint := FInsertionPoint;
FInsertionPoint := -1;
if OldInsertionPoint <> -1 then
InvalidateRect(Handle, GetInsertionPointRect(OldInsertionPoint), false);
end;
procedure TSimpleTabControl.SetActiveTab(const Value: integer);
begin
if FActiveTab <> Value then
begin
FActiveTab := Value;
Invalidate;
end;
end;
procedure TSimpleTabControl.SetActiveTabColor(const Value: TColor);
begin
if FActiveTabColor <> Value then
begin
FActiveTabColor := Value;
Invalidate;
end;
end;
procedure TSimpleTabControl.SetActiveTabTextColor(const Value: TColor);
begin
if FActiveTabTextColor <> Value then
begin
FActiveTabTextColor := Value;
Invalidate;
end;
end;
procedure TSimpleTabControl.SetBorderColor(const Value: TColor);
begin
if FBorderColor <> Value then
begin
FBorderColor := Value;
Invalidate;
end;
end;
procedure TSimpleTabControl.SetColor(const Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Invalidate;
end;
end;
procedure TSimpleTabControl.SetFont(const Value: TFont);
begin
if FFont <> Value then
begin
FFont.Assign(Value);
Invalidate;
end;
end;
procedure TSimpleTabControl.SetInactiveTabColor(const Value: TColor);
begin
if FInactiveTabColor <> Value then
begin
FInactiveTabColor := Value;
Invalidate;
end;
end;
procedure TSimpleTabControl.SetInactiveTabTextColor(const Value: TColor);
begin
if FInactiveTabTextColor <> Value then
begin
FInactiveTabTextColor := Value;
Invalidate;
end;
end;
procedure TSimpleTabControl.SetItems(const Value: TStrings);
begin
if FItems <> Value then
begin
FItems.Assign(Value);
Invalidate;
end;
end;
procedure TSimpleTabControl.SetPadding(const Value: integer);
begin
if FPadding <> Value then
begin
FPadding := Value;
Invalidate;
end;
end;
function TSimpleTabControl.SetData(const formatetc: tagFORMATETC;
var medium: tagSTGMEDIUM; fRelease: LongBool): HRESULT;
begin
result := E_NOTIMPL;
end;
procedure TSimpleTabControl.SetDefaultTabWidth(const Value: integer);
begin
if FDefaultTabWidth <> Value then
begin
FDefaultTabWidth := Value;
if UpdateTabWidth then
Invalidate;
end;
end;
function TSimpleTabControl.UpdateTabWidth: boolean;
var
OldTabWidth: integer;
begin
OldTabWidth := FCurrentTabWidth;
if FItems.Count > 0 then
FCurrentTabWidth := Max(16, Min(FDefaultTabWidth, ClientWidth div FItems.Count))
else
FCurrentTabWidth := FDefaultTabWidth;
result := OldTabWidth <> FCurrentTabWidth;
end;
procedure TSimpleTabControl.WMContextMenu(var Message: TWMContextMenu);
begin
if (Message.XPos = -1) and (Message.YPos = -1) then
begin
if Assigned(FTabPopupMenu) and Visible and (Items.Count > 0) then
with ClientToScreen(Point(FActiveTab * FCurrentTabWidth, ClientHeight - 1)) do
FTabPopupMenu.Popup(X, Y);
end
else
if Assigned(FTabPopupMenu) and (GetTabAtPoint(ScreenToClient(SmallPointToPoint(Message.Pos))) <> -1) then
with SmallPointToPoint(Message.Pos) do
FTabPopupMenu.Popup(X, Y)
else
inherited;
end;
procedure TSimpleTabControl.WMSize(var Message: TWMSize);
begin
inherited;
if UpdateTabWidth then
Invalidate;
end;
procedure TSimpleTabControl.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_GETDLGCODE:
Message.Result := Message.Result or DLGC_WANTARROWS;
WM_SETFOCUS, WM_KILLFOCUS:
Invalidate;
end;
end;
function TSimpleTabControl.TEnumFormatEtc.Clone(
out Enum: IEnumFormatEtc): HResult;
begin
try
Enum := TEnumFormatEtc.Create;
TEnumFormatEtc(Enum).FIndex := Self.FIndex;
result := S_OK;
except
result := E_UNEXPECTED;
end;
end;
function TSimpleTabControl.TEnumFormatEtc.Next(celt: Longint; out elt;
pceltFetched: PLongint): HResult;
var
count: integer;
p: PFormatEtc;
begin
if (celt <= 0) or ((celt > 1) and (pceltFetched = nil)) then
Exit(E_INVALIDARG);
count := 0;
p := @elt;
while (FIndex <= high(Formats)) and (count < celt) do
begin
p^ := Formats[FIndex];
inc(p);
inc(count);
inc(FIndex);
end;
if Assigned(pceltFetched) then
pceltFetched^ := count;
result := IfThen(count = celt, S_OK, S_FALSE);
end;
function TSimpleTabControl.TEnumFormatEtc.Reset: HResult;
begin
FIndex := 0;
Result := S_OK;
end;
function TSimpleTabControl.TEnumFormatEtc.Skip(celt: Longint): HResult;
begin
if FIndex + celt <= high(Formats) then
begin
inc(FIndex, celt);
result := S_OK;
end
else
result := S_FALSE;
end;
initialization
CF_RTAB := RegisterClipboardFormat(CFSTR_RTABCTLTAB);
FORMATETC_RTABCTLTAB.cfFormat := CF_RTAB;
CF_RTABDATA := RegisterClipboardFormat(CFSTR_RTABCTLTABDATA);
FORMATETC_RTABCTLTABDATA.cfFormat := CF_RTABDATA;
TSimpleTabControl.Formats := [FORMATETC_RTABCTLTAB, FORMATETC_RTABCTLTABDATA];
end.