3 respuestas en este tema

[Pratasvenska]

Hola amigos,

Quiero que el caption de un label se muestre de la siguiente forma, por ejemplo:

El alumno Juan Perez fue expulsado.

Espero alguien me pueda aconsejar... Por diversas razones no puedo usar multiples labels., tiene que ser todo en una.

Saludos.

[TiammatMX]

Con un TRichEdit puedes hacer éste efecto, si lo adaptas al tamaño que cualquier TLabel exhibe. Rellenarlo en tiempo de ejecución es otro cantar, pero de que sucederá lo que necesitas, ni quien lo dude.

Bienvenido.

[razadi]

Segun yo nada mejor que te hagas tus propios componente que puedes ir adaptando conforme los ocupas, hace algun tiempo me hice unas labels que requeria y una de ellas era precisamente que me permitiera poner en medio de una frase algunas caracteristicas como el html y pos me di a la tarea de hacerla y con gusto la comparto para todos los "comuneros" y espero te sirva, saludos

delphi

unit eLabels;
 
interface
 
uses
  Windows, Classes, Controls, SysUtils, Graphics, ImgList, Messages,
  Forms, Math, Types, cSharedCommon, cSharedDraw, cClasses, StdCtrls,
  UxTheme, Themes, DwmApi
 
 
type
 
  TeLinkLabelDisplayMode = (dmNone, dmGlyph, dmImageList);
 
  TeLinkLabel = class(TCustomControl)
  private
    FCaption: WideString;
    FDisplayMode: TeLinkLabelDisplayMode;
    FGlyph: TBitmap;
    FHover: Boolean;
    FImageIndex: TImageIndex;
    FImages: TCustomImageList;
    FTextDistance: Integer;
    FTransparent: Boolean;
    FTransparentColor: TColor;
    FVertSpacing: Integer;
    procedure ApplyTransparentColor(const Value: TColor);
    procedure MakeAutoSize(var NewWidth: Integer; var NewHeight: Integer);
    procedure SetCaption(const Value: WideString);
    procedure SetDisplayMode(const Value: TeLinkLabelDisplayMode);
    procedure SetGlyph(const Value: TBitmap);
    procedure SetImageIndex(const Value: TImageIndex);
    procedure SetImages(const Value: TCustomImageList);
    procedure SetTextDistance(const Value: Integer);
    procedure SetTransparent(const Value: Boolean);
    procedure SetTransparentColor(const Value: TColor);
    procedure SetVertSpacing(const Value: Integer);
  protected
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    procedure Changed;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
	  procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DoEnter; override;
    procedure DoExit; override;
    procedure DoGlyphChange(Sender: TObject);
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Paint; override;
    procedure RefreshText;
    procedure SetName(const Value: TComponentName); override;
    procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
    procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;	public
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Action;
    property Align;
    property Anchors;
    property AutoSize default True;
    property Caption: WideString read FCaption write SetCaption;
    property Color;
    property Constraints;
    property DisplayMode: TeLinkLabelDisplayMode read FDisplayMode write SetDisplayMode default dmGlyph;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
    property Images: TCustomImageList read FImages write SetImages;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TextDistance: Integer read FTextDistance write SetTextDistance;
    property TabStop;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clNone;
    property Visible;
    property VertSpacing: Integer read FVertSpacing write SetVertSpacing;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;
 
 
  TeHtmlLabel = class(TCustomControl)
  private
    FCaption: WideString;
    FOnLinkClick: TeHtmlClicEvento;
    FWordWrap: Boolean;
    FShowAccelChar: Boolean;
    FEllipsisPosition: TEllipsisPosition;
    procedure SetCaption(const Value: WideString);
    procedure SetWordWrap(const Value: Boolean);
    procedure SetShowAccelChar(const Value: Boolean);
    procedure SetEllipsisPosition(const Value: TEllipsisPosition);
  protected
    procedure AdjustBounds; dynamic;
    procedure DoDrawText(var Rect: TRect; Flags: Longint); dynamic;
    function GetLabelText: string; virtual;
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
    procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
    property EllipsisPosition: TEllipsisPosition read FEllipsisPosition write SetEllipsisPosition default epNone;
    property ShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar default False;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Action;
    property Align;
    property Anchors;
    property AutoSize default False;
    property Caption: WideString read FCaption write SetCaption;
    property Color;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabStop;
    property Visible;
    property WordWrap: Boolean read FWordWrap write SetWordWrap default False;
 
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnLinkClick: TeHtmlClicEvento read FOnLinkClick write FOnLinkClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;
 
