为什么我的位图在我使用 Canvas.CopyRect 时损坏了？

Question

我正在尝试制作一个显示渐变条的组件。我有一个函数 FillGradient，可以在 Canvas 上形成完美的渐变。当我在 Paint 方法中使用此函数直接在组件 Canvas 上绘制渐变时，一切看起来都很好。但是当我尝试在缓冲区位图上绘制渐变（如下面的代码），然后在需要时（在 Paint 方法中）复制组件 Canvas 上的一部分时，渐变显示已损坏。怎么了？

这是重现问题的最少代码：

unit OwnGauge;

interface

uses
   Windows, Messages, Sysutils, Classes, Graphics, Controls, forms, Dialogs;

const
   Arc1 = 10;

type
   TGradDir = (grHorizontal, grVertical);

   TOwnGauge = class(TGraphicControl)
   private
     Fbmp: TBitmap;
     FBgColor, FSColor, FEColor: TColor;
     FProgress, Fmax, Fmin: Integer;
     procedure FillGradient(ACanvas:TCanvas; ARect:TRect; StartColor,EndColor:Tcolor; Direction:TGradDir);
     function  GetColorBetween(StartColor,EndColor:TColor; Index,StartRange,EndRange:Extended):TColor;
   protected
     procedure Setcolor1(Value: Tcolor);
     procedure Setcolor2(Value: Tcolor);
     procedure Setbgcolor(Value: Tcolor);
     procedure Setmin(Value: Integer);
     procedure Setmax(Value: Integer);
     procedure Setprogress(Value: Integer);
     procedure GradFill(Clr1, Clr2: Tcolor);
     procedure Paint; override;
   public
     constructor Create(Aowner: Tcomponent); override;
     destructor Destroy; override;
   published
     property Backcolor:    Tcolor Read Fbgcolor Write Setbgcolor;
     property Color1:       Tcolor Read Fscolor Write Setcolor1;
     property Color2:       Tcolor Read Fecolor Write Setcolor2;
     property Min:          Integer Read Fmin Write Setmin;
     property Max:          Integer Read Fmax Write Setmax;
     property Progress:     Integer Read Fprogress Write Setprogress;
     property Visible;
     property Font;
   end;

implementation

var
  Percent, Rp: Integer;

constructor TOwnGauge.Create(Aowner: Tcomponent);
begin
  inherited Create(Aowner);

  Width := 200;
  Height := 40;
  Fmin := 1;
  Fmax := 100;
  Fprogress := Fmin;

  Fscolor := Clwhite;
  Fecolor := Clyellow;
  Fbgcolor := ClBtnFace;

  Fbmp:= TBitmap.Create;
  Fbmp.PixelFormat:= pf24bit;
  Fbmp.Transparent:=false;
  Fbmp.Canvas.CopyMode:=cmSrcCopy;
  Fbmp.Width:= Width-2;
  Fbmp.Height:= Height-2;
  Gradfill(Fscolor, Fecolor);
end;

destructor TOwnGauge.Destroy;
begin
  inherited Destroy;
  Fbmp.Free;
end;

procedure TOwnGauge.FillGradient(ACanvas:TCanvas; ARect:TRect; StartColor,EndColor:Tcolor; Direction:TGradDir);
var I: Integer;
begin
 if ((ARect.Right-ARect.Left)<=0) or ((ARect.Bottom-ARect.Top)<=0) then Exit;
 case Direction of
   grHorizontal:
     for I:=ARect.Left to ARect.Right do begin
      ACanvas.Pen.Color:=GetColorBetween(StartColor, EndColor, I, ARect.Left, ARect.Right);
      ACanvas.MoveTo(I, ARect.Top);
      ACanvas.LineTo(I, ARect.Bottom+1);
     end;
   grVertical:
     for I:=ARect.Top to ARect.Bottom do begin
      ACanvas.Pen.Color:=GetColorBetween(StartColor, EndColor, I, ARect.Top, ARect.Bottom);
      ACanvas.MoveTo(ARect.Left, I);
      ACanvas.LineTo(ARect.Right+1, I);
     end;
 end;
end;

function TOwnGauge.GetColorBetween(StartColor,EndColor:TColor; Index,StartRange,EndRange:Extended):TColor;
var F: Extended;
    R1,R2,R3,G1,G2,G3,B1,B2,B3: Byte;

 function CalcColorBytes(FB1,FB2:Byte):Byte;
 begin
  Result:=FB1;
  if FB1 < FB2 then Result:= FB1 + Trunc(F * (FB2 - FB1));
  if FB1 > FB2 then Result:= FB1 - Trunc(F * (FB1 - FB2));
 end;

