O código que segue é de um componente (inacabado), um label
, que estava/estou tentando fazer. A ideia era criar um label em que eu pudesse definir margens, paddings e bordas, sendo que para as bordas a espessura é comum a todas e que eu posso definir a presença ou não (da borda superior, borda direita, borda inferior e borda esquerda).
Deixei a reescrita do método paint por último que, no caso, ainda não terminei porque detectei que, ao instanciar um objeto da minha classe (TMyLabel
) e definir a presença de uma das bordas (borda superior, por exemplo) pela propriedade booleana borderTop
e a espessura comum (a todas as bordas) via propriedade inteira borderWidth
, o form fica piscando.
Comentada a linha em que eu especifico um valor para a espessura da borda (borderWidth := valor
) ou na qual eu defino a presença da borda superior (borderTop := true
), o form não pisca mais. Olhei os métodos (setters) associados as duas propriedades e não encontro o erro.
Minha intuição dizia que o form piscando só poderia ser erro em looping
ou em chamada recursiva de procedure/função, o que não é o caso. Se alguém puder me ajudar, ficaria agradecido.
unit uMyLabel;
interface
uses
System.Classes,
System.Types,
VCL.Controls,
VCL.Graphics,
VCL.StdCtrls;
type
TMyLabel = class(TCustomLabel)
private
FborderTop,
FborderRight,
FborderBottom,
FborderLeft : Boolean;
FborderTopColor,
FborderRightColor,
FborderBottomColor,
FborderLeftColor,
Fcolor,
FdisabledBackgroundColor,
FdisabledFontColor : TColor;
Fcaption : TCaption;
FborderWidth,
FmarginTop,
FmarginRight,
FmarginBottom,
FmarginLeft,
FpaddingTop,
FpaddingRight,
FpaddingBottom,
FpaddingLeft : Integer;
procedure setBorderTop(bool : Boolean);
procedure setBorderRight(bool : Boolean);
procedure setBorderBottom(bool : Boolean);
procedure setBorderLeft(bool : Boolean);
procedure setBorderWidth(width : Integer);
procedure setCaption(caption : TCaption);
procedure setColor(color : TColor);
procedure setMarginTop(width : Integer);
procedure setMarginRight(width : Integer);
procedure setMarginBottom(width : Integer);
procedure setMarginLeft(width : Integer);
procedure setPaddingTop(width : Integer);
procedure setPaddingRight(width : Integer);
procedure setPaddingBottom(width : Integer);
procedure setPaddingLeft(width : Integer);
procedure setTransparent(bool : Boolean);
function getTextHeight : Integer;
function getTextWidth : Integer;
function isTransparent : Boolean;
protected
procedure paint; override;
property alignment;
property canvas;
property clientHeight;
property clientWidth;
property glowsize;
property height;
property layout;
property width;
public
constructor create(aOwner : TComponent); overload;
constructor create(aOwner : TComponent; fontColor : TColor); overload;
procedure setBorderColor(color : TColor); overload;
procedure setBorderColor(color1, color2 : TColor); overload;
procedure setBorderColor(color1, color2, color3 : TColor); overload;
procedure setBorderColor(color1, color2, color3, color4 : TColor); overload;
procedure setMargin(width : Integer); overload;
procedure setMargin(width1, width2 : Integer); overload;
procedure setMargin(width1, width2, width3 : Integer); overload;
procedure setMargin(width1, width2, width3, width4 : Integer); overload;
procedure setPadding(width : Integer); overload;
procedure setPadding(width1, width2 : Integer); overload;
procedure setPadding(width1, width2, width3 : Integer); overload;
procedure setPadding(width1, width2, width3, width4 : Integer); overload;
property clientRect;
property explicitLeft;
property explicitTop;
property helpContext;
property helpKeyWord;
property helpType;
property parentBiDiMode;
property parentColor;
property parentCustomHint;
property parentShowHint;
property textHeight : Integer read getTextHeight;
property textWidth : Integer read getTextWidth;
published
property borderTop : Boolean read FborderTop write setBorderTop default false;
property borderRight : Boolean read FborderRight write setBorderRight default false;
property borderBottom : Boolean read FborderBottom write setBorderBottom default false;
property borderLeft : Boolean read FborderLeft write setBorderLeft default false;
property borderTopColor : TColor read FborderTopColor write FborderTopColor default clBlack;
property borderRightColor : TColor read FborderRightColor write FborderRightColor default clBlack;
property borderBottomColor : TColor read FborderBottomColor write FborderBottomColor default clBlack;
property borderLeftColor : TColor read FborderLeftColor write FborderLeftColor default clBlack;
property borderWidth : Integer read FborderWidth write setBorderWidth default 0;
property caption : TCaption read Fcaption write setCaption;
property color : TColor read Fcolor write setColor default -16777211;
property disabledBackgroundColor : TColor read FdisabledBackgroundColor write FdisabledBackgroundColor default -16777211;
property disabledFontColor : TColor read FdisabledFontColor write FdisabledFontColor default 8421504;
property dragCursor;
property dragKind;
property dragMode;
property enabled;
property explicitHeight : Integer read FExplicitHeight;
property explicitWidth : Integer read FExplicitWidth;
property font;
property marginTop : Integer read FmarginTop write setMarginTop default 0;
property marginRight : Integer read FmarginRight write setMarginRight default 0;
property marginBottom : Integer read FmarginBottom write setMarginBottom default 0;
property marginLeft : Integer read FmarginLeft write setMarginLeft default 0;
property paddingTop : Integer read FpaddingTop write setPaddingTop default 0;
property paddingRight : Integer read FpaddingRight write setPaddingRight default 0;
property paddingBottom : Integer read FpaddingBottom write setPaddingBottom default 0;
property paddingLeft : Integer read FpaddingLeft write setPaddingLeft default 0;
property parentFont;
property popupMenu;
property transparent : Boolean read isTransparent write setTransparent default true;
property visible;
property onClick;
property onContextPopup;
property onDblClick;
property onDragDrop;
property onDragOver;
property onEndDock;
property onEndDrag;
property onGesture;
property onMouseActivate;
property onMouseDown;
property onMouseEnter;
property onMouseLeave;
property onMouseMove;
property onMouseUp;
property onStartDock;
property onStartDrag;
end;
implementation
constructor TMyLabel.create(aOwner : TComponent);
begin
inherited create(aOwner);
FborderTopColor := 0;
FborderRightColor := 0;
FborderBottomColor := 0;
FborderLeftColor := 0;
FborderWidth := 0;
Fcolor:= -16777211;
FdisabledBackgroundColor := -16777211;
FdisabledFontColor := 8421504;
font.color := 0;
FmarginTop := 0;
FmarginRight := 0;
FmarginBottom := 0;
FmarginLeft := 0;
FpaddingTop := 0;
FpaddingRight := 0;
FpaddingBottom := 0;
FpaddingLeft := 0;
FborderTop := false;
FborderRight := false;
FborderBottom := false;
FborderLeft := false;
showHint := true;
transparent := true;
end;
constructor TMyLabel.create(aOwner: TComponent; fontColor: TColor);
begin
create(aOwner);
font.color := fontColor;
end;
procedure TMyLabel.paint;
var
o : TPoint;
rect : TRect;
fontColor : TColor;
procedure setSize;
begin
height := marginTop + paddingTop + canvas.textHeight(caption) + paddingBottom + marginBottom;
width := marginLeft + paddingLeft + canvas.textWidth(caption) + paddingRight + marginRight;
if borderTop then
begin
if borderBottom then
height := height + 2*FborderWidth
else
height := height + FborderWidth;
end
else
if borderBottom then
height := height + FborderWidth;
if borderRight then
begin
if borderLeft then
width := width + 2*FborderWidth
else
width := width + FborderWidth;
end
else
if borderLeft then
width := width + FborderWidth;
end;
procedure renderizarFundo;
begin
if enabled then
canvas.brush.color := Fcolor
else
canvas.brush.color := disabledBackgroundColor;
o := TPoint.create(0,0);
rect := TRect.create(o, self.width, self.height);
canvas.fillRect(rect);
end;
procedure renderizarBorda;
procedure renderizarBordaSuperior;
begin
//
end;
procedure renderizarBordaDireita;
begin
//
end;
procedure renderizarBordaInferior;
begin
//
end;
procedure renderizarBordaEsquerda;
begin
//
end;
begin
renderizarBordaSuperior;
renderizarBordaDireita;
renderizarBordaInferior;
renderizarBordaEsquerda;
end;
procedure renderizarTexto;
begin
fontColor := canvas.font.color;
if not enabled then
canvas.font.color := disabledFontColor;
if borderLeft then
begin
if borderTop then
canvas.textOut(marginLeft+borderWidth+paddingLeft,
marginTop+borderWidth+paddingTop,
caption
)
else
canvas.textOut(marginLeft+borderWidth+paddingLeft,
marginTop+paddingTop,
caption
);
end
else
begin
if borderTop then
canvas.textOut(marginLeft+paddingLeft,
marginTop+borderWidth+paddingTop,
caption
)
else
canvas.textOut(marginLeft+paddingLeft,
marginTop+paddingTop,
caption
);
end;
end;
begin
setSize;
renderizarFundo;
renderizarBorda;
renderizarTexto;
canvas.font.color := fontColor;
end;
procedure TMyLabel.setBorderColor(color: TColor);
begin
if
(color <> borderTopColor) or
(color <> borderRightColor) or
(color <> borderBottomColor) or
(color <> borderLeftColor)
then
begin
FborderTopColor := color;
FborderRightColor := color;
FborderBottomColor := color;
FborderLeftColor := color;
refresh;
end;
end;
procedure TMyLabel.setBorderColor(color1: TColor; color2: TColor);
begin
if
(color1 <> borderTopColor) or
(color1 <> borderBottomColor) or
(color2 <> borderRightColor) or
(color2 <> borderLeftColor)
then
begin
FborderTopColor := color1;
FborderBottomColor := color1;
FborderRightColor := color2;
FborderLeftColor := color2;
refresh;
end;
end;
procedure TMyLabel.setBorderColor(color1: TColor; color2: TColor; color3: TColor);
begin
if
(color1 <> borderTopColor) or
(color2 <> borderRightColor) or
(color2 <> borderLeftColor) or
(color3 <> borderBottomColor)
then
begin
FborderTopColor := color1;
FborderRightColor := color2;
FborderLeftColor := color2;
FborderBottomColor := color3;
refresh;
end;
end;
procedure TMyLabel.setBorderColor(color1: TColor; color2: TColor; color3: TColor; color4: TColor);
begin
if
(color1 <> borderTopColor) or
(color2 <> borderRightColor) or
(color3 <> borderBottomColor) or
(color4 <> borderLeftColor)
then
begin
FborderTopColor := color1;
FborderRightColor := color2;
FborderBottomColor := color3;
FborderLeftColor := color4;
refresh;
end;
end;
procedure TMyLabel.setCaption(caption: TCaption);
begin
if caption <> Fcaption then
begin
Fcaption := caption;
refresh;
end;
end;
procedure TMyLabel.setColor(color: TColor);
begin
Fcolor := color;
if canvas.brush.color <> color then
if not transparent then
begin
canvas.brush.color := color;
refresh;
end;
end;
procedure TMyLabel.setBorderTop(bool: Boolean);
begin
if bool <> borderTop then
begin
FborderTop := bool;
refresh;
end;
end;
procedure TMyLabel.setBorderRight(bool: Boolean);
begin
if bool <> borderRight then
begin
FborderRight := bool;
refresh;
end;
end;
procedure TMyLabel.setBorderBottom(bool: Boolean);
begin
if bool <> borderBottom then
begin
FborderBottom := bool;
refresh;
end;
end;
procedure TMyLabel.setBorderLeft(bool: Boolean);
begin
if bool <> borderLeft then
begin
FborderLeft := bool;
refresh;
end;
end;
procedure TMyLabel.setBorderWidth(width: Integer);
begin
if width > -1 then
begin
if width <> borderWidth then
begin
FborderWidth := width;
refresh;
end;
end
else
begin
FborderWidth := 0;
refresh;
end;
end;
procedure TMyLabel.setMarginTop(width: Integer);
begin
if width > -1 then
begin
if width <> marginTop then
begin
FmarginTop := width;
refresh;
end;
end
else
begin
FmarginTop := 0;
refresh;
end;
end;
procedure TMyLabel.setMarginRight(width: Integer);
begin
if width > -1 then
begin
if width <> marginRight then
begin
FmarginRight := width;
refresh;
end;
end
else
begin
FmarginRight := 0;
refresh;
end;
end;
procedure TMyLabel.setMarginBottom(width: Integer);
begin
if width > -1 then
begin
if width <> marginBottom then
begin
FmarginBottom := width;
refresh;
end;
end
else
begin
FmarginBottom := 0;
refresh;
end;
end;
procedure TMyLabel.setMarginLeft(width: Integer);
begin
if width > -1 then
begin
if width <> marginLeft then
begin
FmarginLeft := width;
refresh;
end;
end
else
begin
FmarginLeft := 0;
refresh;
end;
end;
procedure TMyLabel.setMargin(width: Integer);
begin
if
(width <> marginTop) or
(width <> marginRight) or
(width <> marginBottom) or
(width <> marginLeft)
then
begin
FmarginTop := width;
FmarginRight := width;
FmarginBottom := width;
FmarginLeft := width;
refresh;
end;
end;
procedure TMyLabel.setMargin(width1: Integer; width2: Integer);
begin
if
(width1 <> marginTop) or
(width1 <> marginBottom) or
(width2 <> marginRight) or
(width2 <> marginLeft)
then
begin
FmarginTop := width1;
FmarginBottom := width1;
FmarginRight := width2;
FmarginLeft := width2;
refresh;
end;
end;
procedure TMyLabel.setMargin(width1: Integer; width2: Integer; width3: Integer);
begin
if
(width1 <> marginTop) or
(width2 <> marginRight) or
(width2 <> marginLeft) or
(width3 <> marginBottom)
then
begin
FmarginTop := width1;
FmarginRight := width2;
FmarginLeft := width2;
FmarginBottom := width3;
refresh;
end;
end;
procedure TMyLabel.setMargin(width1: Integer; width2: Integer; width3: Integer; width4: Integer);
begin
if
(width1 <> marginTop) or
(width2 <> marginRight) or
(width3 <> marginBottom) or
(width4 <> marginLeft)
then
begin
FmarginTop := width1;
FmarginRight := width2;
FmarginBottom := width3;
FmarginLeft := width4;
refresh;
end;
end;
procedure TMyLabel.setPaddingTop(width: Integer);
begin
if width > -1 then
begin
if width <> paddingTop then
begin
FpaddingTop := width;
refresh;
end;
end
else
begin
FpaddingTop := 0;
refresh;
end;
end;
procedure TMyLabel.setPaddingRight(width: Integer);
begin
if width > -1 then
begin
if width <> paddingRight then
begin
FpaddingRight := width;
refresh;
end;
end
else
begin
FpaddingRight := 0;
refresh;
end;
end;
procedure TMyLabel.setPaddingBottom(width: Integer);
begin
if width > -1 then
begin
if width <> paddingBottom then
begin
FpaddingBottom := width;
refresh;
end;
end
else
begin
FpaddingBottom := 0;
refresh;
end;
end;
procedure TMyLabel.setPaddingLeft(width: Integer);
begin
if width > -1 then
begin
if width <> paddingLeft then
begin
FpaddingLeft := width;
refresh;
end;
end
else
begin
FpaddingLeft := 0;
refresh;
end;
end;
procedure TMyLabel.setPadding(width: Integer);
begin
if
(width <> paddingTop) or
(width <> paddingRight) or
(width <> paddingBottom) or
(width <> paddingLeft)
then
begin
FpaddingTop := width;
FpaddingRight := width;
FpaddingBottom := width;
FpaddingLeft := width;
refresh;
end;
end;
procedure TMyLabel.setPadding(width1: Integer; width2: Integer);
begin
if
(width1 <> paddingTop) or
(width1 <> paddingBottom) or
(width2 <> paddingRight) or
(width2 <> paddingLeft)
then
begin
FpaddingTop := width1;
FpaddingBottom := width1;
FpaddingRight := width2;
FpaddingLeft := width2;
refresh;
end;
end;
procedure TMyLabel.setPadding(width1: Integer; width2: Integer; width3: Integer);
begin
if
(width1 <> paddingTop) or
(width2 <> paddingRight) or
(width2 <> paddingLeft) or
(width3 <> paddingBottom)
then
begin
FpaddingTop := width1;
FpaddingRight := width2;
FpaddingLeft := width2;
FpaddingBottom := width3;
refresh;
end;
end;
procedure TMyLabel.setPadding(width1: Integer; width2: Integer; width3: Integer; width4: Integer);
begin
if
(width1 <> paddingTop) or
(width2 <> paddingRight) or
(width3 <> paddingBottom) or
(width4 <> paddingLeft)
then
begin
FpaddingTop := width1;
FpaddingRight := width2;
FpaddingBottom := width3;
FpaddingLeft := width4;
refresh;
end;
end;
procedure TMyLabel.setTransparent(bool : Boolean);
begin
if bool <> transparent then
begin
if bool then
canvas.brush.style := bsClear
else
begin
canvas.brush.color := Fcolor;
canvas.brush.style := bsSolid;
end;
refresh;
end;
end;
function TMyLabel.getTextHeight : Integer;
begin
getTextHeight := canvas.textHeight(Fcaption);
end;
function TMyLabel.getTextWidth : Integer;
begin
getTextWidth := canvas.textWidth(Fcaption);
end;
function TMyLabel.isTransparent : Boolean;
begin
if canvas.brush.style = bsClear then
isTransparent := true
else
isTransparent := false;
end;
end.
DisableAlign
eEnableAlign
?DoubleBuffered := True
, esta propriedade é pública, ela não estará no object inspector.