Как сделать текст светящимся

Имея свой самописный элемент управления кнопкой (TMyButton), полученный из TCustomControl, я хочу добавить возможность создавать эффект свечения для подписи MyButton. После долгого пребывания в Гулге я понял, что лучший способ создать свечение - это нарисовать текст заданным цветом, затем размыть все - текст и поверхность, на которой он лежит, а затем снова нарисовать текст. Он будет работать отлично, только если поверхность твердая, например. заливает красным цветом. Я создал процедуру, которая делает растровое изображение размытым, но моя кнопка может иметь не сплошной фон, например растровое изображение, которое может быть заполнено градиентом. Если я размою этот фон, он станет очень ужасным, но свечение выглядит красиво.

Я предполагаю, что эту задачу можно решить с помощью Scanline, но я понятия не имею, что именно мне с ним делать.

Если использовать сплошную заливку, у меня есть это (заполнено clWhite): размытие со сплошной заливкой

Если использовать растровую заливку, у меня есть это («Текст» имеет тень clBlack): размытое растровое изображение

Вот так выглядит размытое растровое изображение, показанное выше, без размытия: исходное растровое изображение

Кто-нибудь знает, как сделать эффект свечения для текста без размытия растрового изображения?

P.S. код для размытия растрового изображения

procedure DrawBlurEffect(BmpInOut: TBitmap; Radius: Integer);
var
  A, B, C, D: PRGBArray;
  x, y, i: Integer;
begin
  BmpInOut.PixelFormat := pf24bit;
  for i:=0 to Radius do
    begin
      for y:=2 to BmpInOut.Height - 2 do
        begin
          A := BmpInOut.ScanLine[y-1];
          B := BmpInOut.ScanLine[y];
          C := BmpInOut.ScanLine[y+1];
          D := BmpInOut.ScanLine[y];
          for x:=1 to BmpInOut.Width - 2 do
            begin
              B[x].Red   := Trunc(C[x].Red   + A[x].Red   + B[x-1].Red   + D[x+1].Red)   div 4;
              B[x].Green := Trunc(C[x].Green + A[x].Green + B[x-1].Green + D[x+1].Green) div 4;
              B[x].Blue  := Trunc(C[x].Blue  + A[x].Blue  + B[x-1].Blue  + D[x+1].Blue)  div 4;
            end;
        end;
    end;
end;

person Josef Švejk    schedule 08.12.2015    source источник
comment
Вычисляя прямоугольник заголовка и применяя размытие только к этому прямоугольнику, а не ко всей кнопке?   -  person kludg    schedule 08.12.2015
comment
возможно, поможет stackoverflow.com/questions/4804777/   -  person kwarunek    schedule 09.12.2015
comment
@ user246408, я пробовал, но как насчет размытых углов текстового прямоугольника? Они недостаточно прозрачны и повреждают растровое изображение назначения.   -  person Josef Švejk    schedule 09.12.2015
comment
@kAlmAcetA, спасибо, но PNG — это не то, что мне нужно.   -  person Josef Švejk    schedule 09.12.2015


Ответы (1)


Нарисуйте текст на стекле (Vista и выше), используя DrawThemeTextEx с набором DTTOPT светящийся флаг.

uses Types, UxTheme, Themes, Graphics;

procedure DrawGlassText(Canvas: TCanvas; GlowSize: Integer; var Rect: TRect;
  var Text: UnicodeString; Format: DWORD); overload;
var
  DTTOpts: TDTTOpts;
begin
  if Win32MajorVersion < 6 then
  begin
    DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Format);
    Exit;
  end;
  ZeroMemory(@DTTOpts, SizeOf(DTTOpts));
  DTTOpts.dwSize := SizeOf(DTTOpts);
  DTTOpts.dwFlags := DTT_COMPOSITED or DTT_TEXTCOLOR;
  if Format and DT_CALCRECT = DT_CALCRECT then
    DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_CALCRECT;
  DTTOpts.crText := ColorToRGB(Canvas.Font.Color);
  if GlowSize > 0 then
  begin
    DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_GLOWSIZE;
    DTTOpts.iGlowSize := GlowSize;
  end;
  with ThemeServices.GetElementDetails(teEditTextNormal) do
    DrawThemeTextEx(ThemeServices.Theme[teEdit], Canvas.Handle, Part, State,
      PWideChar(Text), Length(Text), Format, @Rect, DTTOpts);
end;

Существует TransparentCanvas, который можно использовать для установки цвета свечения.

Как развлечение :). Я помню, что некоторые компоненты (d2) для имитации эффекта свечения использовали простую (плохую) технику - текст позади с определенным цветом свечения - тенью.

procedure TExampleGlowLabel.DoDrawText( var Rect : TRect; Flags : Word );
var
  Text       : array[ 0..255 ] of Char;
  TmpRect    : TRect;
begin
  GetTextBuf(Text, SizeOf(Text));
  if ( Flags and DT_CALCRECT <> 0) and
     ( ( Text[0] = #0 ) or ShowAccelChar and
       ( Text[0] = '&' ) and
       ( Text[1] = #0 ) ) then
    StrCopy(Text, ' ');

  if not ShowAccelChar then
    Flags := Flags or DT_NOPREFIX;
  Canvas.Font := Font;

  if FGlowing and Enabled then
  begin
    TmpRect := Rect;
    OffsetRect( TmpRect, 1, 1 );
    Canvas.Font.Color := GlowColor;
    DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);

    TmpRect := Rect;
    OffsetRect( TmpRect, -1, -1 );
    Canvas.Font.Color := GlowColor;
    DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);

    TmpRect := Rect;
    OffsetRect( TmpRect, -1, 1 );
    Canvas.Font.Color := GlowColor;
    DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);

    TmpRect := Rect;
    OffsetRect( TmpRect, 1, -1 );
    Canvas.Font.Color := GlowColor;
    DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
  end;

  Canvas.Font.Color := Font.Color;
  if not Enabled then
    Canvas.Font.Color := clGrayText;
  DrawText(Canvas.Handle, Text, StrLen(Text), Rect, Flags);
end;

Как упоминалось в комментарии TButton с прозрачным изображением PNG и светящимся эффектом наведения имеет ответ с некоторыми несвободными компонентами.

изменить

Другим подходом было бы использование эффектов FireMonkey (действительно круто) TGlowEffect, но, наверное, это относится ко всему полотну.

person kwarunek    schedule 09.12.2015
comment
Я уже видел трюк с DrawThemeTextEx ранее, но мое приложение можно использовать как минимум под WinXp и там этот способ не работает. Кроме того, я хотел бы получить бесплатный ответ - без каких-либо коммерческих компонентов. FireMonkey не является решением для меня. - person Josef Švejk; 09.12.2015