[源码分享]实用控件四:5分钟的改造----本身可以当容器的Splitter控件 ( 积分: 0 )

  • 主题发起人 主题发起人 Another_eYes
  • 开始时间 开始时间
A

Another_eYes

Unregistered / Unconfirmed
GUEST, unregistred user!
实现非常简单,全盘照抄了Delphi的ExtCtrls.pas中TSplitter的源码,只是把继承基类由TGraphicControl改成了TCustomControl,再在Create中修改了一点小小的style和初始宽度就搞定了,全部时间不到5分钟。

unit SplitterEx;

interface

uses
Windows, SysUtils, Classes, Controls, Graphics, ExtCtrls, Forms;

type
TSplitterEx = class(TCustomControl)
private
FActiveControl: TWinControl;
FAutoSnap: Boolean;
FBeveled: Boolean;
FBrush: TBrush;
FControl: TControl;
FDownPos: TPoint;
FLineDC: HDC;
FLineVisible: Boolean;
FMinSize: NaturalNumber;
FMaxSize: Integer;
FNewSize: Integer;
FOldKeyDown: TKeyEvent;
FOldSize: Integer;
FPrevBrush: HBrush;
FResizeStyle: TResizeStyle;
FSplit: Integer;
FOnCanResize: TCanResizeEvent;
FOnMoved: TNotifyEvent;
FOnPaint: TNotifyEvent;
procedure AllocateLineDC;
procedure CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);
procedure DrawLine;
function FindControl: TControl;
procedure FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure ReleaseLineDC;
procedure SetBeveled(Value: Boolean);
procedure UpdateControlSize;
procedure UpdateSize(X, Y: Integer);
protected
function CanResize(var NewSize: Integer): Boolean; reintroduce; virtual;
function DoCanResize(var NewSize: Integer): Boolean; virtual;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure Paint; override;
procedure RequestAlign; override;
procedure StopSizing; dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas;
published
property Align default alLeft;
property AutoSnap: Boolean read FAutoSnap write FAutoSnap default True;
property Beveled: Boolean read FBeveled write SetBeveled default False;
property Color;
property Cursor default crHSplit;
property Constraints;
property MinSize: NaturalNumber read FMinSize write FMinSize default 30;
property ParentColor;
property ResizeStyle: TResizeStyle read FResizeStyle write FResizeStyle
default rsPattern;
property Visible;
property Width default 3;
property OnCanResize: TCanResizeEvent read FOnCanResize write FOnCanResize;
property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Standard', [TSplitterEx]);
end;

{ TSplitter }

type
TWinControlAccess = class(TWinControl);

constructor TSplitterEx.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
controlstyle := controlstyle + [csAcceptsControls];
FAutoSnap := True;
Align := alLeft;
Width := 3;
Cursor := crHSplit;
FMinSize := 30;
FResizeStyle := rsPattern;
FOldSize := -1;
end;

destructor TSplitterEx.Destroy;
begin
FBrush.Free;
inherited Destroy;
end;

procedure TSplitterEx.AllocateLineDC;
begin
FLineDC := GetDCEx(Parent.Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS
or DCX_LOCKWINDOWUPDATE);
if ResizeStyle = rsPattern then
begin
if FBrush = nil then
begin
FBrush := TBrush.Create;
{$IFDEF MSWINDOWS}
FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite);
{$ENDIF}
{$IFDEF LINUX}
FBrush.Color := clGray;
{$ENDIF}
end;
FPrevBrush := SelectObject(FLineDC, FBrush.Handle);
end;
end;

procedure TSplitterEx.DrawLine;
var
P: TPoint;
begin
FLineVisible := not FLineVisible;
P := Point(Left, Top);
if Align in [alLeft, alRight] then
P.X := Left + FSplit else
P.Y := Top + FSplit;
with P do PatBlt(FLineDC, X, Y, Width, Height, PATINVERT);
end;

procedure TSplitterEx.ReleaseLineDC;
begin
if FPrevBrush <> 0 then
SelectObject(FLineDC, FPrevBrush);
ReleaseDC(Parent.Handle, FLineDC);
if FBrush <> nil then
begin
FBrush.Free;
FBrush := nil;
end;
end;

