1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:

unit ssCtrls;

interface

uses
  SysUtils, Classes, Controls, StdCtrls, D2D1, Direct2D,DirectDraw,
  Windows, Forms, Messages, Graphics, ExtCtrls, Wincodec, pngimage;

 TAlphaLayout = class(TCustomControl)
  private
    FDoChange: boolean;
    FHelpLineColor: TColor;
    FOnChange: TNotifyEvent;

    FD2DCanvas: TDirect2DCanvas;

    procedure DoChange(Sender: TObject);

    procedure SetHelpLineColor(Value: TColor);
    //procedure SetLineReferencCollection( Value: TLineReferencCollection);
    procedure SetOnChange(Value: TNotifyEvent);
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  protected
    procedure Paint; override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure BeginChange;
    procedure EndChange(aChange: boolean);
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property HelpLineColor: TColor read FHelpLineColor write SetHelpLineColor;

    property ShowHint;
    property Touch;
    property Visible;
{$IF DEFINED(CLR)}
    property Color;
    property Font;
    property Parent;
{$ELSE}
    property Parent;
{$IFEND}
    property ParentBackground;
    property OnChange : TNotifyEvent read FOnChange write SetOnChange;
  end;

implementation

////////////////////////////////////////////////////////////////////////////////
///////////////////           TAlphaLayout              ////////////////////////
////////////////////////////////////////////////////////////////////////////////



constructor TAlphaLayout.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
//  Parent:= TWinControl(aOwner);
  //ControlStyle := [csAcceptsControls,csReflector, csReplicatable, csPannable, csGestures];
  ControlStyle :=  [csAcceptsControls,csReflector,csReplicatable,csParentBackground] - [csOpaque];    //csNoStdEvents
  Width:= 100;
  Height:= 100;
  ParentBackground:= true;

  FHelpLineColor:= clRed;
  FDoChange:= true;
  FOnChange:= nil;

  FD2DCanvas:= TDirect2DCanvas.Create(Canvas.Handle,Rect(0,0,Width,Height));
end;

destructor TAlphaLayout.Destroy;
begin
  inherited Destroy;
end;

procedure TAlphaLayout.Resize;
begin
  inherited;
end;

procedure TAlphaLayout.SetHelpLineColor(Value: TColor);
begin
  if Value <> FHelpLineColor then begin
    FHelpLineColor:= Value;
    DoChange(self);
  end;
end;

procedure TAlphaLayout.Assign(Source: TPersistent);
begin
  if Source is TAlphaLayout then begin
    BeginChange;
    FHelpLineColor:= TLayoutReferenc(Source).FHelpLineColor;
    EndChange(true);
  end;
end;

procedure TAlphaLayout.BeginChange;
begin
  FDoChange:= false;
end;

procedure TAlphaLayout.EndChange(aChange: boolean);
begin
  FDoChange:= true;
  if aChange then
    DoChange(self);
end;

procedure TAlphaLayout.DoChange(Sender: TObject);
begin
  if not FDoChange then exit;

  if Assigned(OnChange) then
    OnChange(self);

  Invalidate;
  //perform(WM_PAINT,0,0);
end;

procedure TAlphaLayout.SetOnChange(Value: TNotifyEvent);
begin
  FOnChange:= Value;
end;

procedure TAlphaLayout.Paint;
var
  i: integer;
begin
  (fd2dCanvas.RenderTarget as ID2D1DCRenderTarget).BindDC(Canvas.Handle, Rect(0,0,Width,Height));
  Fd2dCanvas.BeginDraw;
  try
    // alle Referenz-Hilfslinien zeichnen
    if csDesigning in ComponentState then begin
      Fd2dCanvas.Brush.Style:= bsClear;
      Fd2dCanvas.Pen.Style:= psDashDot;
      Fd2dCanvas.Pen.Color:= FHelpLineColor;

      Fd2dCanvas.DrawRectangle(D2D1RectF(0,0,Width,Height));
    end;
  finally
    Fd2dCanvas.EndDraw;
  end;
end;

procedure TAlphaLayout.WMNCHitTest(var Message: TWMNCHitTest);
begin
  with Message do
    if (csDesigning in ComponentState) then
      inherited
    else
      Result := HTTRANSPARENT;
end;

end.                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:

constructor TAlphaLayout.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDoChange:= false;
  //ControlStyle := [csAcceptsControls,csReflector, csReplicatable, csPannable, csGestures];
  ControlStyle :=  [csAcceptsControls,csReflector,csReplicatable,csParentBackground] - [csOpaque];    //csNoStdEvents
  Width:= 100;
  Height:= 100;
  ParentBackground:= true;

  FHelpLineColor:= clRed;
  FOnChange:= nil;

  FD2DCanvas:= nil;
  FDoChange:= true;
end;

procedure TAlphaLayout.Paint;
var
  i: integer;
begin
  if FD2DCanvas= nil then
    FD2DCanvas:= TDirect2DCanvas.Create(Canvas.Handle,Rect(0,0,Width,Height))
  else
    (fd2dCanvas.RenderTarget as ID2D1DCRenderTarget).BindDC(Canvas.Handle, Rect(0,0,Width,Height));

  Fd2dCanvas.BeginDraw;
  try
    // alle Referenz-Hilfslinien zeichnen
    if csDesigning in ComponentState then begin
      Fd2dCanvas.Brush.Style:= bsClear;
      Fd2dCanvas.Pen.Style:= psDashDot;
      Fd2dCanvas.Pen.Color:= FHelpLineColor;

      Fd2dCanvas.DrawRectangle(D2D1RectF(0,0,Width,Height));
    end;
  finally
    Fd2dCanvas.EndDraw;
  end;
end;