我试图制作一个显示渐变条形图的组件。我有一个函数FillGradient,它在Canvas上形成一个完美的梯度。当我在Paint方法中使用这个函数直接在组件画布上绘制梯度时,一切看起来都很好。但是,当我试图在缓冲区位图上绘制渐变时(如下面的代码所示),然后在需要时在组件画布上复制一部分(在画图方法中),渐变将被显示损坏。怎么了?

这是重现问题的最小代码:
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.发布于 2018-03-30 14:16:39
TCanvas.Copyrect方法内部使用StretchBlt函数。当矩形具有不同的大小时,它执行拉伸操作,如下面的代码行所示:
Canvas.CopyRect(Rect(1,1,1+Rp,Height-2), Fbmp.Canvas, Rect(0,0,Fbmp.Width-1,Fbmp.Height-1));若要提供高质量的拉伸,请将SetStretchBltMode应用到带有HALFTONE标志的Canvas.Handle中。
你知道GradientFill函数吗?
https://stackoverflow.com/questions/49575898
复制相似问题