问

如何在自定义TGraphicControl上绘制淡出文本？

 吴钧隆362 发布于 2023-02-10 14:32
  • go
  • chrome
  • label
  • ip
  • text
  • copy

    • 我想在TGraphicControl上绘制淡出文本,比如Google Chrome上的标签,当没有足够的空间在Canvas上显示整个文本时.

    因此,我不想显示省略文本(我知道该怎么做),而是希望它像这样淡出: 德尔福

    TGraphicControl需要具有透明选项,如TCustomLabel(ControlStyle - [csOpaque]).

    这对GDIPlus来说可能是一件容易的事,但我需要使用纯GDI.

    我也尝试研究TGradText v.1.0(直接下载)的代码,它几乎完全符合我的需要 - 它可以绘制透明文本,但结果看起来非常糟糕而且不顺畅.我猜是因为它为这个任务制作了一个pmCopy掩码.

    这是我根据Andreas Rejbrand的回答编写的代码.我在TImage上使用了PaintBox并预渲染了背景:

    type
  TParentControl = class(TWinControl);

{ This procedure is copied from RxLibrary VCLUtils }  
procedure CopyParentImage(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
    with Control do
    begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left; Y := -Top;
    end;
    { Copy parent control image }
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
      with TParentControl(Control.Parent) do
      begin
        Perform(WM_ERASEBKGND, DC, 0);
        PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    { Copy images of graphic controls }
    for I := 0 to Count - 1 do begin
      if Control.Parent.Controls[I] = Control then Break
      else if (Control.Parent.Controls[I] <> nil) and
        (Control.Parent.Controls[I] is TGraphicControl) then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
            ControlState := ControlState + [csPaintCopy];
            SaveIndex := SaveDC(DC);
            try
              SetViewportOrgEx(DC, Left + X, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
          end;
        end;
      end;
    end;
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
end;

type
  PRGB32Array = ^TRGB32Array;
  TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;

procedure FadeBMToWhite(Bitmap: TBitmap);
var
  w, h: integer;
  y: Integer;
  sl: PRGB32Array;
  x: Integer;
begin
  Bitmap.PixelFormat := pf32bit;
  w := Bitmap.Width;
  h := Bitmap.Height;
  for y := 0 to h - 1  do
  begin
    sl := Bitmap.ScanLine[y];
    for x := 0 to w - 1 do
      with sl[x] do
      begin
        rgbBlue := rgbBlue + x * ($FF - rgbBlue) div w;
        rgbGreen := rgbGreen + x * ($FF - rgbGreen) div w;
        rgbRed := rgbRed + x * ($FF - rgbRed) div w;
      end;
  end;
end;

procedure FadeLastNpx(Canvas: TCanvas; N: Integer; ClientWidth, ClientHeight: Integer);
var
  bm: TBitmap;
begin
  bm := TBitmap.Create;
  try
    bm.Width := N;
    bm.Height := ClientHeight;
    BitBlt(bm.Canvas.Handle, 0, 0, N, ClientHeight,
      Canvas.Handle, ClientWidth - N, 0, SRCCOPY);
    FadeBMToWhite(bm);
    BitBlt(Canvas.Handle, ClientWidth - N, 0, N, ClientHeight,
      bm.Canvas.Handle, 0, 0, SRCCOPY);
  finally
    bm.Free;
  end;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
var
  w: integer;
  r: TRect;
  S: string;
  CurScreen: TBitmap; // offscreen bitmap to speed things up
begin
  with PaintBox1 do
  begin
    CurScreen := TBitmap.Create;
    CurScreen.Width := Width;
    CurScreen.Height := Height;
    CopyParentImage(PaintBox1, CurScreen.Canvas);

    with CurScreen do
    begin
      Canvas.Font.Assign(PaintBox1.Font);

      S := 'This is a string.';
      Canvas.Font.Size := 20;
      w := Canvas.TextWidth(S);
      r := ClientRect;

      Canvas.FrameRect(r); // for testing
      Canvas.Brush.Style := bsClear; 
      DrawText(Canvas.Handle, PChar(S), Length(S), r, DT_SINGLELINE or DT_VCENTER);
      if w > ClientWidth then
        FadeLastNpx(Canvas, 50, ClientWidth, ClientHeight);
    end; // with CurScreen

    Canvas.Draw(0, 0, CurScreen);
  end; // with PaintBox1

  CurScreen.Free;
end;

    结果如下:

    在此输入图像描述

    正如你所看到的,背景的右边也会褪色.看起来很好.但我想知道只有文字可以用TLama sugeestion褪色？

    2 个回答

    • 这应该让你开始:

      unit Unit5;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TForm5 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    procedure FadeLast50px;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form5: TForm5;

implementation

{$R *.dfm}

type
  PRGB32Array = ^TRGB32Array;
  TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;

procedure FadeBMToWhite(Bitmap: TBitmap);
var
  w, h: integer;
  y: Integer;
  sl: PRGB32Array;
  x: Integer;
begin
  Bitmap.PixelFormat := pf32bit;
  w := Bitmap.Width;
  h := Bitmap.Height;
  for y := 0 to h - 1 do
  begin
    sl := Bitmap.ScanLine[y];
    for x := 0 to w - 1 do
      with sl[x] do
      begin
        rgbBlue := rgbBlue + x * ($FF - rgbBlue) div w;
        rgbGreen := rgbGreen + x * ($FF - rgbGreen) div w;
        rgbRed := rgbRed + x * ($FF - rgbRed) div w;
      end;
  end;
end;

procedure TForm5.FadeLast50px;
var
  bm: TBitmap;
begin
  bm := TBitmap.Create;
  try
    bm.SetSize(50, ClientHeight);
    BitBlt(bm.Canvas.Handle, 0, 0, 50, ClientHeight,
      Canvas.Handle, ClientWidth - 50, 0, SRCCOPY);
    FadeBMToWhite(bm);
    BitBlt(Canvas.Handle, ClientWidth - 50, 0, 50, ClientHeight,
      bm.Canvas.Handle, 0, 0, SRCCOPY);
  finally
    bm.Free;
  end;
end;

procedure TForm5.FormPaint(Sender: TObject);
const
  S = 'This is a string.';
var
  w: integer;
  r: TRect;
begin
  Canvas.Font.Size := 20;
  w := Canvas.TextWidth(S);
  r := ClientRect;
  DrawText(Canvas.Handle, S, Length(S), r, DT_SINGLELINE or DT_VCENTER);
  if w > ClientWidth then
    FadeLast50px;
end;

procedure TForm5.FormResize(Sender: TObject);
begin
  Invalidate;
end;

end.

      截图http://privat.rejbrand.se/fadestr.png

      编译演示EXE

      更新

      这是一个简单的背景实验:

      unit Unit5;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TForm5 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form5: TForm5;
  bk: TBitmap;

implementation

{$R *.dfm}

const
  BLENDWIDTH = 100;

type
  PRGB32Array = ^TRGB32Array;
  TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;

procedure FadeBM(Bitmap: TBitmap);
var
  w, h: integer;
  y: Integer;
  sl: PRGB32Array;
  x: Integer;
begin
  Bitmap.PixelFormat := pf32bit;
  w := Bitmap.Width;
  h := Bitmap.Height;
  for y := 0 to h - 1 do
  begin
    sl := Bitmap.ScanLine[y];
    for x := 0 to w - 1 do
      with sl[x] do
      begin
        rgbReserved := Round(255*x/w);
        rgbRed := rgbRed * rgbReserved div 255;
        rgbGreen := rgbGreen * rgbReserved div 255;
        rgbBlue := rgbBlue * rgbReserved div 255;
      end;
  end;
end;

procedure TForm5.FormCreate(Sender: TObject);
begin
  bk := TBitmap.Create;
  with TOpenDialog.Create(nil) do
    try
      Filter := 'Windows Bitmap|*.bmp';
      if Execute then
        bk.LoadFromFile(FileName)
    finally
      Free;
    end;
end;

procedure TForm5.FormPaint(Sender: TObject);
const
  S = 'This is a string.';
var
  w: integer;
  r: TRect;
  bf: TBlendFunction;
  bk2: TBitmap;
begin
  // Draw backgrond
  BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight, Bk.Canvas.Handle, 0, 0, SRCCOPY);
  // Draw text
  Canvas.Font.Size := 20;
  Canvas.Brush.Style := bsClear;
  w := Canvas.TextWidth(S);
  r := ClientRect;
  DrawText(Canvas.Handle, S, Length(S), r, DT_SINGLELINE or DT_VCENTER);
  if w > ClientWidth then
  begin
    bk2 := TBitmap.Create;
    try
      bk2.SetSize(BLENDWIDTH, ClientHeight);
      BitBlt(bk2.Canvas.Handle, 0, 0, BLENDWIDTH, ClientHeight, Bk.Canvas.Handle, ClientWidth - BLENDWIDTH, 0, SRCCOPY);
      FadeBM(bk2);
      bf.BlendOp := AC_SRC_OVER;
      bf.BlendFlags := 0;
      bf.SourceConstantAlpha := 255;
      bf.AlphaFormat := AC_SRC_ALPHA;
      Windows.AlphaBlend(Canvas.Handle, ClientWidth - BLENDWIDTH, 0, BLENDWIDTH, ClientHeight, bk2.Canvas.Handle, 0, 0, BLENDWIDTH, ClientHeight, bf);
    finally
      bk2.Free;
    end;
  end;
end;

procedure TForm5.FormResize(Sender: TObject);
begin
  Invalidate;
end;

end.

      截图http://privat.rejbrand.se/fadestr2.png

      编译演示EXE

      示例背景位图

      2023-02-10 14:35 回答

    • 特此安德烈亚斯的代码(投票应该是他的!)被纳入一个独立的组成部分:

      unit FadingTextControl;

interface

uses
  Classes, Controls, Windows, Graphics;

type
  TFadingTextControl = class(TGraphicControl)
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Caption;
    property Font;
  end;

implementation

{ TFadingTextControl }

constructor TFadingTextControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csOpaque];
end;

