Fade an image using GDI+ (i.e. Change only the Alpha channel of a TGPGraphic)

问题

I need to fade the right side of an image using GDI+. I'm actually trying to emulate the right hand side text fade that you see in Google Chrome. Here's what I want to do.

Create a TGPGraphics object from a TBitmap.
Create a TGPBitmap from a region of the TBitmap.
Paint the background of the TGPGraphics object and the text to the TGPBitmap.
Change the Alpha settings on the right hand side of the TGPBitmap object to produce the fade effect.
Draw the TGPBitmap back to the TGPGraphics object.

回答1:

If you really want to use GDI+ for this

unit Unit3;

interface

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

type
  TForm3 = class(TForm)
    PaintBox1: TPaintBox;
    Image1: TImage;
    Shape1: TShape;
    Shape2: TShape;
    Shape3: TShape;
    Timer1: TTimer;
    procedure PaintBox1Paint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form3: TForm3;

implementation

uses
  EXGDIPAPI,
  EXGDIPOBJ;

{$R *.dfm}

Procedure GPEasyTextout(Graphics: TGPGraphics; Const TheText: String; Rect: TGPRectF; Color: TGPColor; HAlign, VAlign: TStringAlignment; Size: Integer = 10;
  FontName: String = 'Arial');
var
  StringFormat: TGPStringFormat;
  FontFamily: TGPFontFamily;
  Font: TGPFont;
  Pen: TGPPen;
  Brush: TGPSolidBrush;
begin
  StringFormat := TGPStringFormat.Create;
  FontFamily := TGPFontFamily.Create(FontName);
  Font := TGPFont.Create(FontFamily, Size, FontStyleRegular, UnitPixel);
  Pen := TGPPen.Create(Color);
  Brush := TGPSolidBrush.Create(Color);
  StringFormat.SetAlignment(HAlign);
  StringFormat.SetLineAlignment(VAlign);
  Graphics.DrawString(TheText, -1, Font, Rect, StringFormat, Brush);
  Pen.Free;
  Brush.Free;
  StringFormat.Free;
  FontFamily.Free;
  Font.Free;
end;

Procedure PaintImageTransparent(DC: HDC; AGraphic: TGraphic;AlphaDec:Byte);

var
  Graphics, bmpgraphics: TGPGraphics;
  Width, Height, Row, Column: Integer;
  Color, colorTemp: TGPColor;
  bitmap, BitmapOut: TGPBitmap;
  Stream: TMemoryStream;
  Alpha:Integer;
begin
  Graphics := TGPGraphics.Create(DC);  // destination
  Stream := TMemoryStream.Create;      // Stremm to keep normal TGraphic
  AGraphic.SaveToStream(Stream);
  bitmap := TGPBitmap.Create(TStreamAdapter.Create(Stream));
  bmpgraphics := TGPGraphics.Create(bitmap); // Graphic for Bitmap
  GPEasyTextout(bmpgraphics, 'Some Text to display', MakeRect(10.0, 10, 300, 200), MakeColor(0, 0, 0), StringAlignmentCenter, StringAlignmentCenter, 20);
  bmpgraphics.Free;
  Width := bitmap.GetWidth;
  Height := bitmap.GetHeight;

  BitmapOut := TGPBitmap.Create(Width, Height); // Outputbitmap
  bmpgraphics := TGPGraphics.Create(BitmapOut); // Graphic for Bitmap
  bmpgraphics.DrawImage(bitmap, 0, 0, Width, Height);
  bmpgraphics.Free;

  for Row := 0 to Height - 1 do
  begin
    for Column := 0 to Width - 1 do
    begin
      BitmapOut.GetPixel(Column, Row, Color);
      Alpha := ((255 * (Width - Column)) div Width) + AlphaDec;
      if Alpha>255 then Alpha := 255;

      colorTemp := MakeColor(Alpha, GetRed(Color), GetGreen(Color), GetBlue(Color));
      BitmapOut.SetPixel(Column, Row, colorTemp);
    end;
  end;

  Graphics.DrawImage(BitmapOut, 0, 0, Width, Height);

  BitmapOut.Free;
  bitmap.Free;
  Graphics.Free;
  Stream.Free;
end;

procedure TForm3.FormCreate(Sender: TObject);
begin
   ReportMemoryLeaksOnShutDown := True;
end;

procedure TForm3.PaintBox1Paint(Sender: TObject);
begin
  PaintImageTransparent(TPaintBox(Sender).Canvas.Handle, Image1.picture.Graphic,Timer1.Tag);
end;