function TSplitterEx.FindControl: TControl;
var
P: TPoint;
I: Integer;
R: TRect;
begin
Result := nil;
P := Point(Left, Top);
case Align of
alLeft: Dec(P.X);
alRight: Inc(P.X, Width);
alTop: Dec(P.Y);
alBottom: Inc(P.Y, Height);
else
Exit;
end;
for I := 0 to Parent.ControlCount - 1 do
begin
Result := Parent.Controls;
if Result.Visible and Result.Enabled then
begin
R := Result.BoundsRect;
if (R.Right - R.Left) = 0 then
if Align in [alTop, alLeft] then
Dec(R.Left)
else
Inc(R.Right);
if (R.Bottom - R.Top) = 0 then
if Align in [alTop, alLeft] then
Dec(R.Top)
else
Inc(R.Bottom);
if PtInRect(R, P) then Exit;
end;
end;
Result := nil;
end;

procedure TSplitterEx.RequestAlign;
begin
inherited RequestAlign;
if (Cursor <> crVSplit) and (Cursor <> crHSplit) then Exit;
if Align in [alBottom, alTop] then
Cursor := crVSplit
else
Cursor := crHSplit;
end;

procedure TSplitterEx.Paint;
const
XorColor = $00FFD8CE;
var
FrameBrush: HBRUSH;
R: TRect;
begin
R := ClientRect;
Canvas.Brush.Color := Color;
Canvas.FillRect(ClientRect);
if Beveled then
begin
if Align in [alLeft, alRight] then
InflateRect(R, -1, 2) else
InflateRect(R, 2, -1);
OffsetRect(R, 1, 1);
FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));
FrameRect(Canvas.Handle, R, FrameBrush);
DeleteObject(FrameBrush);
OffsetRect(R, -2, -2);
FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));
FrameRect(Canvas.Handle, R, FrameBrush);
DeleteObject(FrameBrush);
end;
if csDesigning in ComponentState then
{ Draw outline }
with Canvas do
begin
Pen.Style := psDot;
Pen.Mode := pmXor;
Pen.Color := XorColor;
Brush.Style := bsClear;
Rectangle(0, 0, ClientWidth, ClientHeight);
end;
if Assigned(FOnPaint) then FOnPaint(Self);
end;

function TSplitterEx.DoCanResize(var NewSize: Integer): Boolean;
begin
Result := CanResize(NewSize);
if Result and (NewSize <= MinSize) and FAutoSnap then
NewSize := 0;
end;

function TSplitterEx.CanResize(var NewSize: Integer): Boolean;
begin
Result := NewSize >= 32;
if result and Assigned(FOnCanResize) then FOnCanResize(Self, NewSize, Result);
end;

procedure TSplitterEx.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
I: Integer;
begin
inherited MouseDown(Button, Shift, X, Y);
if Button = mbLeft then
begin
FControl := FindControl;
FDownPos := Point(X, Y);
if Assigned(FControl) then
begin
if Align in [alLeft, alRight] then
begin
FMaxSize := Parent.ClientWidth - FMinSize;
for I := 0 to Parent.ControlCount - 1 do
with Parent.Controls do
if Visible and (Align in [alLeft, alRight]) then Dec(FMaxSize, Width);
Inc(FMaxSize, FControl.Width);
end
else
begin
FMaxSize := Parent.ClientHeight - FMinSize;
for I := 0 to Parent.ControlCount - 1 do
with Parent.Controls do
if Align in [alTop, alBottom] then Dec(FMaxSize, Height);
Inc(FMaxSize, FControl.Height);
end;
UpdateSize(X, Y);
AllocateLineDC;
with ValidParentForm(Self) do
if ActiveControl <> nil then
begin
FActiveControl := ActiveControl;
FOldKeyDown := TWinControlAccess(FActiveControl).OnKeyDown;
TWinControlAccess(FActiveControl).OnKeyDown := FocusKeyDown;
end;
if ResizeStyle in [rsLine, rsPattern] then DrawLine;
end;
end;
end;

procedure TSplitterEx.UpdateControlSize;
begin
if FNewSize <> FOldSize then
begin
case Align of
alLeft: FControl.Width := FNewSize;
alTop: FControl.Height := FNewSize;
alRight:
begin
Parent.DisableAlign;
try
FControl.Left := FControl.Left + (FControl.Width - FNewSize);
FControl.Width := FNewSize;
finally
Parent.EnableAlign;
end;
end;
alBottom:
begin
Parent.DisableAlign;
try
FControl.Top := FControl.Top + (FControl.Height - FNewSize);
FControl.Height := FNewSize;
finally
Parent.EnableAlign;
end;
end;
end;
Update;
if Assigned(FOnMoved) then FOnMoved(Self);
FOldSize := FNewSize;
end;
end;

procedure TSplitterEx.CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);
var
S: Integer;
begin
if Align in [alLeft, alRight] then
Split := X - FDownPos.X
else
Split := Y - FDownPos.Y;
S := 0;
case Align of
alLeft: S := FControl.Width + Split;
alRight: S := FControl.Width - Split;
alTop: S := FControl.Height + Split;
alBottom: S := FControl.Height - Split;
end;
NewSize := S;
if S < FMinSize then
NewSize := FMinSize
else if S > FMaxSize then
NewSize := FMaxSize;
if S <> NewSize then
begin
if Align in [alRight, alBottom] then
S := S - NewSize else
S := NewSize - S;
Inc(Split, S);
end;
end;

procedure TSplitterEx.UpdateSize(X, Y: Integer);
begin
CalcSplitSize(X, Y, FNewSize, FSplit);
end;

procedure TSplitterEx.MouseMove(Shift: TShiftState; X, Y: Integer);
var
NewSize, Split: Integer;
begin
inherited;
if (ssLeft in Shift) and Assigned(FControl) then
begin
CalcSplitSize(X, Y, NewSize, Split);
if DoCanResize(NewSize) then
begin
if ResizeStyle in [rsLine, rsPattern] then DrawLine;
FNewSize := NewSize;
FSplit := Split;
if ResizeStyle = rsUpdate then UpdateControlSize;
if ResizeStyle in [rsLine, rsPattern] then DrawLine;
end;
end;
end;

procedure TSplitterEx.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
if Assigned(FControl) then
begin
if ResizeStyle in [rsLine, rsPattern] then DrawLine;
UpdateControlSize;
StopSizing;
end;
end;

procedure TSplitterEx.FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_ESCAPE then
StopSizing
else if Assigned(FOldKeyDown) then
FOldKeyDown(Sender, Key, Shift);
end;

procedure TSplitterEx.SetBeveled(Value: Boolean);
begin
FBeveled := Value;
Repaint;
end;

procedure TSplitterEx.StopSizing;
begin
if Assigned(FControl) then
begin
if FLineVisible then DrawLine;
FControl := nil;
ReleaseLineDC;
if Assigned(FActiveControl) then
begin
TWinControlAccess(FActiveControl).OnKeyDown := FOldKeyDown;
FActiveControl := nil;
end;
end;
if Assigned(FOnMoved) then
FOnMoved(Self);
end;

end.
 
实现非常简单,全盘照抄了Delphi的ExtCtrls.pas中TSplitter的源码,只是把继承基类由TGraphicControl改成了TCustomControl,再在Create中修改了一点小小的style和初始宽度就搞定了,全部时间不到5分钟。

unit SplitterEx;

interface

uses
Windows, SysUtils, Classes, Controls, Graphics, ExtCtrls, Forms;

type
TSplitterEx = class(TCustomControl)
private
FActiveControl: TWinControl;
FAutoSnap: Boolean;
FBeveled: Boolean;
FBrush: TBrush;
FControl: TControl;
FDownPos: TPoint;
FLineDC: HDC;
FLineVisible: Boolean;
FMinSize: NaturalNumber;
FMaxSize: Integer;
FNewSize: Integer;
FOldKeyDown: TKeyEvent;
FOldSize: Integer;
FPrevBrush: HBrush;
FResizeStyle: TResizeStyle;
FSplit: Integer;
FOnCanResize: TCanResizeEvent;
FOnMoved: TNotifyEvent;
FOnPaint: TNotifyEvent;
procedure AllocateLineDC;
procedure CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);
procedure DrawLine;
function FindControl: TControl;
procedure FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure ReleaseLineDC;
procedure SetBeveled(Value: Boolean);
procedure UpdateControlSize;
procedure UpdateSize(X, Y: Integer);
protected
function CanResize(var NewSize: Integer): Boolean; reintroduce; virtual;
function DoCanResize(var NewSize: Integer): Boolean; virtual;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure Paint; override;
procedure RequestAlign; override;
procedure StopSizing; dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas;
published
property Align default alLeft;
property AutoSnap: Boolean read FAutoSnap write FAutoSnap default True;
property Beveled: Boolean read FBeveled write SetBeveled default False;
property Color;
property Cursor default crHSplit;
property Constraints;
property MinSize: NaturalNumber read FMinSize write FMinSize default 30;
property ParentColor;
property ResizeStyle: TResizeStyle read FResizeStyle write FResizeStyle
default rsPattern;
property Visible;
property Width default 3;
property OnCanResize: TCanResizeEvent read FOnCanResize write FOnCanResize;
property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Standard', [TSplitterEx]);
end;

