Примеси и контролы с непрямоугольными краями

Предыдущие серии были тут:
http://18delphi.blogspot.com/2013/03/blog-post_4606.html
http://18delphi.blogspot.com/2013/03/generic-generic.html
http://18delphi.blogspot.com/2013/04/iunknown.html


Контролы с непрямоугольными краями КОНЕЧНО лучше всего делать на FireMonkey. И забыть про VCL - по мере возможности.

Но понятное дело, что это в идеале. Но существуют суровые реалии жизни.

Потому - как делать такие контролы на VCL, да и не просто на VCL, а ещё и на примесях (иначе бы я даже не стал эту тему поднимать) - рассмотрим тут. Будем ОДНОЙ примесью скруглять края у TEdit и TButton. Сразу замечу - он разные по наследованию. Но примесь будет - ОДНА.

Ничто кстати не отменяет использования подобной техники и в FireMonley. Да и вообще - в невизуальных классах. Я про примеси. А не про скруглённые края.

Итак. Начнём с диаграмм:

и:

Код:
RegionableControl.imp.pas:

{$IfNDef RegionableControl_imp}
 
{$Define RegionableControl_imp}
 _RegionableControl_ = {mixin} class(_RegionableControl_Parent_)
  {* Контрол с поддержкой регионов }
 private
 // private fields
   f_Reg : Tl3Region;
 private
 // private methods
   procedure UpdateRegion;
   procedure ClearRegion;
   procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
 protected
 // overridden protected methods
   procedure Cleanup; override;
     {* Функция очистки полей объекта. }
   procedure CreateWnd; override;
   procedure DestroyWnd; override;
   procedure Resize; override;
   procedure VisibleChanging; override;
 protected
 // protected methods
   procedure TuneRegion(aRegion: Tl3Region); virtual;
 end;//_RegionableControl_
 
{$Else RegionableControl_imp}
 
// start class _RegionableControl_
 
procedure _RegionableControl_.UpdateRegion;
begin
 ClearRegion;
 if (f_Reg = nil) then
  f_Reg := Tl3Region.Create
 else
  f_Reg.FreeRgn;
 if (Width > 0) AND (Height > 0) AND Visible then
 begin
  if HandleAllocated then
  begin
   TuneRegion(f_Reg);
   if not f_Reg.Empty then
    SetWindowRgn(Handle, f_Reg.Rgn, true);
  end;//HandleAllocated
 end;//Visible
end;//_RegionableControl_.UpdateRegion
 
procedure _RegionableControl_.ClearRegion;
begin
 if HandleAllocated then
  SetWindowRgn(Handle, 0, false);
end;//_RegionableControl_.ClearRegion
 
procedure _RegionableControl_.TuneRegion(aRegion: Tl3Region);
begin
 // - ничего не делаем, полагаемся на потомков
end;//_RegionableControl_.TuneRegion
 
procedure _RegionableControl_.CMVisibleChanged(var Message: TMessage);
begin
 inherited;
 UpdateRegion;
end;//_RegionableControl_.CMVisibleChanged
 
procedure _RegionableControl_.Cleanup;
begin
 ClearRegion;
 FreeAndNil(f_Reg);
 inherited;
end;//_RegionableControl_.Cleanup
 
procedure _RegionableControl_.CreateWnd;
begin
 inherited;
 UpdateRegion;
end;//_RegionableControl_.CreateWnd
 
procedure _RegionableControl_.DestroyWnd;
begin
 ClearRegion;
 inherited;
end;//_RegionableControl_.DestroyWnd
 
procedure _RegionableControl_.Resize;
begin
 inherited;
 UpdateRegion;
end;//_RegionableControl_.Resize
 
procedure _RegionableControl_.VisibleChanging;
begin
 inherited;
 //UpdateRegion;
end;//_RegionableControl_.VisibleChanging
 
{$EndIf RegionableControl_imp}

RoundedControl.imp.pas:

{$IfNDef RoundedControl_imp}
 