procedure Register;
 
implementation
 
procedure Register;
begin
  RegisterComponents('Componentes efectisoft', [TeLinkLabel,TeHtmlLabel]);
end;
 
{ TeLinkLabel }
 
procedure TeLinkLabel.ApplyTransparentColor(const Value: TColor);
begin
  FGlyph.Transparent := True;
  FGlyph.TransparentColor := Value;
end;
 
function TeLinkLabel.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
var
  ANewWidth, ANewHeight: Integer;
begin
  Result := True;
  MakeAutoSize(ANewWidth, ANewHeight);
  if Align in [alNone, alLeft, alRight] then
    NewWidth := ANewWidth;
  if Align in [alNone, alTop, alBottom] then
    NewHeight := ANewHeight;
end;
 
procedure TeLinkLabel.Changed;
begin
  if AutoSize then AdjustSize
    else Invalidate;
end;
 
procedure TeLinkLabel.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  RefreshText;
end;
 
procedure TeLinkLabel.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Changed;
end;
 
procedure TeLinkLabel.CMMouseEnter(var Message: TMessage);
begin
  if not(csDesigning in ComponentState) then begin
    FHover := True;
    RefreshText;
  end;
end;
 
procedure TeLinkLabel.CMMouseLeave(var Message: TMessage);
begin
  if not(csDesigning in ComponentState) then begin
    FHover := False;
    RefreshText;
  end;
end;
 
procedure TeLinkLabel.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
  Realign;
end;
 
constructor TeLinkLabel.Create(AOwner: TComponent);
begin
  inherited;
  ControlStyle := [csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks, csReplicatable];
  DoubleBuffered := True;
  AutoSize := True;
  FDisplayMode := dmGlyph;
  FGlyph := TBitmap.Create;
  FGlyph.OnChange := DoGlyphChange;
  FImageIndex := -1;
  FImages := nil;
  FTransparentColor := clNone;
  FHover := False;
  FTextDistance := 2;
  FTransparent := False;
  FVertSpacing := 2;
  ParentColor := True;
end;
 
procedure TeLinkLabel.CreateParams(var Params: TCreateParams);
begin
  inherited;
 
end;
 
procedure TeLinkLabel.CreateWnd;
begin
  inherited;
 
end;
 
destructor TeLinkLabel.Destroy;
begin
  FGlyph.Free;
  inherited;
end;
 
procedure TeLinkLabel.DoEnter;
begin
  inherited;
  Invalidate;
end;
 
procedure TeLinkLabel.DoExit;
begin
  inherited;
  Invalidate;
end;
 
procedure TeLinkLabel.DoGlyphChange(Sender: TObject);
begin
  ApplyTransparentColor(FGlyph.Canvas.Pixels[0, FGlyph.Height - 1]);
  Changed;
end;
 
procedure TeLinkLabel.MakeAutoSize(var NewWidth, NewHeight: Integer);
begin
  if HandleAllocated then begin
    Canvas.Font.Assign(Font);
    NewHeight := Canvas.TextHeight(Caption);
    NewWidth := Canvas.TextWidth(Caption);
    case FDisplayMode of
      dmGlyph:
        if not Glyph.Empty then with Canvas do begin
          if FGlyph.Height > NewHeight then NewHeight := FGlyph.Height;
          Inc(NewWidth, FGlyph.Width + FTextDistance);
        end;
      dmImageList:
        if Assigned(FImages) and InRange(FImageIndex, 0, FImages.Count) then begin
          if FImages.Height > NewWidth then NewHeight := FImages.Height;
          Inc(NewWidth, FImages.Width + FTextDistance);
        end;
    end;
    NewHeight := NewHeight + FVertSpacing;
  end;
