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));

要提供高质量的拉伸，请将SetStretchBltMode应用于Canvas.Handle HALFTONE旗帜

P.S。您是否了解GradientFill功能？

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

1 个答案: