How to create a non-rectangular TPanel (Views: 27)
Problem/Question/Abstract: How to create a non-rectangular TPanel Answer: unit ShapedPanel; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls; type TShapedPanel = class(TCustomControl) private { Private declarations } FBorderColor: TColor; IsLoaded: Boolean; FBorderWidth: Integer; FRgn, FRgn2: HRGN; RgnBrush: TBrush; FFIlLColor: TColor; procedure SetFillColor(const Value: TColor); function GetFillColor: TColor; procedure MakeRegion; procedure SetBorderColor(Value: TColor); procedure WMSize(var Message: TMessage); message WM_SIZE; protected { Protected declarations } procedure Paint; override; procedure CreateWnd; override; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; published { Published declarations } property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack; property BorderWidth: Integer read FBorderWidth write FBorderWidth default 2; property FillColor: TColor read GetFillColor write SetFillColor; property Height default 200; property Width default 200; property OnClick; property OnContextPopup; property OnDblClick; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnResize; property OnStartDrag; end; procedure Register; implementation procedure Register; begin RegisterComponents('EXS', [TShapedPanel]); end; constructor TShapedPanel.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := [csCaptureMouse, csClickEvents, csOpaque, csDoubleClicks]; Width := 200; Height := 200; RgnBrush := TBrush.Create; RgnBrush.Color := clBlack; FFillColor := clWhite; IsLoaded := False; FBorderWidth := 2; FBorderColor := clBlack; FRgn := 0; FRgn2 := 0; end; destructor TShapedPanel.Destroy; begin DeleteObject(FRgn); DeleteObject(FRgn2); inherited; end; procedure TShapedPanel.CreateWnd; begin inherited; MakeRegion; IsLoaded := True; {IsLoaded is to make sure MakeRegion is not called before there is a Handle for this control, but it may not be nessary} end; procedure TShapedPanel.MakeRegion; var x4, y2: Integer; FPoints: array[0..5] of TPoint; begin {I moved the Region creation to this procedure so it can be called for WM_SIZE} SetWindowRgn(Handle, 0, False); {this clears the window region} if FRgn <> 0 then begin {Make sure to Always DeleteObject for a Region} DeleteObject(FRgn); DeleteObject(FRgn2); FRgn := 0; FRgn2 := 0; end; x4 := Width div 4; y2 := Height div 2; FPoints[0] := Point(x4, 0); FPoints[1] := Point(Width - x4, 0); FPoints[2] := Point(Width, y2); FPoints[3] := Point(Width - x4, Height); FPoints[4] := Point(x4, Height); FPoints[5] := Point(0, y2); FRgn := CreatePolygonRgn(FPoints, 6, WINDING); SetWindowRGN(Handle, FRgn, True); FRgn2 := CreatePolygonRgn(FPoints, 6, WINDING); {FRgn2 is used for FrameRgn in Paint} end; procedure TShapedPanel.WMSize(var Message: TMessage); var TmpClr: TColor; begin inherited; if IsLoaded then begin TmpClr := Canvas.Brush.Color; Canvas.Brush.Color := FFillColor; MakeRegion; FillRgn(Canvas.Handle, FRgn2, Canvas.Brush.Handle); Paint; Canvas.Brush.Color := TmpClr; end; end; procedure TShapedPanel.Paint; var TmpClr: TColor; begin inherited; if IsLoaded then begin TmpClr := Canvas.Brush.Color; Canvas.Brush.Color := FFillColor; MakeRegion; FillRgn(Canvas.Handle, FRgn2, Canvas.Brush.Handle); FrameRgn(Canvas.Handle, FRgn2, RgnBrush.Handle, FBorderWidth, FBorderWidth); Canvas.Brush.Color := TmpClr; end; end; procedure TShapedPanel.SetBorderColor(Value: TColor); begin if FBorderColor <> Value then begin FBorderColor := Value; RgnBrush.Color := FBorderColor; Paint; end; end; procedure TShapedPanel.SetFillColor(const Value: TColor); begin if FFillColor <> Value then begin FFillColor := Value; Paint; end end; function TShapedPanel.GetFillColor: TColor; begin Result := FFillColor; end; end. |