[Ankor]

Ну это наверно не очень удобно, каждый раз вырисовывать текст на канве, да и сколько там всего прописывать надо, поэтому я и использую Label, кидаешь их куда угодно, 2 строчки кода и всё.

[angvelem]

Ты спросил, я ответил. Хотя, если завернуть в процедуру, вызов составит 1 строку.

[Ankor]

А в мой модуль нельзя как-нибудь эти Ваши функции завернуть, чтобы потом все Label-ы, более чётче перерисовывались?
А то в данном модуле черная обводка например, на некоторых картинках отсвечивает иногда красным, да и другми цветами, нет четкого контура.

Может можно и проще в модуле дописать, вам как специалистам виднее.

Плюсики, спасибы и благодарности всегда за мной.

[angvelem]

Я тут на скорую руку состряпял юнит:
stroke.pas

Код:

unit stroke;

interface

uses
  Windows, Messages, Classes, Controls, Graphics, StdCtrls;
  
type
  TCustomStrokeLabel	= class(TCustomLabel)
  private
    fShowAccelChar	: Boolean;
    fAlignment		: TAlignment;
    fLayout		: TTextLayout;
    fWordWrap		: Boolean;
    fPathColor		: TColor;
    procedure SetAlignment(Value : TAlignment);
    procedure SetShowAccelChar(Value : Boolean);
    function  GetPathColor : TColor;
    procedure SetPathColor(aColor : TColor);
  protected
    function  GetLabelText : String ; override;
    procedure DoDrawText(var Rect : TRect; Flags : Longint); override;
    procedure Paint; override;

    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property ShowAccelChar : Boolean read FShowAccelChar write SetShowAccelChar default True;
  public
    constructor Create(AOwner : TComponent); override;
    property PathColor : TColor read GetPathColor write SetPathColor default clRed;
  end;
    
  TStrokeLabel		= class(TCustomStrokeLabel)
  published
    property Align;
    property Alignment;
    property Anchors;
    property AutoSize;
    property BiDiMode;
    property Caption;
    property Color nodefault;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FocusControl;
    property Font;
    property ParentBiDiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PathColor;
    property PopupMenu;
    property ShowAccelChar;
    property ShowHint;
    property Transparent;
    property Layout;
    property WordWrap;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

{ TStrokeLabel }

constructor TCustomStrokeLabel.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  fShowAccelChar := True;
  fPathColor := clRed;
end;

function TCustomStrokeLabel.GetLabelText : String;
begin
  Result := Caption;
end;

procedure TCustomStrokeLabel.DoDrawText(var Rect : TRect; Flags : Longint);
var
  Text : String;
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 not Enabled then
  begin
    OffsetRect(Rect, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
    OffsetRect(Rect, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  end
  else
  begin
    Canvas.Brush.Style := bsClear;
    Canvas.Pen.Color := fPathColor;
    BeginPath(Canvas.Handle);
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
    EndPath(Canvas.Handle); 
    Canvas.Brush.Style := bsSolid;
    Canvas.Brush.Color := Canvas.Font.Color;
    StrokeAndFillPath(Canvas.Handle);
  end;
end;

procedure TCustomStrokeLabel.Paint;
const
  Alignments : array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  WordWraps  : array[Boolean] of Word = (0, DT_WORDBREAK);
var
  Rect, CalcRect : TRect;
  DrawStyle      : Longint;
begin
  with Canvas do
  begin
    if not Transparent then
    begin
      Brush.Color := Self.Color;
      Brush.Style := bsSolid;
      FillRect(ClientRect);
    end;
    Brush.Style := bsClear;
    Rect := ClientRect;
    { DoDrawText takes care of BiDi alignments }
    DrawStyle := DT_EXPANDTABS or WordWraps[FWordWrap] or Alignments[FAlignment];
    { Calculate vertical layout }
    if FLayout <> tlTop then
    begin
      CalcRect := Rect;
      DoDrawText(CalcRect, DrawStyle or DT_CALCRECT);
      if FLayout = tlBottom then
        OffsetRect(Rect, 0, Height - CalcRect.Bottom)
      else
        OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);
    end;
    DoDrawText(Rect, DrawStyle);
  end;
end;

procedure TCustomStrokeLabel.SetAlignment(Value : TAlignment);
begin
  if fAlignment <> Value then
  begin
    fAlignment := Value;
    Invalidate;
  end;
end;

procedure TCustomStrokeLabel.SetShowAccelChar(Value : Boolean);
begin
  if FShowAccelChar <> Value then
  begin
    FShowAccelChar := Value;
    Invalidate;
  end;
end;

function TCustomStrokeLabel.GetPathColor : TColor;
begin
  Result := fPathColor;
end;

procedure TCustomStrokeLabel.SetPathColor(aColor : TColor);
begin
  if fPathColor <> aColor then
  begin
    fPathColor := aColor;
    Invalidate;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TStrokeLabel]);
end;

end.

stroke_d7.dpk

Код:

package stroke_d7;

{$ALIGN ON}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO ON}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS ON}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO ON}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST ON}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESCRIPTION 'Stroke Label'}
{$IMPLICITBUILD OFF}

requires
  vcl70;

contains
  Stroke in 'Stroke.pas';

end.

stroke_d2009.dpk

Код:

package stroke_d2009;

{$ALIGN ON}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO ON}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS ON}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO OFF}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST ON}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESCRIPTION 'Stroke Label'}
{$IMPLICITBUILD ON}

requires
  rtl,
  vcl;

contains
  stroke in 'stroke.pas';

end.

[Ankor]