procedure TForm3.Timer1Timer(Sender: TObject);
begin
  Timer1.Tag := Timer1.Tag + 10;
  if Timer1.Tag>255 then
    begin
     Timer1.Tag := 255;
     Timer1.Enabled := false;
    end
  else PaintBox1.Invalidate;

end;

end.

complete source available here http://www.bummisoft.de/download/transparentverlauf.zip

回答2:

Another approach without GDI+ could be done this way. -Creating and preparing a bitmap for transparency -paint on it -set transparency gradient -paint it

unit Unit3;

interface

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

type
  TForm3 = class(TForm)
    Image1: TImage;
    PaintBox1: TPaintBox;
    Timer1: TTimer;
    procedure PaintBox1Paint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private

    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}
procedure TForm3.FormCreate(Sender: TObject);
begin
  DoubleBuffered := true;
end;

type
  pRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = ARRAY [0 .. $EFFFFFF] OF TRGBQuad;

Procedure SetAlpha(bmp: TBitMap; Alpha: Byte);
var
  pscanLine32: pRGBQuadArray;
  i, j: Integer;
  lAlpha:Integer;
begin

  for i := 0 to bmp.Height - 1 do
  begin
    pscanLine32 := bmp.Scanline[i];
    for j := 0 to bmp.Width - 1 do
      begin
        lAlpha := Round(255 * (bmp.width- j) / bmp.width )+ Alpha;
        if lAlpha>255 then lAlpha := 255;
        pscanLine32[j].rgbReserved := lAlpha;
        pscanLine32[j].rgbBlue := Round(pscanLine32[j].rgbBlue * lAlpha / 255);
        pscanLine32[j].rgbRed :=  Round(pscanLine32[j].rgbRed * lAlpha / 255);
        pscanLine32[j].rgbGreen :=  Round(pscanLine32[j].rgbGreen * lAlpha / 255);
      end;
  end;

end;

Procedure InitAlpha(bmp: TBitMap);
var
  pscanLine32: pRGBQuadArray;
  i, j: Integer;
  lAlpha:Integer;
begin
 bmp.PixelFormat := pf32Bit;
 bmp.HandleType := bmDIB;
 bmp.ignorepalette := true;
 bmp.alphaformat := afDefined;
  for i := 0 to bmp.Height - 1 do
  begin
    pscanLine32 := bmp.Scanline[i];
    for j := 0 to bmp.Width - 1 do
      begin
        pscanLine32[j].rgbReserved := 255;
        pscanLine32[j].rgbBlue := 0;
        pscanLine32[j].rgbRed := 0;
        pscanLine32[j].rgbGreen := 0;
      end;
  end;

end;




procedure TForm3.PaintBox1Paint(Sender: TObject);
var
 bmp:TBitmap;
begin
    bmp:=TBitmap.Create;
    try

      bmp.Width := Image1.Picture.Graphic.Width;
      bmp.Height := Image1.Picture.Graphic.Height;
      InitAlpha(bmp);
      bmp.Canvas.Draw(0,0,Image1.Picture.Graphic);
      bmp.Canvas.Brush.Style := bsClear;
      bmp.Canvas.Font.Size := 20;
      bmp.Canvas.TextOut(10,10,'Some tex to display');
      SetAlpha(bmp,Timer1.tag);
      TPaintBox(Sender).Canvas.Draw(0,0,bmp);
    finally
      bmp.Free;
    end;
end;

procedure TForm3.Timer1Timer(Sender: TObject);
begin
  Timer1.Tag :=  Timer1.Tag + 10;
  if Timer1.Tag>255 then
    begin
       Timer1.Tag:=255;
       Timer1.Enabled := False;
    end
   else Paintbox1.Invalidate;
end;

end.

回答3:

You don't need to convert these - at least if you use Delphi2010+.... TBitmap (TGraphic respectively) already has a method to draw a bitmap on a canvas with an opacity param - Just look at the DrawTransparent method in the delphi help.

If that is not sufficient check out the AlphaBlend function from the windows gdi api.

To get that whole procedure smooth I think you should:

create a bitmap with the background
create a bitmap with the text
in a timer procedure (which could trigger the fading invalidate) set the opacity value and triggers an invaldiate for only that specific region (invalidateRect)
in the painting procedure create a third bitmap -> paint the backround and then with the alpha value set the text (or whatever bitmap) uppon that.
draw that resulting bitmap on the canvas.

if you still experience some flickering then eventually enable double buffering and/or handle the WM_ERASEBKNG message yourself.

来源：https://stackoverflow.com/questions/13701685/fade-an-image-using-gdi-i-e-change-only-the-alpha-channel-of-a-tgpgraphic

标签

Delphi

gdi+

delphi-xe2

gdi