16,748
社区成员
发帖
与我相关
我的任务
分享
procedure PaintGradient( Canvas: TCanvas; Bounds: TRect; GradDir: TGradientDirection; ColorStart, ColorStop: TColor;
SmoothFactor: TSmoothFactor );
var
FBitmap: TBitmap;
Width, Height: Integer;
begin
ColorStart := ColorToRGB( ColorStart );
ColorStop := ColorToRGB( ColorStop );
FBitmap := TBitmap.Create;
try
Width := Abs( Bounds.Right - Bounds.Left );
Height := Abs( Bounds.Bottom - Bounds.Top );
if ( Width = 0 ) or ( Height = 0 ) then
Exit;
FBitmap.Width := Width;
FBitmap.Height := Height;
FBitmap.Canvas.Pen.Width := 1;
FBitmap.Canvas.Pen.Style := psClear;
FBitmap.Canvas.Pen.Mode := pmCopy;
FBitmap.Canvas.Brush.Style := bsSolid;
case GradDir of
gdHorizontalEnd:
begin
FillGrad( FBitmap.Canvas.Handle, 0, -1, Height, ColorStart, ColorStop, SmoothFactor );
BitFillBlit( FBitmap.Canvas.Handle, 0, 0, Width, Height, 8, Height, SRCCOPY );
end;
gdHorizontalCenter:
begin
FillGrad( FBitmap.Canvas.Handle, 0, Height div 2, Height, ColorStart, ColorStop, SmoothFactor );
BitFillBlit( FBitmap.Canvas.Handle, 0, 0, Width, Height, 8, Height, SRCCOPY );
end;
gdHorizontalBox:
begin
FBitmap.Canvas.Brush.Color := ColorStart;
FBitmap.Canvas.FillRect( Rect( 0, 0, Width, Height ) );
FillGradRect( FBitmap.Canvas.Handle, Width, Height, Width shr 2, 0, ColorStart, ColorStop, SmoothFactor );
BoxBitMirrorBlit( FBitmap.Canvas.Handle, 0, 0, Width, Height, SRCCOPY );
end;
gdVerticalEnd:
begin
FillGrad( FBitmap.Canvas.Handle, -1, 0, Width, ColorStart, ColorStop, SmoothFactor );
BitFillBlit( FBitmap.Canvas.Handle, 0, 0, Width, Height, Width, 8, SRCCOPY );
end;
gdVerticalCenter:
begin
FillGrad( FBitmap.Canvas.Handle, Width div 2, 0, Width, ColorStart, ColorStop, SmoothFactor );
BitFillBlit( FBitmap.Canvas.Handle, 0, 0, Width, Height, Width, 8, SRCCOPY );
end;
gdVerticalBox:
begin
FillGradRect( FBitmap.Canvas.Handle, Width, Height, 0, Height shr 2, ColorStart, ColorStop, SmoothFactor );
BoxBitMirrorBlit( FBitmap.Canvas.Handle, 0, 0, Width, Height, SRCCOPY );
end;
gdSquareBox:
begin
FBitmap.Canvas.Brush.Color := ColorStart;
FBitmap.Canvas.FillRect( Rect( 0, 0, Width, Height ) );
FillGradRect( FBitmap.Canvas.Handle, Width, Height, 0, 0, ColorStart, ColorStop, SmoothFactor );
BoxBitMirrorBlit( FBitmap.Canvas.Handle, 0, 0, Width, Height, SRCCOPY );
end;
gdBigSquareBox:
begin
FillGradRect( FBitmap.Canvas.Handle, Width, Height, Width shr 2, Height shr 2, ColorStart, ColorStop, SmoothFactor );
BoxBitMirrorBlit( FBitmap.Canvas.Handle, 0, 0, Width, Height, SRCCOPY );
end;
gdDiagonalUp:
begin
if ColorStart = ColorStop then
begin
FBitmap.Canvas.Brush.Color := ColorStart;
FBitmap.Canvas.Rectangle( 0, 0, Width, Height );
end
else
FillGradDiag( FBitmap.Canvas.Handle, Width, Height, ColorStart, ColorStop, SmoothFactor );
end;
gdDiagonalDown:
begin
if ColorStart = ColorStop then
begin
FBitmap.Canvas.Brush.Color := ColorStart;
FBitmap.Canvas.Rectangle( 0, 0, Width, Height );
end
else
FillGradDiag( FBitmap.Canvas.Handle, -Width, Height, ColorStart, ColorStop, SmoothFactor );
end;
end;
Canvas.Draw( Bounds.Left, Bounds.Top, FBitmap );
finally
FBitmap.Free;
end;
end;
type
TGradientDirection = (gdHorizontal, gdVertical);
type
TGradientFill = function(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG; Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall;
const
sGradientFill = 'GradientFill'; { do not localize }
var
MsImgHandle: HMODULE;
MsImgInitialized: Boolean;
GradientFillFunc: TGradientFill;
procedure GradientFillCanvas(const ACanvas: TCanvas;
const AStartColor, AEndColor: TColor; const ARect: TRect;
const Direction: TGradientDirection);
const
cGradientDirections: array[TGradientDirection] of Cardinal =
(GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V);
var
StartColor, EndColor: Cardinal;
Vertexes: array[0..1] of TTriVertex;
GradientRect: TGradientRect;
begin
// The GradientFill API is not supported on NT4 do we'll try to dynamically load
// the DLL and call the API.
if not MsImgInitialized then
begin
MsImgHandle := LoadLibrary(msimg32);
if MsImgHandle <> 0 then
GradientFillFunc := GetProcAddress(MsImgHandle, PChar(sGradientFill));
MsImgInitialized := True;
end;
// If we didn't find the GradientFill API simply exit leaving the canvas unmodified
if not Assigned(GradientFillFunc) then exit;
StartColor := ColorToRGB(AStartColor);
EndColor := ColorToRGB(AEndColor);
Vertexes[0].x := ARect.Left;
Vertexes[0].y := ARect.Top;
Vertexes[0].Red := GetRValue(StartColor) shl 8;
Vertexes[0].Blue := GetBValue(StartColor) shl 8;
Vertexes[0].Green := GetGValue(StartColor) shl 8;
Vertexes[0].Alpha := 0;
Vertexes[1].x := ARect.Right;
Vertexes[1].y := ARect.Bottom;
Vertexes[1].Red := GetRValue(EndColor) shl 8;
Vertexes[1].Blue := GetBValue(EndColor) shl 8;
Vertexes[1].Green := GetGValue(EndColor) shl 8;
Vertexes[1].Alpha := 0;
GradientRect.UpperLeft := 0;
GradientRect.LowerRight := 1;
GradientFillFunc(ACanvas.Handle, @Vertexes[0], 2, @GradientRect, 1,
cGradientDirections[Direction]);
end;
procedure TForm5.Button1Click(Sender: TObject);
begin
GradientFillCanvas(Canvas, clRed, clBlack, ClientRect, gdVertical)
end;