Спасибо огромное за труды, правда мне в этом не разобраться(.

Я вот Ваш юнит сделал, вроде без ошибок компилируется, а как всё это хозяйство к Label-ам применить?

Вот если можно, на моём примере покажите пожалуйста, а то я и за пол года не разбирусь.

[angvelem]

Сообщение от Ankor

...Я вот Ваш юнит сделал, вроде без ошибок компилируется, а как всё это хозяйство к Label-ам применить? ...

Модуль рабочий, протестирован в Дельфи 7 и 2009. Второй и третий файлы это установщики для соответствующих версий дельфи. Выбирай подходящий и запускай - установится в закладку Samples под названием TStrokeLabel. Использовать точно также как и обычный TLabel, добавлено свойство PathColor, им выставляется цвет обводки текста.

[Ankor]

Ну вроде установил, правда четкой обводки по контуру не получилось.

В любом случае огромное спасибо, наверно как-то допиливать придётся.

[angvelem]

Несколько изменил вывод текста, для более чёткой прорисовки. Up.

[Ankor]

Спасибо.

Я тут нашел более крутой компонент, там и ширину тени, и цвета, и много чего можно сразу выставлять, да вот беда, именно нужного свойства - обводки текста по периметру(контуру) там нету.
Наверняка там несложно одну функцию эту добавить, и было бы вообще супер.

Если будет время и желание, посмотрите пожалуйста этот компонент.
Буду признателен.

Текст файла не уместился, поэтому вложение сделал.

[Страдалецъ]

Есть совершенно бесплатные и очень симпатишные компоненты AlphaControls. Искомый вами эффект и еще куча всяких вкусностей там есть. Попробуйте.

[angvelem]

Сообщение от Ankor

...Я тут нашел более крутой компонент...

Всю крутость весьма легко добавить, смотри как реализуется свойство PathColor, по аналогии добавляйте свои. Дополнительно смотрите как свойства реализуются в Дельфи у разных классов. Если знаний не хватает используйте вариант от Страдалецъ.

[Ankor]

Спасибо и на этом. Вариант AlphaControls мне не подходит.

Кстати Вы последний свой исправленный пример с лучшей чёткостью сами то смотрели?
Там если размер текста Size = 8, то весь текст закрашивается, без всякой обводки, вот я и нашел другой, более навороченный компонент, но это уже не важно.
Сам я врядли конечно сделаю, если спецам даже иногда не удаётся.

Спс за внимание.

[angvelem]

Конечно смотрел. Беда в том, что используя функцию StrokeAndFillPath, хорошой читабельности можно добиться только при достаточно большом размере шрифта. Увы по-другому она не умеет. Я эту функцию использовал не для TLabel, а когда мне нужно было вывести сообщение привлекающее внимание - достаточно крупное.
P.S. Для маленьких шрифтов я делал не обводку, а тень - с выбором позиции, размера и цвета.

[Ankor]

Ну да бог тогда с Вашей функцией, а Вы вот этот модуль можете мне доработать так, чтобы его как компонент (название - LabelF) можно было на делфи установить, со всеми свойствами обычного Label и там несколько новых, которые в модуле?
В какой раздел среды неважно, можно и в вкладку Samples.

Код:

unit LabelShadowUnit;

interface

uses
  SysUtils, Classes, Graphics, Controls, StdCtrls;

type
  TLabel2       = class(TLabel);
  TLabel        = class(TLabel2)
    constructor Create(Owner : TComponent); override;
    destructor Destroy; override; //запуск деструктора
    procedure AddShadow(x: integer = 3; y: integer = 1; colorr : TColor = clBlack);
    procedure AddShadowText(widthh : byte = 1; colorr : TColor = clBlack);
    procedure ClearShadow;
  private
    shad : TList;
  end;

implementation

{ TLabel }

procedure TLabel.AddShadow(x : integer = 3; y : integer = 1; colorr : TColor = clBlack);
var
  sh: TLabel;
begin
  sh := TLabel.Create(self.Owner);
  with sh do
  begin
    WordWrap    := self.WordWrap;
    Alignment   := self.Alignment;
    Autosize    := self.AutoSize;
    Parent      := TWinControl(self.Parent);
    Font        := self.Font;
    Top         := self.Top + y;
    Left        := self.Left + x;
    Width       := self.width;
    Height      := self.Height;
    Font.Color  := colorr;
    Caption     := self.Caption;
    Transparent := True;
  end;
  self.Transparent := True;
  self.BringToFront;
  shad.Add(sh);
end;

procedure TLabel.AddShadowText(widthh: byte; colorr : TColor);
begin
  // прямоугольник
  AddShadow(widthh, 0, colorr);
  AddShadow(-1 * widthh, 0, colorr);
  AddShadow(0, widthh, colorr);
  AddShadow(0, -1 * widthh, colorr);
  // по бокам
  AddShadow(widthh, widthh, colorr);
  AddShadow(-1 * widthh, -1 * widthh, colorr);
  AddShadow(-1 * widthh, widthh, colorr);
  AddShadow(widthh, -1 * widthh, colorr);
end;

procedure TLabel.ClearShadow;
var
  I : Integer;
begin
  for I := 0 to shad.Count - 1 do
    TLabel(shad[i]).Destroy;
  shad.Clear;
end;

constructor TLabel.Create(Owner : TComponent);
begin
  inherited Create(Owner);
  shad := TList.Create;
end;

destructor TLabel.Destroy;
var
  I : Integer;
begin
  for I := 0 to shad.Count - 1 do
    TLabel(shad[i]).Destroy;
  shad.Destroy;
  inherited Destroy;
end;

end.

[YVitaliy]

Добавь в модуль

Код:

procedure Register;
begin
  RegisterComponents('Additional', [TShadowLabel]);
end;

А потом Component-Install Component, выбираешь Into New Package, указываешь путь к юниту, имя, описание, жмешь Ok