end;
 
procedure TeLinkLabel.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if TabStop then
  begin
    SetFocus;
    Invalidate;
  end;
end;
 
procedure TeLinkLabel.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) and (AComponent = FImages) then FImages := nil;
end;
 
procedure TeLinkLabel.Paint;
var
	X, Y: Integer;
  fr: TRect;
begin
  inherited;
	X := 0;
  with Canvas do begin
    if Transparent then
      DrawTransparent(Self, Canvas)
    else begin
      Brush.Color := Self.Color;
      FillRect(ClientRect);
    end;
    case FDisplayMode of
      dmGlyph:
        if not(FGlyph.Empty) then begin
          Y := (Height div 2) - (FGlyph.Height div 2);
          FGlyph.Transparent := True;
          DrawBitmap(Canvas, X, Y, FGlyph, Color);
          Inc(X, FGlyph.Width + FTextDistance);
        end;
      dmImageList:
        if Assigned(FImages) and InRange(FImageIndex, 0, FImages.Count) then begin
          Y := (Height div 2) - (Images.Height div 2);
          FGlyph.Transparent := True;
          FImages.Draw(Canvas, X, Y, FImageIndex);
          Inc(X, FImages.Width + FTextDistance);
        end;
    end;
    Font.Assign(Self.Font);
    if FHover then
      Font.Style := Font.Style + [fsUnderline];
    if not Enabled then
      Font.Color := clGrayText;
    TGraphicsProvider.DrawTextRect(Canvas, Rect(X, 0, Width, Height), taLeftJustify, Caption);
    fr := Rect(0, 0, Width, Height);
    if Focused then
      TGraphicsProvider.DrawFocused(Canvas, fr);
  end;
end;
 
procedure TeLinkLabel.RefreshText;
var
  r: TRect;
begin
  if not(FGlyph.Empty) then r := Rect(FGlyph.Width + FTextDistance, 0, ClientWidth, ClientHeight) else r := ClientRect;
  InvalidateRect(Handle, @r, False);
end;
 
procedure TeLinkLabel.SetCaption(const Value: WideString);
begin
  FCaption := Value;
  Changed;
end;
 
procedure TeLinkLabel.SetDisplayMode(const Value: TeLinkLabelDisplayMode);
begin
  FDisplayMode := Value;
  Changed;
end;
 
procedure TeLinkLabel.SetGlyph(const Value: TBitmap);
begin
  FGlyph.Assign(Value);
  Changed;
end;
 
procedure TeLinkLabel.SetImageIndex(const Value: TImageIndex);
begin
  FImageIndex := Value;
  Invalidate;
end;
 
procedure TeLinkLabel.SetImages(const Value: TCustomImageList);
begin
  FImages := Value;
  if Value <> nil then begin
    FImages.FreeNotification(Self);
  end else begin
    FImages.RemoveFreeNotification(Self);
  end;
end;
 
procedure TeLinkLabel.SetName(const Value: TComponentName);
begin
  inherited;
  if not (csLoading in ComponentState) then
    if Caption = '' then
      Caption := Name;
end;
 
procedure TeLinkLabel.SetTextDistance(const Value: Integer);
begin
  FTextDistance := Value;
  Changed;
end;
 
procedure TeLinkLabel.SetTransparent(const Value: Boolean);
begin
  FTransparent := Value;
  Invalidate;
end;
 
procedure TeLinkLabel.SetTransparentColor(const Value: TColor);
begin
  FTransparentColor := Value;
  ApplyTransparentColor(FTransparentColor);
end;
 
procedure TeLinkLabel.SetVertSpacing(const Value: Integer);
begin
  FVertSpacing := Value;
  Changed;
end;
 
procedure TeLinkLabel.WMEraseBkGnd(var Message: TWMEraseBkGnd);
begin
  Message.Result := 1;
end;
 
procedure TeLinkLabel.WMKillFocus(var Message: TWMSetFocus);
begin
  inherited;
  Invalidate;
end;
 