{ TSplitter }

type
TWinControlAccess = class(TWinControl);

constructor TSplitterEx.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
controlstyle := controlstyle + [csAcceptsControls];
FAutoSnap := True;
Align := alLeft;
Width := 3;
Cursor := crHSplit;
FMinSize := 30;
FResizeStyle := rsPattern;
FOldSize := -1;
end;

destructor TSplitterEx.Destroy;
begin
FBrush.Free;
inherited Destroy;
end;

procedure TSplitterEx.AllocateLineDC;
begin
FLineDC := GetDCEx(Parent.Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS
or DCX_LOCKWINDOWUPDATE);
if ResizeStyle = rsPattern then
begin
if FBrush = nil then
begin
FBrush := TBrush.Create;
{$IFDEF MSWINDOWS}
FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite);
{$ENDIF}
{$IFDEF LINUX}
FBrush.Color := clGray;
{$ENDIF}
end;
FPrevBrush := SelectObject(FLineDC, FBrush.Handle);
end;
end;

procedure TSplitterEx.DrawLine;
var
P: TPoint;
begin
FLineVisible := not FLineVisible;
P := Point(Left, Top);
if Align in [alLeft, alRight] then
P.X := Left + FSplit else
P.Y := Top + FSplit;
with P do PatBlt(FLineDC, X, Y, Width, Height, PATINVERT);
end;

procedure TSplitterEx.ReleaseLineDC;
begin
if FPrevBrush <> 0 then
SelectObject(FLineDC, FPrevBrush);
ReleaseDC(Parent.Handle, FLineDC);
if FBrush <> nil then
begin
FBrush.Free;
FBrush := nil;
end;
end;

function TSplitterEx.FindControl: TControl;
var
P: TPoint;
I: Integer;
R: TRect;
begin
Result := nil;
P := Point(Left, Top);
case Align of
alLeft: Dec(P.X);
alRight: Inc(P.X, Width);
alTop: Dec(P.Y);
alBottom: Inc(P.Y, Height);
else
Exit;
end;
for I := 0 to Parent.ControlCount - 1 do
begin
Result := Parent.Controls;
if Result.Visible and Result.Enabled then
begin
R := Result.BoundsRect;
if (R.Right - R.Left) = 0 then
if Align in [alTop, alLeft] then
Dec(R.Left)
else
Inc(R.Right);
if (R.Bottom - R.Top) = 0 then
if Align in [alTop, alLeft] then
Dec(R.Top)
else
Inc(R.Bottom);
if PtInRect(R, P) then Exit;
end;
end;
Result := nil;
end;

procedure TSplitterEx.RequestAlign;
begin
inherited RequestAlign;
if (Cursor <> crVSplit) and (Cursor <> crHSplit) then Exit;
if Align in [alBottom, alTop] then
Cursor := crVSplit
else
Cursor := crHSplit;
end;

procedure TSplitterEx.Paint;
const
XorColor = $00FFD8CE;
var
FrameBrush: HBRUSH;
R: TRect;
begin
R := ClientRect;
Canvas.Brush.Color := Color;
Canvas.FillRect(ClientRect);
if Beveled then
begin
if Align in [alLeft, alRight] then
InflateRect(R, -1, 2) else
InflateRect(R, 2, -1);
OffsetRect(R, 1, 1);
FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));
FrameRect(Canvas.Handle, R, FrameBrush);
DeleteObject(FrameBrush);
OffsetRect(R, -2, -2);
FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));
FrameRect(Canvas.Handle, R, FrameBrush);
DeleteObject(FrameBrush);
end;
if csDesigning in ComponentState then
{ Draw outline }
with Canvas do
begin
Pen.Style := psDot;
Pen.Mode := pmXor;
Pen.Color := XorColor;
Brush.Style := bsClear;
Rectangle(0, 0, ClientWidth, ClientHeight);
end;
if Assigned(FOnPaint) then FOnPaint(Self);
end;

function TSplitterEx.DoCanResize(var NewSize: Integer): Boolean;
begin
Result := CanResize(NewSize);
if Result and (NewSize <= MinSize) and FAutoSnap then
NewSize := 0;
end;

function TSplitterEx.CanResize(var NewSize: Integer): Boolean;
begin
Result := NewSize >= 32;
if result and Assigned(FOnCanResize) then FOnCanResize(Self, NewSize, Result);
end;