procedure TFadingTextControl.Paint;
const
  FadeWidth = 100;
var
  R: TRect;
  Overlay: TBitmap;
  BlendFunc: TBlendFunction;

  procedure FadeOverlay;
  type
    PRGB32Array = ^TRGB32Array;
    TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad) - 1] of TRGBQuad;
  var
    W: Integer;
    Y: Integer;
    Line: PRGB32Array;
    X: Integer;
  begin
    Overlay.PixelFormat := pf32bit;
    W := Overlay.Width;
    for Y := 0 to Overlay.Height - 1 do
    begin
      Line := Overlay.ScanLine[Y];
      for X := 0 to W - 1 do
        with Line[X] do
        begin
          rgbReserved := Round(255 * X / W);
          rgbRed := rgbRed * rgbReserved div 255;
          rgbGreen := rgbGreen * rgbReserved div 255;
          rgbBlue := rgbBlue * rgbReserved div 255;
        end;
    end;
  end;

begin
  R := ClientRect;
  Canvas.Font.Assign(Font);
  Canvas.Brush.Style := bsClear;
  if Canvas.TextWidth(Caption) <= Width then
    DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_SINGLELINE or DT_VCENTER)
  else
  begin
    Overlay := TBitmap.Create;
    try
      Overlay.Width := FadeWidth;
      Overlay.Height := Height;
      BitBlt(Overlay.Canvas.Handle, 0, 0, FadeWidth, Height, Canvas.Handle,
        Width - FadeWidth, 0, SRCCOPY);
      DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_SINGLELINE or
        DT_VCENTER);
      FadeOverlay;
      BlendFunc.BlendOp := AC_SRC_OVER;
      BlendFunc.BlendFlags := 0;
      BlendFunc.SourceConstantAlpha := 255;
      BlendFunc.AlphaFormat := AC_SRC_ALPHA;
      AlphaBlend(Canvas.Handle, Width - FadeWidth, 0, FadeWidth, Height,
        Overlay.Canvas.Handle, 0, 0, FadeWidth, Height, BlendFunc);
    finally
      Overlay.Free;
    end;
  end;
end;

end.

      2023-02-10 14:35 回答
    撰写答案
    今天，你开发时遇到什么问题呢？
    立即提问
    热门标签
    PHP1.CN | 中国最专业的PHP中文社区 | PNG素材下载 | DevBox开发工具箱 | json解析格式化 |PHP资讯 | PHP教程 | 数据库技术 | 服务器技术 | 前端开发技术 | PHP框架 | 开发工具 | 在线工具
    Copyright © 1998 - 2020 PHP1.CN. All Rights Reserved 京公网安备 11010802041100号 | 京ICP备19059560号-4 | PHP1.CN 第一PHP社区 版权所有