procedure TeLinkLabel.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
  inherited;
  if Transparent then
    Invalidate;
end;
 
{ TeHtmlLabel }
 
procedure TeHtmlLabel.AdjustBounds;
const
  WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
  DC: HDC;
  X: Integer;
  Rect: TRect;
  AAlignment: TAlignment;
begin
  if not (csReading in ComponentState) and AutoSize then begin
    Rect := ClientRect;
    DC := GetDC(0);
    try
      Canvas.Handle := DC;
      DoDrawText(Rect, (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[FWordWrap]);
      Canvas.Handle := 0;
    finally
      ReleaseDC(0, DC);
    end;
    X := Left;
    //AAlignment := FAlignment;
    if UseRightToLeftAlignment then
      ChangeBiDiModeAlignment(AAlignment);
    //if AAlignment = taRightJustify then
      Inc(X, Width - Rect.Right);
    SetBounds(X, Top, Rect.Right, Rect.Bottom);
  end;
end;
 
function TeHtmlLabel.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
var
  HtmlInfo: THtmlInfo;
begin
  Result := True;
  HtmlInfo := ProcessHTML(Canvas, ClientRect, Caption, Point(0, 0), False);
  NewWidth := HtmlInfo.Size.cx;
  NewHeight := HtmlInfo.Size.cy;
end;
 
procedure TeHtmlLabel.CMMouseLeave(var Message: TMessage);
begin
  if Screen.Cursor = crHandPoint then
    Screen.Cursor := Cursor;
end;
 
constructor TeHtmlLabel.Create(AOwner: TComponent);
begin
  inherited;
 
end;
 
destructor TeHtmlLabel.Destroy;
begin
 
  inherited;
end;
 
procedure TeHtmlLabel.DoDrawText(var Rect: TRect; Flags: Integer);
  procedure DoDrawThemeTextEx(DC: HDC; const Text: string;
    var TextRect: TRect; TextFlags: Cardinal);
  var
    Options: TDTTOpts;
  begin
    FillChar(Options, SizeOf(Options), 0);
    Options.dwSize := SizeOf(Options);
    Options.dwFlags := DTT_TEXTCOLOR or DTT_COMPOSITED;
    if TextFlags and DT_CALCRECT = DT_CALCRECT then
      Options.dwFlags := Options.dwFlags or DTT_CALCRECT;
    Options.crText := ColorToRGB(Canvas.Font.Color);
 
    with ThemeServices.GetElementDetails(teEditTextNormal) do
      DrawThemeTextEx(ThemeServices.Theme[teEdit], DC, Part, State,
        PWideChar(WideString(Text)), Length(WideString(Text)), TextFlags, @TextRect, Options);
  end;
 
  procedure DrawText(DC: HDC; const Text: string; TextLen: Integer;
    var TextRect: TRect; TextFlags: Cardinal);
  var
    LForm: TCustomForm;
    PaintOnGlass: Boolean;
  begin
    PaintOnGlass := ThemeServices.ThemesEnabled and DwmCompositionEnabled and
      not (csDesigning in ComponentState);
    if PaintOnGlass then
    begin
      LForm := GetParentForm(Self);
      PaintOnGlass := (LForm <> nil) and LForm.GlassFrame.FrameExtended and
        LForm.GlassFrame.IntersectsControl(Self);
    end;
    if PaintOnGlass then
      DoDrawThemeTextEx(DC, Text, TextRect, TextFlags)
    else
     Windows.DrawText(DC, PChar(Text), TextLen, TextRect, TextFlags);
  end;
 
const
  EllipsisStr = '...';
  Ellipsis: array[TEllipsisPosition] of Longint = (0, DT_PATH_ELLIPSIS,
    DT_END_ELLIPSIS, DT_WORD_ELLIPSIS);
var
  Text, DText: string;
  NewRect: TRect;
  Height, Delim: Integer;
begin
  Text := GetLabelText;
  if (Flags and DT_CALCRECT <> 0) and ((Text = '') or FShowAccelChar and
    (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  if not FShowAccelChar then Flags := Flags or DT_NOPREFIX;
  Flags := DrawTextBiDiModeFlags(Flags);
  Canvas.Font := Font;
  if (FEllipsisPosition <> epNone) and not AutoSize then
  begin
    DText := Text;
    Flags := Flags and not DT_EXPANDTABS;
    Flags := Flags or Ellipsis[FEllipsisPosition];
    if FWordWrap and (FEllipsisPosition in [epEndEllipsis, epWordEllipsis]) then
    begin
      repeat
        NewRect := Rect;
        Dec(NewRect.Right, Canvas.TextWidth(EllipsisStr));
        Windows.DrawText(Canvas.Handle, PChar(DText), Length(DText), NewRect, Flags or DT_CALCRECT);
        Height := NewRect.Bottom - NewRect.Top;
        if (Height > ClientHeight) and (Height > Canvas.Font.Height) then
        begin
          Delim := LastDelimiter(' '#9, Text);
          if Delim = 0 then
            Delim := Length(Text);
          Dec(Delim);
          if ByteType(Text, Delim) = mbLeadByte then
            Dec(Delim);
          Text := Copy(Text, 1, Delim);
          DText := Text + EllipsisStr;
          if Text = '' then
            Break;
        end else
          Break;
      until False;
    end;
    if Text <> '' then
      Text := DText;
  end;
  if not Enabled then
  begin
    OffsetRect(Rect, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, Text, Length(Text), Rect, Flags);
    OffsetRect(Rect, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, Text, Length(Text), Rect, Flags);
  end
  else
    DrawText(Canvas.Handle, Text, Length(Text), Rect, Flags);
end;
 
function TeHtmlLabel.GetLabelText: string;
begin
  Result := Caption;
end;
 
procedure TeHtmlLabel.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
 
end;
 
procedure TeHtmlLabel.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  TagValue: WideString;
begin
  inherited;
  TagValue := ProcessHTML(Canvas, Self.ClientRect, Caption, Point(X, Y), False).TagValue;
  if TagValue <> '' then
    Screen.Cursor := crHandPoint
  else
    Screen.Cursor := Cursor;
end;
 
procedure TeHtmlLabel.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  TagValue: WideString;
begin
  inherited;
  TagValue := ProcessHTML(Canvas, Self.ClientRect, Caption, Point(X, Y), False).TagValue;
  if TagValue <> '' then
    if Assigned(OnLinkClick) then
      OnLinkClick(Self, TagValue);
end;
 
procedure TeHtmlLabel.Paint;
begin
  inherited;
  with Canvas do begin
    Font.Assign(Self.Font);
    Brush.Color := Color;
    FillRect(ClientRect);
  end;
  ProcessHTML(Canvas, ClientRect, Caption, Point(0, 0), True);
end;
 
procedure TeHtmlLabel.SetCaption(const Value: WideString);
begin
  FCaption := Value;
  Invalidate;
end;
 
procedure TeHtmlLabel.SetEllipsisPosition(const Value: TEllipsisPosition);
begin
  if FEllipsisPosition <> Value then begin
    FEllipsisPosition := Value;
    AutoSize := False;
    Invalidate;
  end;
end;
 
procedure TeHtmlLabel.SetShowAccelChar(const Value: Boolean);
begin
  if FShowAccelChar <> Value then begin
    FShowAccelChar := Value;
    Invalidate;
  end;
end;
 
procedure TeHtmlLabel.SetWordWrap(const Value: Boolean);
begin
  if FWordWrap <> Value then begin
    FWordWrap := Value;
    AdjustBounds;
    Invalidate;
  end;
end;
 
procedure TeHtmlLabel.WMEraseBkGnd(var Message: TWMEraseBkGnd);
begin
  Message.Result := 1;
end;
 
end.

y cuando la llamas la usas tan simple como:

delphi

...
var
  miLabel: TeHTMLLabel;
begin
...
   miLabel.Caption := 'El alumno <b>Juan Perez</b> fue expulsado.';
...

espero te sirva, saludos.

[Pratasvenska]

Hola, disculpa tenía días que no me pasaba por aquí pero ahora veo tu solución. Claro que sirve. Muchas gracias!