procedure TSplitterEx.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
I: Integer;
begin
inherited MouseDown(Button, Shift, X, Y);
if Button = mbLeft then
begin
FControl := FindControl;
FDownPos := Point(X, Y);
if Assigned(FControl) then
begin
if Align in [alLeft, alRight] then
begin
FMaxSize := Parent.ClientWidth - FMinSize;
for I := 0 to Parent.ControlCount - 1 do
with Parent.Controls do
if Visible and (Align in [alLeft, alRight]) then Dec(FMaxSize, Width);
Inc(FMaxSize, FControl.Width);
end
else
begin
FMaxSize := Parent.ClientHeight - FMinSize;
for I := 0 to Parent.ControlCount - 1 do
with Parent.Controls do
if Align in [alTop, alBottom] then Dec(FMaxSize, Height);
Inc(FMaxSize, FControl.Height);
end;
UpdateSize(X, Y);
AllocateLineDC;
with ValidParentForm(Self) do
if ActiveControl <> nil then
begin
FActiveControl := ActiveControl;
FOldKeyDown := TWinControlAccess(FActiveControl).OnKeyDown;
TWinControlAccess(FActiveControl).OnKeyDown := FocusKeyDown;
end;
if ResizeStyle in [rsLine, rsPattern] then DrawLine;
end;
end;
end;

procedure TSplitterEx.UpdateControlSize;
begin
if FNewSize <> FOldSize then
begin
case Align of
alLeft: FControl.Width := FNewSize;
alTop: FControl.Height := FNewSize;
alRight:
begin
Parent.DisableAlign;
try
FControl.Left := FControl.Left + (FControl.Width - FNewSize);
FControl.Width := FNewSize;
finally
Parent.EnableAlign;
end;
end;
alBottom:
begin
Parent.DisableAlign;
try
FControl.Top := FControl.Top + (FControl.Height - FNewSize);
FControl.Height := FNewSize;
finally
Parent.EnableAlign;
end;
end;
end;
Update;
if Assigned(FOnMoved) then FOnMoved(Self);
FOldSize := FNewSize;
end;
end;

procedure TSplitterEx.CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);
var
S: Integer;
begin
if Align in [alLeft, alRight] then
Split := X - FDownPos.X
else
Split := Y - FDownPos.Y;
S := 0;
case Align of
alLeft: S := FControl.Width + Split;
alRight: S := FControl.Width - Split;
alTop: S := FControl.Height + Split;
alBottom: S := FControl.Height - Split;
end;
NewSize := S;
if S < FMinSize then
NewSize := FMinSize
else if S > FMaxSize then
NewSize := FMaxSize;
if S <> NewSize then
begin
if Align in [alRight, alBottom] then
S := S - NewSize else
S := NewSize - S;
Inc(Split, S);
end;
end;

procedure TSplitterEx.UpdateSize(X, Y: Integer);
begin
CalcSplitSize(X, Y, FNewSize, FSplit);
end;

procedure TSplitterEx.MouseMove(Shift: TShiftState; X, Y: Integer);
var
NewSize, Split: Integer;
begin
inherited;
if (ssLeft in Shift) and Assigned(FControl) then
begin
CalcSplitSize(X, Y, NewSize, Split);
if DoCanResize(NewSize) then
begin
if ResizeStyle in [rsLine, rsPattern] then DrawLine;
FNewSize := NewSize;
FSplit := Split;
if ResizeStyle = rsUpdate then UpdateControlSize;
if ResizeStyle in [rsLine, rsPattern] then DrawLine;
end;
end;
end;

procedure TSplitterEx.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
if Assigned(FControl) then
begin
if ResizeStyle in [rsLine, rsPattern] then DrawLine;
UpdateControlSize;
StopSizing;
end;
end;

procedure TSplitterEx.FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_ESCAPE then
StopSizing
else if Assigned(FOldKeyDown) then
FOldKeyDown(Sender, Key, Shift);
end;

procedure TSplitterEx.SetBeveled(Value: Boolean);
begin
FBeveled := Value;
Repaint;
end;

procedure TSplitterEx.StopSizing;
begin
if Assigned(FControl) then
begin
if FLineVisible then DrawLine;
FControl := nil;
ReleaseLineDC;
if Assigned(FActiveControl) then
begin
TWinControlAccess(FActiveControl).OnKeyDown := FOldKeyDown;
FActiveControl := nil;
end;
end;
if Assigned(FOnMoved) then
FOnMoved(Self);
end;

end.
 
后退
顶部