{$Define RoundedControl_imp}
 _RegionableControl_Parent_ = _RoundedControl_Parent_;
 {$Include RegionableControl.imp.pas}
 _RoundedControl_ = {mixin} class(_RegionableControl_)
 protected
 // overridden protected methods
   procedure TuneRegion(aRegion: Tl3Region); override;
 end;//_RoundedControl_
 
{$Else RoundedControl_imp}
 
{$Include RegionableControl.imp.pas}
 
// start class _RoundedControl_
 
procedure _RoundedControl_.TuneRegion(aRegion: Tl3Region);
const
 cRad = 15;
var
 l_R : Tl3Region;
begin
 l_R := Tl3Region.Create;
 try
  l_R.Rgn := CreateRoundRectRgn(1, 0, Width + 1, Height, cRad, cRad);
  aRegion.Combine(l_R, RGN_OR);
  //aRegion.CombineRect(l3SRect(Width - cRad, 0, Width, Height), RGN_OR);
 finally
  FreeAndNil(l_R);
 end;//try..fianlly
end;//_RoundedControl_.TuneRegion
 
{$EndIf RoundedControl_imp}

RoundedButton.pas:

unit RoundedButton;
 
interface
 
uses
  StdCtrls,
  Messages,
  l3Region,
  Controls {a}
  ;
 
type
 _RefCounted_Parent_ = TButton;
 {$Include RefCounted.imp.pas}
 _RoundedControl_Parent_ = _RefCounted_;
 {$Include RoundedControl.imp.pas}
 TRoundedButton = class(_RoundedControl_)
 end;//TRoundedButton
 
implementation
 
uses
  Windows,
  SysUtils,
  Themes
  ;
 
{$Include RefCounted.imp.pas}
 
{$Include RoundedControl.imp.pas}
 
end.

RoundedEdit.pas:

unit RoundedEdit;
 
interface
 
uses
  StdCtrls,
  Messages,
  l3Region,
  Controls {a}
  ;
 
type
 _RefCounted_Parent_ = TEdit;
 {$Include RefCounted.imp.pas}
 _RoundedControl_Parent_ = _RefCounted_;
 {$Include RoundedControl.imp.pas}
 TRoundedEdit = class(_RoundedControl_)
 end;//TRoundedEdit
 
implementation
 
uses
  Windows,
  SysUtils,
  Themes
  ;
 
{$Include RefCounted.imp.pas}
 
{$Include RoundedControl.imp.pas}
 
end.

И тест к этому делу:

Код теста:

unit RoundedControlsTest;
 
interface
 
uses
  TestFrameWork
  ;
 
type
 TRoundedControlsTest = class(TTestCase)
 published
 // published methods
   procedure DoIt;
 end;//TRoundedControlsTest
 
implementation
 
uses
  RoundedButton,
  RoundedEdit,
  Forms
  ;
 
 
// start class TRoundedControlsTest
 
procedure TRoundedControlsTest.DoIt;
var
 l_Form : TCustomForm;
 l_E : TRoundedEdit;
 l_B : TRoundedButton;
begin
 l_Form := TCustomForm.CreateNew(Application);
 l_E := TRoundedEdit.Create(l_Form);
 l_B := TRoundedButton.Create(l_Form);
 
 l_Form.Height := 200;
 l_Form.Width := 200;
 l_E.Left := 10;
 l_B.Left := 10;
 l_E.Top := 20;
 l_B.Top := 50;
 
 l_E.Parent := l_Form;
 l_B.Parent := l_Form;
 l_Form.Show;
end;//TRoundedControlsTest.DoIt
 
initialization
 TestFramework.RegisterTest(TRoundedControlsTest.Suite);
 
end.

Код лежит тут - https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/Blogger/%D0%A2%D0%B5%D1%81%D1%82%D1%8B%20%D0%B8%20%D0%BF%D1%80%D0%B8%D0%BC%D0%B5%D1%81%D0%B8/RoundedControls/src

... to be continued ...