1

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.
7
  • 1
    Já tentou utilizar DisableAlign e EnableAlign?
    – Monari
    1/10/2015 às 15:52
  • Não funciona. E estou, realmente, sem conseguir enxergar a causa do problema. De qualquer forma, agradeço a ajuda.
    – user21742
    1/10/2015 às 17:04
  • 1
    Tente utilizar a propriedade DoubleBuffered := True, esta propriedade é pública, ela não estará no object inspector.
    – Monari
    2/10/2015 às 0:35
  • Não existe esta propriedade; o meu componente estende TCustomLabel.
    – user21742
    2/10/2015 às 1:54
  • 1
    Tente remover os refresh por invalidate 4/10/2015 às 14:49

1 Resposta 1

1
    constructor TMyLabel.create(aOwner : TComponent);
    begin
      inherited create(aOwner);

      if AOwner.InheritsFrom(TWinControl) then
      begin
        Self.Parent := (aOwner as TWinControl);
        (aOwner as TWinControl).DoubleBuffered := True;
      end;
...

Você deve fazer log-in para responder a esta pergunta.