1
The following code is a component (unfinished), a label
, what I was/am trying to do. The idea was to create a label in which I could define edges, paddings and edges, being that for the edges the thickness is common to all and that I can define the presence or not (from the top edge, right edge, bottom edge and left edge).
I left the rewriting of the Paint method last that, in this case, I have not finished because I detected that by instantiating an object of my class (TMyLabel
) and define the presence of one of the edges (upper edge, for example) by the boolean property borderTop
and the common thickness (at all edges) via whole property borderWidth
, the form keeps blinking.
Commented the line on which I specify a value for edge thickness (borderWidth := valor
) or in which I define the presence of the upper edge (borderTop := true
), form does not flash anymore. I have looked at the methods (setters) associated with the two properties and do not find the error.
My intuition said that the blinking form could only be error in looping
or in recursive Procedure/function call, which is not the case. If anyone can help me, I would be grateful.
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.
Have you tried using
DisableAlign
andEnableAlign
?– Monari
It doesn’t work. And I’m really unable to see the cause of the problem. Anyway, I appreciate the help.
– user21742
Try to use the property
DoubleBuffered := True
, this property is public, it will not be in the inspector Object.– Monari
This property does not exist; my component extends Tcustomlabel.
– user21742
Got it. This property belongs to Owner (Twincontrol). I added the line (aOwner as Twincontrol) to the constructor. Doublebuffered := True; and stopped flashing; it worked.
– user21742
The bad thing is that, since Tcustomlabel is not a Twincontrol, it is necessary to change a property of Parent/Owner. This is really not good. But, anyway, now that the why of the problem has been found (thank you!), I will run after a way to add Doublebuffered to that class. It seems that if I didn’t understand wrong, this problem is because of the refreshs.
– user21742
Try to remove the refresh by invalidate
– EProgrammerNotFound