mirror of
https://github.com/keymanapp/keyman.git
synced 2026-09-30 03:27:44 +00:00
794 lines
23 KiB
ObjectPascal
794 lines
23 KiB
ObjectPascal
(*
|
|
Name: LeftTabbedPageControl
|
|
Copyright: Copyright (C) SIL International.
|
|
Documentation:
|
|
Description:
|
|
Create Date: 4 May 2015
|
|
|
|
Modified Date: 24 Jul 2015
|
|
Authors: mcdurdin
|
|
Related Files:
|
|
Dependencies:
|
|
|
|
Bugs:
|
|
Todo:
|
|
Notes:
|
|
History: 04 May 2015 - mcdurdin - I4693 - V9.0 - Fix crash when creating left tabbed page control without images
|
|
24 Jul 2015 - mcdurdin - I4796 - Refresh Keyman Developer look and feel for release
|
|
*)
|
|
unit LeftTabbedPageControl;
|
|
|
|
interface
|
|
|
|
uses
|
|
System.Types,
|
|
Winapi.Messages,
|
|
Winapi.Windows,
|
|
Vcl.ComCtrls,
|
|
Vcl.Controls,
|
|
Vcl.Graphics,
|
|
Vcl.ImgList,
|
|
Vcl.Themes;
|
|
|
|
type
|
|
TLeftTabbedPageControl = class(TPageControl)
|
|
private
|
|
class constructor Create;
|
|
protected
|
|
procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean);
|
|
override;
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
procedure WndProc(var Message: TMessage); override;
|
|
end;
|
|
|
|
TLeftTabControlStyleHook = class(TMouseTrackControlStyleHook)
|
|
strict private
|
|
FHotTabIndex: Integer;
|
|
FMousePosition: TMouseTrackControlStyleHook.TMousePosition;
|
|
FUpDownHandle: HWnd;
|
|
FUpDownInstance: Pointer;
|
|
FUpDownDefWndProc: Pointer;
|
|
FUpDownLeftPressed, FUpDownRightPressed: Boolean;
|
|
FUpDownMouseOnLeft, FUpDownMouseOnRight: Boolean;
|
|
procedure AngleTextOut(Canvas: TCanvas; Angle: Integer; X, Y: Integer; const Text: string);
|
|
function GetDisplayRect: TRect;
|
|
function GetImages: TCustomImageList;
|
|
function GetTabCount: Integer;
|
|
function GetTabIndex: Integer;
|
|
function GetTabPosition: TTabPosition;
|
|
function GetTabRect(Index: Integer): TRect;
|
|
function GetTabs(Index: Integer): string;
|
|
procedure HookUpDownControl;
|
|
procedure UpdateTabs(OldHotTab, HotTab: Integer);
|
|
procedure UpdateUpDownArea;
|
|
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
|
|
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
|
|
procedure WMMouseMove(var Message: TMessage); message WM_MOUSEMOVE;
|
|
procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
|
|
procedure WMParentNotify(var Message: TMessage); message WM_PARENTNOTIFY;
|
|
strict protected
|
|
procedure DrawTab(Canvas: TCanvas; Index: Integer); virtual;
|
|
function IndexOfTabAt(X, Y: Integer): Integer;
|
|
procedure Paint(Canvas: TCanvas); override;
|
|
procedure PaintBackground(Canvas: TCanvas); override;
|
|
procedure PaintUpDown(Canvas: TCanvas); virtual;
|
|
procedure UpDownWndProc(var Msg: TMessage); virtual;
|
|
procedure WndProc(var Message: TMessage); override;
|
|
property DisplayRect: TRect read GetDisplayRect;
|
|
property HotTabIndex: Integer read FHotTabIndex;
|
|
property Images: TCustomImageList read GetImages;
|
|
property TabCount: Integer read GetTabCount;
|
|
property TabIndex: Integer read GetTabIndex;
|
|
property TabPosition: TTabPosition read GetTabPosition;
|
|
property TabRect[Index: Integer]: TRect read GetTabRect;
|
|
property Tabs[Index: Integer]: string read GetTabs;
|
|
public
|
|
constructor Create(AControl: TWinControl); override;
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
uses
|
|
System.Classes,
|
|
Winapi.CommCtrl;
|
|
|
|
{ TLeftTabbedPageControl }
|
|
|
|
class constructor TLeftTabbedPageControl.Create;
|
|
begin
|
|
TCustomStyleEngine.RegisterStyleHook(TLeftTabbedPageControl, TLeftTabControlStyleHook);
|
|
end;
|
|
|
|
procedure TLeftTabbedPageControl.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
inherited;
|
|
Params.Style := Params.Style or TCS_OWNERDRAWFIXED;
|
|
end;
|
|
|
|
procedure TLeftTabbedPageControl.DrawTab(TabIndex: Integer; const Rect: TRect;
|
|
Active: Boolean);
|
|
|
|
function GetPageIndexFromTabIndex(ix: Integer): Integer;
|
|
begin
|
|
Result := -1;
|
|
while ix >= 0 do
|
|
begin
|
|
Inc(Result);
|
|
if Pages[Result].TabVisible then
|
|
Dec(ix);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
TabIndex := GetPageIndexFromTabIndex(TabIndex);
|
|
|
|
if Active then
|
|
begin
|
|
Canvas.Brush.Color := $DAC379; // Keyman Light Blue
|
|
Canvas.FillRect(Rect);
|
|
end;
|
|
|
|
if Images <> nil then // I4693
|
|
Images.Draw(Canvas,
|
|
(Rect.Right + Rect.Left - Images.Width) div 2, Rect.Top + 4,
|
|
Pages[TabIndex].ImageIndex);
|
|
with Canvas do
|
|
begin
|
|
Font.Style := [fsBold];
|
|
if Images <> nil then // I4693
|
|
TextOut((Rect.Right + Rect.Left - TextWidth(Pages[TabIndex].Caption)) div 2,
|
|
Rect.Top + Images.Height + 8, Pages[TabIndex].Caption)
|
|
else
|
|
TextOut((Rect.Right + Rect.Left - TextWidth(Pages[TabIndex].Caption)) div 2,
|
|
Rect.Top + 8, Pages[TabIndex].Caption);
|
|
end;
|
|
end;
|
|
|
|
procedure TLeftTabbedPageControl.WndProc(var Message: TMessage);
|
|
begin
|
|
inherited;
|
|
if Message.Msg = tcm_AdjustRect then
|
|
begin
|
|
Dec(PRect(Message.LParam)^.Left, 1);
|
|
PRect(Message.LParam)^.Right := ClientWidth;
|
|
PRect(Message.LParam)^.Top := 0;
|
|
PRect(Message.LParam)^.Bottom := ClientHeight;
|
|
end;
|
|
end;
|
|
|
|
|
|
type
|
|
TControlClass = class(TWinControl);
|
|
|
|
{ TLeftTabControlStyleHook }
|
|
|
|
constructor TLeftTabControlStyleHook.Create;
|
|
begin
|
|
inherited;
|
|
DoubleBuffered := True;
|
|
OverridePaint := True;
|
|
OverrideEraseBkgnd := True;
|
|
FUpDownInstance := nil;
|
|
FUpDownHandle := 0;
|
|
FUpDownDefWndProc := nil;
|
|
FUpDownLeftPressed := False;
|
|
FUpDownRightPressed := False;
|
|
FUpDownMouseOnLeft := False;
|
|
FUpDownMouseOnRight := False;
|
|
end;
|
|
|
|
destructor TLeftTabControlStyleHook.Destroy;
|
|
begin
|
|
if FUpDownHandle <> 0 then
|
|
SetWindowLong(FUpDownHandle, GWL_WNDPROC, IntPtr(FUpDownDefWndProc));
|
|
FreeObjectInstance(FUpDownInstance);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.CNNotify(var Message: TWMNotify);
|
|
begin
|
|
if (Message.NMHdr.Code = TCN_SELCHANGE) and (LongWord(Message.IDCtrl) = Handle) and (FUpDownHandle <> 0) then
|
|
UpdateUpDownArea;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.WMParentNotify(var Message: TMessage);
|
|
begin
|
|
if FUpDownHandle = 0 then
|
|
HookUpDownControl;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.WndProc(var Message: TMessage);
|
|
begin
|
|
// Reserved for potential updates
|
|
inherited;
|
|
case Message.Msg of
|
|
TCM_ADJUSTRECT:
|
|
if FUpDownHandle = 0 then
|
|
HookUpDownControl;
|
|
end;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.HookUpDownControl;
|
|
begin
|
|
if FUpDownHandle <> 0 then Exit;
|
|
FUpDownHandle := FindWindowEx(Handle, 0, 'msctls_updown32', nil); // do not localize
|
|
if FUpDownHandle <> 0 then
|
|
begin
|
|
FUpDownInstance := MakeObjectInstance(UpDownWndProc);
|
|
FUpDownDefWndProc := Pointer(GetWindowLong(FUpDownHandle, GWL_WNDPROC));
|
|
SetWindowLong(FUpDownHandle, GWL_WNDPROC, IntPtr(FUpDownInstance));
|
|
end;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.UpdateUpDownArea;
|
|
var
|
|
R, R1: TRect;
|
|
P: TPoint;
|
|
begin
|
|
if FUpDownHandle = 0 then
|
|
Exit;
|
|
GetWindowRect(FUpDownHandle, R);
|
|
P := Control.ScreenToClient(Point(R.Left, R.Top));
|
|
if TabPosition = tpTop then
|
|
begin
|
|
R1 := Rect(P.X, 0, P.X + R.Width, P.Y + R.Height + 5);
|
|
RedrawWindow(Handle, R1, 0, RDW_INVALIDATE);
|
|
end
|
|
else
|
|
begin
|
|
R1 := Rect(P.X, P.Y - 5, P.X + R.Width, Control.Height);
|
|
RedrawWindow(Handle, R1, 0, RDW_INVALIDATE);
|
|
end;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.PaintUpDown(Canvas: TCanvas);
|
|
var
|
|
Buffer: TBitmap;
|
|
R, BoundsRect: TRect;
|
|
DrawState: TThemedScrollBar;
|
|
Details: TThemedElementDetails;
|
|
begin
|
|
GetWindowRect(FUpDownHandle, BoundsRect);
|
|
if (BoundsRect.Width = 0) or (BoundsRect.Height = 0) or not StyleServices.Available then
|
|
Exit;
|
|
{create buffer}
|
|
Buffer := TBitMap.Create;
|
|
try
|
|
Buffer.Width := BoundsRect.Width;
|
|
Buffer.Height := BoundsRect.Height;
|
|
R := TRect.Create(0, 0, Buffer.Width, Buffer.Height);
|
|
|
|
Buffer.Canvas.Brush.Color := StyleServices.ColorToRGB(clBtnFace);
|
|
Buffer.Canvas.FillRect(R);
|
|
{left button}
|
|
R.Right := R.Left + R.Width div 2;
|
|
if FUpDownLeftPressed then
|
|
DrawState := tsArrowBtnLeftPressed
|
|
else if FUpDownMouseOnLeft {and MouseInControl} then
|
|
DrawState := tsArrowBtnLeftHot
|
|
else
|
|
DrawState := tsArrowBtnLeftNormal;
|
|
Details := StyleServices.GetElementDetails(DrawState);
|
|
StyleServices.DrawElement(Buffer.Canvas.Handle, Details, R);
|
|
{right button}
|
|
R := TRect.Create(0, 0, Buffer.Width, Buffer.Height);
|
|
R.Left := R.Right - R.Width div 2;
|
|
if FUpDownRightPressed then
|
|
DrawState := tsArrowBtnRightPressed
|
|
else if FUpDownMouseOnRight {and MouseInControl} then
|
|
DrawState := tsArrowBtnRightHot
|
|
else
|
|
DrawState := tsArrowBtnRightNormal;
|
|
Details := StyleServices.GetElementDetails(DrawState);
|
|
StyleServices.DrawElement(Buffer.Canvas.Handle, Details, R);
|
|
{draw buffer}
|
|
Canvas.Draw(0, 0, Buffer);
|
|
finally
|
|
Buffer.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.UpDownWndProc(var Msg: TMessage);
|
|
var
|
|
FCallOldProc: Boolean;
|
|
|
|
procedure WMLButtonDblClk(var Msg: TWMMouse);
|
|
var
|
|
R, R1: TRect;
|
|
begin
|
|
SendMessage(FUpDownHandle, WM_SETREDRAW, 0, 0);
|
|
Msg.Result := CallWindowProc(FUpDownDefWndProc, FUpDownHandle,
|
|
Msg.Msg, TMessage(Msg).WParam, TMessage(Msg).LParam);
|
|
SendMessage(FUpDownHandle, WM_SETREDRAW, 1, 0);
|
|
GetWindowRect(FUpDownHandle, R);
|
|
R1 := Rect(0, 0, R.Width, R.Height);
|
|
R1.Right := R1.Left + R1.Width div 2;
|
|
if PtInRect(R1, Point(Msg.XPos, Msg.YPos)) then
|
|
FUpDownLeftPressed := True
|
|
else
|
|
FUpDownLeftPressed := False;
|
|
R1 := Rect(0, 0, R.Width, R.Height);
|
|
R1.Left := R1.Right - R1.Width div 2;
|
|
if PtInRect(R1, Point(Msg.XPos, Msg.YPos)) then
|
|
FUpDownRightPressed := True
|
|
else
|
|
FUpDownRightPressed := False;
|
|
RedrawWindow(FUpDownHandle, nil, 0, RDW_INVALIDATE);
|
|
FCallOldProc := False;
|
|
end;
|
|
|
|
procedure WMLButtonDown(var Msg: TWMMouse);
|
|
begin
|
|
WMLButtonDblClk(Msg);
|
|
end;
|
|
|
|
procedure WMLButtonUp(var Msg: TWMMouse);
|
|
begin
|
|
SendMessage(FUpDownHandle, WM_SETREDRAW, 0, 0);
|
|
Msg.Result := CallWindowProc(FUpDownDefWndProc, FUpDownHandle,
|
|
Msg.Msg, TMessage(Msg).WParam, TMessage(Msg).LParam);
|
|
SendMessage(FUpDownHandle, WM_SETREDRAW, 1, 0);
|
|
FUpDownLeftPressed := False;
|
|
FUpDownRightPressed := False;
|
|
RedrawWindow(FUpDownHandle, nil, 0, RDW_INVALIDATE);
|
|
UpdateUpDownArea;
|
|
FCallOldProc := False;
|
|
end;
|
|
|
|
procedure WMMouseMove(var Msg: TWMMouse);
|
|
var
|
|
R, R1: TRect;
|
|
FOldUpDownMouseOnLeft, FOldUpDownMouseOnRight: Boolean;
|
|
begin
|
|
Msg.Result := CallWindowProc(FUpDownDefWndProc, FUpDownHandle,
|
|
Msg.Msg, TMessage(Msg).WParam, TMessage(Msg).LParam);
|
|
|
|
FOldUpDownMouseOnLeft := FUpDownMouseOnLeft;
|
|
FOldUpDownMouseOnRight := FUpDownMouseOnRight;
|
|
|
|
GetWindowRect(FUpDownHandle, R);
|
|
|
|
R1 := Rect(0, 0, R.Width, R.Height);
|
|
R1.Right := R1.Left + R1.Width div 2;
|
|
if PtInRect(R1, Point(Msg.XPos, Msg.YPos)) then
|
|
FUpDownMouseOnLeft := True
|
|
else
|
|
FUpDownMouseOnLeft := False;
|
|
R1 := Rect(0, 0, R.Width, R.Height);
|
|
R1.Left := R1.Right - R1.Width div 2;
|
|
if PtInRect(R1, Point(Msg.XPos, Msg.YPos)) then
|
|
FUpDownMouseOnRight := True
|
|
else
|
|
FUpDownMouseOnRight := False;
|
|
|
|
if (FOldUpDownMouseOnLeft <> FUpDownMouseOnLeft) or
|
|
(FOldUpDownMouseOnRight <> FUpDownMouseOnRight) then
|
|
RedrawWindow(FUpDownHandle, nil, 0, RDW_INVALIDATE);
|
|
|
|
FCallOldProc := False;
|
|
end;
|
|
|
|
procedure WMMouseLeave(Msg: TMessage);
|
|
begin
|
|
FUpDownMouseOnLeft := False;
|
|
FUpDownMouseOnRight := False;
|
|
FUpDownLeftPressed := False;
|
|
FUpDownRightPressed := False;
|
|
RedrawWindow(FUpDownHandle, nil, 0, RDW_INVALIDATE);
|
|
end;
|
|
|
|
procedure WMPaint(Msg: TMessage);
|
|
var
|
|
DC: HDC;
|
|
Canvas: TCanvas;
|
|
PS: TPaintStruct;
|
|
begin
|
|
DC := Msg.WParam;
|
|
Canvas := TCanvas.Create;
|
|
if DC <> 0 then
|
|
Canvas.Handle := DC
|
|
else
|
|
Canvas.Handle := BeginPaint(FUpDownHandle, PS);
|
|
try
|
|
PaintUpDown(Canvas);
|
|
finally
|
|
if DC = 0 then
|
|
EndPaint(FUpDownHandle, PS);
|
|
Canvas.Handle := 0;
|
|
Canvas.Free;
|
|
end;
|
|
FCallOldProc := False;
|
|
end;
|
|
|
|
begin
|
|
FCallOldProc := True;
|
|
case Msg.Msg of
|
|
WM_MOUSELEAVE: WMMouseLeave(Msg);
|
|
WM_LBUTTONDBLCLK: WMLButtonDblClk(TWMMouse(Msg));
|
|
WM_LBUTTONDOWN: WMLButtonDown(TWMMouse(Msg));
|
|
WM_LBUTTONUP: WMLButtonUp(TWMMouse(Msg));
|
|
WM_MOUSEMOVE: WMMouseMove(TWMMouse(Msg));
|
|
WM_PAINT: WMPaint(Msg);
|
|
end;
|
|
if FCallOldProc then
|
|
Msg.Result := CallWindowProc(FUpDownDefWndProc, FUpDownHandle,
|
|
Msg.Msg, Msg.WParam, Msg.LParam);
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.AngleTextOut(Canvas: TCanvas; Angle: Integer; X, Y: Integer; const Text: string);
|
|
var
|
|
NewFontHandle, OldFontHandle: hFont;
|
|
LogRec: TLogFont;
|
|
begin
|
|
GetObject(Canvas.Font.Handle, SizeOf(LogRec), Addr(LogRec));
|
|
LogRec.lfEscapement := Angle * 10;
|
|
LogRec.lfOrientation := LogRec.lfEscapement;
|
|
NewFontHandle := CreateFontIndirect(LogRec);
|
|
OldFontHandle := SelectObject(Canvas.Handle, NewFontHandle);
|
|
SetBkMode(Canvas.Handle, TRANSPARENT);
|
|
Canvas.TextOut(X, Y, Text);
|
|
NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle);
|
|
DeleteObject(NewFontHandle);
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.DrawTab(Canvas: TCanvas; Index: Integer);
|
|
var
|
|
R, LayoutR, GlyphR: TRect;
|
|
ImageWidth, ImageHeight, ImageStep, TX, TY: Integer;
|
|
DrawState: TThemedTab;
|
|
Details: TThemedElementDetails;
|
|
ThemeTextColor: TColor;
|
|
FImageIndex: Integer;
|
|
begin
|
|
if (Images <> nil) and (Index < Images.Count) then
|
|
begin
|
|
ImageWidth := Images.Width;
|
|
ImageHeight := Images.Height;
|
|
ImageStep := 3;
|
|
end
|
|
else
|
|
begin
|
|
ImageWidth := 0;
|
|
ImageHeight := 0;
|
|
ImageStep := 0;
|
|
end;
|
|
|
|
R := TabRect[Index];
|
|
if R.Left < 0 then Exit;
|
|
|
|
if TabPosition in [tpTop, tpBottom] then
|
|
begin
|
|
if Index = TabIndex then
|
|
InflateRect(R, 0, 2);
|
|
end
|
|
else if Index = TabIndex then
|
|
Dec(R.Left, 2) else Dec(R.Right, 2);
|
|
|
|
Canvas.Font.Assign(TLeftTabbedPageControl(Control).Font);
|
|
LayoutR := R;
|
|
DrawState := ttTabDontCare;
|
|
case TabPosition of
|
|
tpTop:
|
|
begin
|
|
if Index = TabIndex then
|
|
DrawState := ttTabItemSelected
|
|
else if (Index = FHotTabIndex) and MouseInControl then
|
|
DrawState := ttTabItemHot
|
|
else
|
|
DrawState := ttTabItemNormal;
|
|
end;
|
|
tpLeft:
|
|
begin
|
|
if Index = TabIndex then
|
|
DrawState := ttTabItemLeftEdgeSelected
|
|
else if (Index = FHotTabIndex) and MouseInControl then
|
|
DrawState := ttTabItemLeftEdgeHot
|
|
else
|
|
DrawState := ttTabItemLeftEdgeNormal;
|
|
end;
|
|
tpBottom:
|
|
begin
|
|
if Index = TabIndex then
|
|
DrawState := ttTabItemBothEdgeSelected
|
|
else if (Index = FHotTabIndex) and MouseInControl then
|
|
DrawState := ttTabItemBothEdgeHot
|
|
else
|
|
DrawState := ttTabItemBothEdgeNormal;
|
|
end;
|
|
tpRight:
|
|
begin
|
|
if Index = TabIndex then
|
|
DrawState := ttTabItemRightEdgeSelected
|
|
else if (Index = FHotTabIndex) and MouseInControl then
|
|
DrawState := ttTabItemRightEdgeHot
|
|
else
|
|
DrawState := ttTabItemRightEdgeNormal;
|
|
end;
|
|
end;
|
|
|
|
if StyleServices.Available then
|
|
begin
|
|
Details := StyleServices.GetElementDetails(DrawState);
|
|
Details.Part := 40;
|
|
StyleServices.DrawElement(Canvas.Handle, Details, R);
|
|
end;
|
|
|
|
{ Image }
|
|
if Control is TLeftTabbedPageControl then
|
|
FImageIndex := TLeftTabbedPageControl(Control).GetImageIndex(Index)
|
|
else
|
|
FImageIndex := Index;
|
|
|
|
if (Images <> nil) and (FImageIndex >= 0) and (FImageIndex < Images.Count) then
|
|
begin
|
|
GlyphR := LayoutR;
|
|
case TabPosition of
|
|
tpTop, tpBottom:
|
|
begin
|
|
GlyphR.Left := GlyphR.Left + ImageStep;
|
|
GlyphR.Right := GlyphR.Left + ImageWidth;
|
|
LayoutR.Left := GlyphR.Right;
|
|
GlyphR.Top := GlyphR.Top + (GlyphR.Bottom - GlyphR.Top) div 2 - ImageHeight div 2;
|
|
if (TabPosition = tpTop) and (Index = TabIndex) then
|
|
OffsetRect(GlyphR, 0, -1)
|
|
else if (TabPosition = tpBottom) and (Index = TabIndex) then
|
|
OffsetRect(GlyphR, 0, 1);
|
|
end;
|
|
tpLeft:
|
|
begin
|
|
GlyphR.Bottom := GlyphR.Bottom - ImageStep;
|
|
GlyphR.Top := GlyphR.Bottom - ImageHeight;
|
|
LayoutR.Bottom := GlyphR.Top;
|
|
GlyphR.Left := GlyphR.Left + (GlyphR.Right - GlyphR.Left) div 2 - ImageWidth div 2;
|
|
end;
|
|
tpRight:
|
|
begin
|
|
GlyphR.Top := GlyphR.Top + ImageStep;
|
|
GlyphR.Bottom := GlyphR.Top + ImageHeight;
|
|
LayoutR.Top := GlyphR.Bottom;
|
|
GlyphR.Left := GlyphR.Left + (GlyphR.Right - GlyphR.Left) div 2 - ImageWidth div 2;
|
|
end;
|
|
end;
|
|
if StyleServices.Available then
|
|
StyleServices.DrawIcon(Canvas.Handle, Details, GlyphR, Images.Handle, FImageIndex);
|
|
end;
|
|
|
|
{ Text }
|
|
if StyleServices.Available then
|
|
begin
|
|
if (TabPosition = tpTop) and (Index = TabIndex) then
|
|
OffsetRect(LayoutR, 0, -1)
|
|
else if (TabPosition = tpBottom) and (Index = TabIndex) then
|
|
OffsetRect(LayoutR, 0, 1);
|
|
|
|
if TabPosition = tpLeft then
|
|
begin
|
|
// TX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 -
|
|
// Canvas.TextHeight(Tabs[Index]) div 2;
|
|
// TY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 +
|
|
// Canvas.TextWidth(Tabs[Index]) div 2;
|
|
if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor) then
|
|
Canvas.Font.Color := ThemeTextColor;
|
|
// AngleTextOut(Canvas, 0, TX, TY, Tabs[Index]);
|
|
|
|
Details.Part := 39;
|
|
DrawControlText(Canvas, Details, Tabs[Index], LayoutR, DT_VCENTER or DT_CENTER or DT_SINGLELINE or DT_NOCLIP);
|
|
end
|
|
else if TabPosition = tpRight then
|
|
begin
|
|
TX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 +
|
|
Canvas.TextHeight(Tabs[Index]) div 2;
|
|
TY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 -
|
|
Canvas.TextWidth(Tabs[Index]) div 2;
|
|
if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor)
|
|
then
|
|
Canvas.Font.Color := ThemeTextColor;
|
|
AngleTextOut(Canvas, -90, TX, TY, Tabs[Index]);
|
|
end
|
|
else
|
|
DrawControlText(Canvas, Details, Tabs[Index], LayoutR, DT_VCENTER or DT_CENTER or DT_SINGLELINE or DT_NOCLIP);
|
|
end;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.WMEraseBkgnd(var Message: TMessage);
|
|
var
|
|
Details: TThemedElementDetails;
|
|
begin
|
|
if (Message.LParam = 1) and StyleServices.Available then
|
|
begin
|
|
Details := StyleServices.GetElementDetails(ttPane);
|
|
StyleServices.DrawElement(HDC(Message.WParam), Details, Control.ClientRect);
|
|
end;
|
|
Message.Result := 1;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.PaintBackground(Canvas: TCanvas);
|
|
var
|
|
Details: TThemedElementDetails;
|
|
begin
|
|
if StyleServices.Available then
|
|
begin
|
|
Details := StyleServices.GetElementDetails(ttPane);
|
|
StyleServices.DrawParentBackground(Handle, Canvas.Handle, Details, False);
|
|
end;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.Paint(Canvas: TCanvas);
|
|
var
|
|
R: TRect;
|
|
I, SaveIndex: Integer;
|
|
Details: TThemedElementDetails;
|
|
begin
|
|
SaveIndex := SaveDC(Canvas.Handle);
|
|
try
|
|
R := DisplayRect;
|
|
ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom);
|
|
PaintBackground(Canvas);
|
|
finally
|
|
RestoreDC(Canvas.Handle, SaveIndex);
|
|
end;
|
|
|
|
{ Draw tabs }
|
|
for I := 0 to TabCount - 1 do
|
|
begin
|
|
if I = TabIndex then
|
|
Continue;
|
|
DrawTab(Canvas, I);
|
|
end;
|
|
|
|
{ Draw body }
|
|
case TabPosition of
|
|
tpTop: InflateRect(R, Control.Width - R.Right, Control.Height - R.Bottom);
|
|
tpLeft: InflateRect(R, Control.Width - R.Right, Control.Height - R.Bottom);
|
|
tpBottom: InflateRect(R, R.Left, R.Top);
|
|
tpRight: InflateRect(R, R.Left, R.Top);
|
|
end;
|
|
|
|
if StyleServices.Available then
|
|
begin
|
|
Details := StyleServices.GetElementDetails(ttPane);
|
|
StyleServices.DrawElement(Canvas.Handle, Details, R);
|
|
end;
|
|
|
|
{ Draw active tab }
|
|
if TabIndex >= 0 then
|
|
DrawTab(Canvas, TabIndex);
|
|
|
|
// paint other controls
|
|
TControlClass(Control).PaintControls(Canvas.Handle, nil);
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.UpdateTabs(OldHotTab, HotTab: Integer);
|
|
var
|
|
R: TRect;
|
|
begin
|
|
if (OldHotTab >= 0) and (OldHotTab < TabCount) then
|
|
begin
|
|
R := TabRect[OldHotTab];
|
|
InvalidateRect(Handle, @R, True);
|
|
end;
|
|
if (HotTab >= 0) and (HotTab < TabCount) then
|
|
begin
|
|
R := TabRect[HotTab];
|
|
InvalidateRect(Handle, @R, True);
|
|
end;
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.CMMouseLeave(var Message: TMessage);
|
|
begin
|
|
WMMouseMove(Message);
|
|
end;
|
|
|
|
procedure TLeftTabControlStyleHook.WMMouseMove(var Message: TMessage);
|
|
var
|
|
Index, OldIndex: Integer;
|
|
begin
|
|
inherited;
|
|
CallDefaultProc(Message);
|
|
FMousePosition := mpNone;
|
|
Index := IndexOfTabAt(TWMMouseMove(Message).XPos, TWMMouseMove(Message).YPos);
|
|
if Index <> FHotTabIndex then
|
|
begin
|
|
OldIndex := FHotTabIndex;
|
|
FHotTabIndex := Index;
|
|
UpdateTabs(OldIndex, Index);
|
|
end;
|
|
end;
|
|
|
|
function TLeftTabControlStyleHook.GetImages: TCustomImageList;
|
|
begin
|
|
Result := nil;
|
|
if Control is TLeftTabbedPageControl then
|
|
Result := TLeftTabbedPageControl(Control).Images;
|
|
end;
|
|
|
|
function TLeftTabControlStyleHook.GetTabCount: Integer;
|
|
begin
|
|
Result := SendMessage(Handle, TCM_GETITEMCOUNT, 0, 0);
|
|
end;
|
|
|
|
function TLeftTabControlStyleHook.GetTabs(Index: Integer): string;
|
|
var
|
|
TCItem: TTCItem;
|
|
Buffer: array[0..254] of Char;
|
|
begin
|
|
FillChar(TCItem, Sizeof(TCItem), 0);
|
|
|
|
TCItem.mask := TCIF_TEXT;
|
|
TCItem.pszText := @Buffer;
|
|
TCItem.cchTextMax := SizeOf(Buffer);
|
|
if SendMessageW(Handle, TCM_GETITEMW, Index, IntPtr(@TCItem)) <> 0 then
|
|
Result := TCItem.pszText
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
function TLeftTabControlStyleHook.GetTabRect(Index: Integer): TRect;
|
|
begin
|
|
Result := TRect.Empty;
|
|
if (Control is TLeftTabbedPageControl) then
|
|
Result := TLeftTabbedPageControl(Control).TabRect(Index)
|
|
else if Handle <> 0 then
|
|
TabCtrl_GetItemRect(Handle, Index, Result);
|
|
end;
|
|
|
|
function TLeftTabControlStyleHook.GetTabPosition: TTabPosition;
|
|
begin
|
|
Result := tpTop;
|
|
if Control is TLeftTabbedPageControl then
|
|
Result := TLeftTabbedPageControl(Control).TabPosition;
|
|
end;
|
|
|
|
function TLeftTabControlStyleHook.GetTabIndex: Integer;
|
|
begin
|
|
if Control is TLeftTabbedPageControl then
|
|
Result := TLeftTabbedPageControl(Control).TabIndex
|
|
else
|
|
Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0);
|
|
end;
|
|
|
|
function TLeftTabControlStyleHook.GetDisplayRect: TRect;
|
|
begin
|
|
Result := Rect(0, 0, 0, 0);
|
|
if (Control <> nil) and (Control is TLeftTabbedPageControl) then
|
|
Result := TLeftTabbedPageControl(Control).DisplayRect
|
|
else
|
|
begin
|
|
Result := Control.ClientRect;
|
|
SendMessage(Handle, TCM_ADJUSTRECT, 0, IntPtr(@Result));
|
|
Inc(Result.Top, 2);
|
|
end;
|
|
end;
|
|
|
|
function TLeftTabControlStyleHook.IndexOfTabAt(X, Y: Integer): Integer;
|
|
var
|
|
HitTest: TTCHitTestInfo;
|
|
begin
|
|
if (Control <> nil) and (Control is TLeftTabbedPageControl) then
|
|
Result := TLeftTabbedPageControl(Control).IndexOfTabAt(X, Y)
|
|
else
|
|
begin
|
|
Result := -1;
|
|
if PtInRect(Control.ClientRect, Point(X, Y)) then
|
|
with HitTest do
|
|
begin
|
|
pt.X := X;
|
|
pt.Y := Y;
|
|
Result := TabCtrl_HitTest(Handle, @HitTest);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('Keyman', [TLeftTabbedPageControl]);
|
|
end;
|
|
|
|
end.
|