TabControl.pas

File name
C:\Users\Andreas Rejbrand\Documents\Dev\rtesrc 3.1.1\TabControl\TabControl.pas
Date exported
Time exported
Formatting processor
TPascalFormattingProcessor
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);

    { IDropTarget }
    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;

    { IDropSource }
    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;

    { IDataObject }
    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;

{ TSimpleTabControl }

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
                        // Reorder within self
                        if MoveTab(TabRec.Idx, TabIndex) then
                        begin
                          result := S_OK;
                          FInternalDrop := true;
                        end;
                      end
                      else
                      begin
                        // Obtain tab from other window
                        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;

  // Backgrounds
  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;

  // Borders
  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;

  // Insertion point
  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 // menu key or Shift+F10
  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;

{ TSimpleTabControl.TEnumFormatEtc }

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.