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

时间：2013-12-14 10:38:19

标签： delphi delphi-7

我想在TGraphicControl上绘制淡出文本，就像Google Chrome上的标签一样，当没有足够的空间在画布上显示整个文字时。

所以我没有显示省略号文本（我知道该怎么做），而是希望它像这样淡出：delphi

TGraphicControl需要具有透明选项，如TCustomLabel（ControlStyle - [csOpaque]）。

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

我也尝试研究TGradText v.1.0（直接download）的代码（几乎）完全符合我的需要 - 它可以绘制透明文本，但结果看起来很糟糕而且不顺畅。我想这是因为它为这个任务制作了一个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;

结果如下：

enter image description here

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

2 个答案:

答案 0 :(得分：11)

这应该让你开始：

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.

Screenshot http://privat.rejbrand.se/fadestr.png

Compiled demo 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.

Screenshot http://privat.rejbrand.se/fadestr2.png

Compiled demo EXE

Sample background bitmap

答案 1 :(得分：5)

特此以Andreas' code（投票应该为他！）并入独立组成部分：

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.
相关问题
最新问题