begin
 if Index <= StartRange then Exit(StartColor);
 if Index >= EndRange then Exit(EndColor);
 F:=(Index - StartRange) / (EndRange - StartRange);
 asm
   mov  EAX,StartColor
   cmp  EAX,EndColor
   je   @@Exit
   mov  R1,AL
   shr  EAX,8
   mov  G1,AL
   shr  EAX,8
   mov  B1,AL
   mov  EAX,EndColor
   mov  R2,AL
   shr  EAX,8
   mov  G2,AL
   shr  EAX,8
   mov  B2,AL
   push EBP
   mov  AL,R1
   mov  DL,R2
   call CalcColorBytes
   pop  ECX
   push EBP
   mov  R3,AL
   mov  DL,G2
   mov  AL,G1
   call CalcColorBytes
   pop  ECX
   push EBP
   mov  G3,AL
   mov  DL,B2
   mov  AL,B1
   call CalcColorBytes
   pop  ECX
   mov  B3,AL
   XOR  EAX,EAX
   mov  AL,B3
   SHL  EAX,8
   mov  AL,G3
   SHL  EAX,8
   mov  AL,R3
 @@Exit:
   mov  @Result,EAX
 end;
end;

Procedure TOwnGauge.Gradfill(Clr1, Clr2: Tcolor);
begin
 FillGradient(FBmp.Canvas, Rect(0,0, FBmp.Width-1, FBmp.Height-1), clRed, clBlue, grHorizontal);
end;

procedure TOwnGauge.Paint;
begin
  if not Visible then Exit;

  Percent:= Round(((FProgress-Fmin)/(Fmax-Fmin))*100);
  Rp:= Percent*(Width-3) div 100;

  Canvas.CopyMode:=cmSrcCopy;
  if Rp<>0 then
   Canvas.CopyRect(Rect(1,1,1+Rp,Height-2), Fbmp.Canvas, Rect(0,0,Fbmp.Width-1,Fbmp.Height-1));

  if Percent<100 then begin
   Canvas.Brush.Color:= FBgColor;
   Canvas.Brush.Style:= bsSolid;
   Canvas.Pen.Style:= psClear;
   Canvas.Pen.Width:= 1;
   Canvas.Rectangle(2+Rp, 2, Width-0, Height-0);
  end;
end;

//-----------------------------------------------

Procedure TOwnGauge.Setbgcolor(Value:  Tcolor);
begin
  if Value <> Fbgcolor then
  begin
    Fbgcolor := Value;
    Invalidate;
  end;
end;

Procedure TOwnGauge.Setcolor1(Value:  Tcolor);
begin
  if Value <> Fscolor then
  begin
    Fscolor := Value;
    Gradfill (Fscolor, Fecolor);
    Invalidate;
  end;
end;

Procedure TOwnGauge.Setcolor2(Value:  Tcolor);
begin
  if Value <> Fecolor then
  begin
    Fecolor := Value;
    Gradfill (Fscolor, Fecolor);
    Invalidate;
  end;
end;

Procedure TOwnGauge.Setmin(Value:  Integer);
begin
  if (Value <> Fmin) And (Value< Fmax) then
  begin
    Fmin := Value;
    if (Fprogress< Fmin) then  Fprogress:= Fmin;
    Invalidate;
  end;
end;

Procedure TOwnGauge.Setmax(Value:  Integer);
begin
  if (Value <> Fmax) And (Fmin< Value)  then
  begin
    Fmax := Value;
    if (Fprogress> Fmax) then  begin
     Fprogress:= Fmax;
    end;
    Invalidate;
  end;
end;

Procedure TOwnGauge.Setprogress(Value:  Integer);
begin
  if (value > fMax) then value := Fmax;
  if (value < fMin) then value := fMin;
  if (Value <> Fprogress) then begin
    Fprogress := Value;
    Paint;
  end;
end;

end.

Answer 1

TCanvas.Copyrect 方法内部使用 StretchBlt 函数。它在矩形具有不同大小时执行拉伸，可能如以下代码行所示：

 Canvas.CopyRect(Rect(1,1,1+Rp,Height-2), Fbmp.Canvas, Rect(0,0,Fbmp.Width-1,Fbmp.Height-1));

要提供 high-quality 拉伸，请使用 HALFTONE 标志将 SetStretchBltMode 应用到 Canvas.Handle

P.S。你知道 GradientFill 函数吗？

为什么我的位图在我使用 Canvas.CopyRect 时损坏了？

Why my bitmap is corrupted when I use Canvas.CopyRect?

delphi

graphics

delphi-2009