So I want to print a string grid in the middle/center of another printed page that already has a printed/header and footer, but I'm not sure how to print the string grid in the middle/center of the page?
Is there anything in the code below that I can change to do that? Or do I have to do something else completely?
Thanks in advance for all the help!
Example of the type of page I have to print on (In the open part of the page):
Code I've used for one of the other buttons that also prints:
procedure PrintGrid(sGrid: TStringGrid; sTitle: string);
var
X1, X2: Integer;
Y1, Y2: Integer;
TmpI: Integer;
F: Integer;
TR: TRect;
begin
Printer.Title := sTitle;
Printer.BeginDoc;
Printer.Canvas.Pen.Color := 0;
Printer.Canvas.Font.Name := 'Times New Roman';
Printer.Canvas.Font.Size := 12;
Printer.Canvas.Font.Style := [fsBold, fsUnderline];
Printer.Canvas.TextOut(0, 100, Printer.Title);
for F := 1 to sGrid.ColCount - 1 do
begin
X1 := 0;
for TmpI := 1 to (F - 1) do
X1 := X1 + 5 * (sGrid.ColWidths[TmpI]);
Y1 := 300;
X2 := 0;
for TmpI := 1 to F do
X2 := X2 + 5 * (sGrid.ColWidths[TmpI]);
Y2 := 450;
TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.Font.Style := [fsBold];
Printer.Canvas.Font.Size := 7;
Printer.Canvas.TextRect(TR, X1 + 50, 350, sGrid.Cells[F, 0]);
Printer.Canvas.Font.Style := [];
for TmpI := 1 to sGrid.RowCount - 1 do
begin
Y1 := 150 * TmpI + 300;
Y2 := 150 * (TmpI + 1) + 300;
TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.TextRect(TR, X1 + 50, Y1 + 50, sGrid.Cells[F, TmpI]);
end;
end;
Printer.EndDoc;
end;
Kind Regards
PrimeBeat
You can get printer width and height in pixel (Printer.PageWidth and Printer.PageHeight). You can get text with and height using Printer.Canvas.TextExtent. You have your grid so you know the number of rows and column. The rest is some easy computing. You can adapt the font size so that the grid fits in the given space.
Related
My little code creates modern art to the full screen size Form canvas with different kind of shapes.
I can make ellipse, rectangle and line work but not the polycon. Can any one help me? (Version: Delphi community edition )
uses .... GDIPAPI, GDIPOBJ, GDIPUTIL;
procedure TForm1.Button1Click(Sender: TObject);
var
graphics: TGPGraphics;
SolidPen: TGPPen;
SolidBrush : TGPBrush;
x,y,x2,y2,x3,y3 : integer;
begin
graphics := TGPGraphics.Create(Canvas.Handle);
graphics.SetSmoothingMode(SmoothingModeAntiAlias);
SolidPen := TGPPen.Create(MakeColor(255, random(255), random(255), random(255)), random(4)+1);
SolidBrush := TGPSolidBrush.Create(MakeColor(255, random(255), random(255), random(255)));
SolidPen.SetStartCap(LineCapRound);
SolidPen.SetEndCap(LineCapRound);
//POLYCON, not working.------------------
// PROBLEM HERE: it's complaining: 'Oridinal type required' ,
// 'incompatible type: integer and TPoint'
x:= 150; y := 50; x2 := 50; y2 := 250; x3 := 250; y3 := 250;
graphics.FillPolygon(SolidBrush, [Point(x, y), Point(x2, y2), Point(x3, y3)]);
graphics.DrawPolygon(SolidPen, [Point(x, y), Point(x2, y2), Point(x3, y3)]);
//--------------------------------------------
// ELLIPSE, ok
x := random(Form1.width); y := random(Form1.height); x2 := random(200); y2 := random(200);
graphics.FillEllipse(SolidBrush,x, y, x2, y2);
graphics.DrawEllipse(SolidPen,x, y, x2, y2);
// RECTANGLE, ok
x := random(Form1.width); y := random(Form1.height); x2 := random(200); y2 := random(200);
graphics.FillRectangle(SolidBrush, x, y, x2, y2);
graphics.DrawRectangle(SolidPen, x, y, x2, y2);
// LINE, ok
x := random(Form1.width); y := random(Form1.height); x2 := random(Form1.width); y2 := random(Form1.height);
graphics.DrawLine(SolidPen, x, y, x2, y2);
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Height := Screen.Height;
Form1.Width := Screen.Width;
end;
You are not passing the points of the polygon correctly.
Looking at the two overloaded DrawPolygon() declarations:
function TGPGraphics.DrawPolygon(pen: TGPPen; points: PGPPointF; count: Integer): TStatus;
function TGPGraphics.DrawPolygon(pen: TGPPen; points: PGPPoint; count: Integer): TStatus;
you can see that the points are passed as a PGPPointF or PGPPoint. The definitions of these types are found in Winapi.GDIPAPI and there we see that the coordinates are either single or integer
Since you are using integer coordinates look at the definition of PGPPoint in Winapi.GDIPAPI
type
PGPPoint = ^TGPPoint;
TGPPoint = record
X : Integer;
Y : Integer;
end;
TPointDynArray = array of TGPPoint;
function MakePoint(X, Y: Integer): TGPPoint; overload;
{$EXTERNALSYM MakePoint}
So, declare a variable
ArrOfPoint: TPointDynArray;
and fill it with your points:
SetLength(ArrOfPoint, 3);
ArrOfPoint[0] := MakePoint(x, y);
ArrOfPoint[1] := MakePoint(x2, y2);
ArrOfPoint[2] := MakePoint(x3, y3);
Finally replace your call to e.g. DrawPolygon() with
graphics.DrawPolygon(SolidPen, PGPPoint(#ArrOfPoint[0]), 3);
meaning you pass the address of the first point as a PGPPoint type.
So, the corrected working code for the polygon is following (at the moment):
uses
... GDIPAPI, GDIPOBJ, GDIPUTIL;
procedure TForm1.Button1Click(Sender: TObject);
var
graphics: TGPGraphics;
SolidPen: TGPPen;
SolidBrush : TGPBrush;
ArrOfPoint: TPointDynArray;
x, y, x2, y2, x3, y3 : integer;
begin
graphics := TGPGraphics.Create(Canvas.Handle);
graphics.SetSmoothingMode(SmoothingModeAntiAlias);
SolidPen := TGPPen.Create(MakeColor(255, random(255), random(255), random(255)), random(4)+1);
SolidBrush := TGPSolidBrush.Create(MakeColor(255, random(255), random(255), random(255)));
x := random(Form1.Width); y := random(Form1.Height);
x2 := random(Form1.Width); y2 := random(Form1.Height);
x3 := random(Form1.Width); y3 := random(Form1.Height);
SetLength(ArrOfPoint, 3);
ArrOfPoint[0] := MakePoint(x, y);
ArrOfPoint[1] := MakePoint(x2, y2);
ArrOfPoint[2] := MakePoint(x3, y3);
graphics.FillPolygon(SolidBrush,PGPPoint(#ArrOfPoint[0]), 3);
graphics.DrawPolygon(SolidPen, PGPPoint(#ArrOfPoint[0]), 3);
end;
I am trying to write my own quick resampler which allows to scale image down by 2,3,4 etc.
I compared it with StretchBlt and my resampler is about 2 times slower.
My code:
type TRGBA = record
B,G,R: Byte;
A: Byte;
end;
PRGBAArray = ^TRGBAArray;
TRGBAArray = array[0..32767] of TRGBA;
procedure DownsampleSys(Src, Dst: TBitmap; Times: Integer);
var ARect: TRect;
dc:HDC;
p:TPoint;
begin
Dst.Width := Src.Width div Times;
Dst.Height := Src.Height div Times;
ARect := Rect(0,0, Dst.Width, Dst.Height);
dc := Dst.Canvas.Handle;
GetBrushOrgEx(dc,p);
SetStretchBltMode(dc,HALFTONE);
SetBrushOrgEx(dc,p.x,p.y,#p);
StretchBlt(dc,
ARect.Left, ARect.Top,
ARect.Right- ARect.Left, ARect.Bottom- ARect.Top,
Src.Canvas.Handle,0,0,Src.Width,Src.Height,Dst.Canvas.CopyMode);
end;
procedure Downsample2(Src, Dst: TBitmap; Times: Integer);
var x,y: Integer;
xx,yy: Integer;
FromP, ToP: PRGBAArray;
SumR, SumG, SumB: Cardinal;
Times2: Integer;
xTimes, yTimes: Integer;
xxxTimes: Integer;
MarginL, MarginT: Integer;
begin
Dst.Width := floor(Src.Width/ Times);
Dst.Height := floor(Src.Height / Times);
Times2 := Times * Times;
MarginL := (Src.Width - (Dst.Width * Times)) div 2;
MarginT := (Src.Height - (Dst.Height * Times)) div 2;
for y:=0 to Dst.Height-1 do begin
ToP := Dst.Scanline[y];
yTimes := MarginT + y*Times;
for x:=0 to Dst.Width-1 do begin
SumR := 0;
SumG := 0;
SumB := 0;
xTimes := MarginL + x*Times;
for yy:=0 to Times-1 do begin
FromP := Src.Scanline[yy + yTimes];
for xx:=0 to Times-1 do begin
xxxTimes := xx + xTimes;
SumR := SumR + FromP[xxxTimes].R;
SumG := SumG + FromP[xxxTimes].G;
SumB := SumB + FromP[xxxTimes].B;
end;
end;
ToP[x].R := SumR div Times2;
ToP[x].G := SumG div Times2;
ToP[x].B := SumB div Times2;
end;
end;
end;
Usage:
InB := TBitmap.Create;
OutB := TBitmap.Create;
InB.LoadFromFile('2.bmp');
InB.PixelFormat := pf32bit;
OutB.PixelFormat := pf32bit;
Downsample2(InB, OutB, 4);
How can I make it even faster?
If you are still interested in an answer, you could give this thumbnail-routine a try. It's the result of a discussion way back on the Borland newsgroups. On my system it runs a bit faster than Stretch_Halftone, but the box-rescaling is a bit too foggy for my taste. I've abandoned all box-rescaling myself, because the system-rescaling, on my graphics at least, looks better; almost as if it was using bicubic scaling behind the scenes.
The speed gain is by use of lookup-tables, pointer- and integer-math.
// procedure MakeThumbnailMod
// Original source: Roy Magne Klever
// Altered to avoid division by 0
// and tried to make it a bit faster (RS)
//Integer math courtesy of Hagen Redmann
type
PRGB32 = ^TRGB32;
TRGB32 = packed record
b: byte;
g: byte;
r: byte;
a: byte;
end;
TLine32 = array [0 .. maxint div SizeOf(TRGB32) - 1] of TRGB32;
PLine32 = ^TLine32;
TIntArray = array of integer;
TDeltaArray = array of array of integer;
procedure MakeStepsAndWeights(xscale, yscale: Single; xw, yh: integer;
var dxmin, dymin: integer; var Weights: TDeltaArray;
var xsteps, ysteps: TIntArray);
var
i, j: integer;
x1, x2: integer;
dxmax, dymax, intscale: integer;
fact: Single;
begin
SetLength(xsteps, xw);
SetLength(ysteps, yh);
intscale := round(xscale * $10000);
// won't work if xcale > $10000/2, because then intscale
// exceeds 32bit integer. I don't see that happening.
x1 := 0;
x2 := intscale shr 16;
for i := 0 to xw - 1 do
begin
xsteps[i] := x2 - x1;
x1 := x2;
x2 := (i + 2) * intscale shr 16;
end;
dxmin := Ceil(xscale - 1);
dxmax := trunc(xscale + 1);
intscale := round(yscale * $10000);
x1 := 0;
x2 := intscale shr 16;
for i := 0 to yh - 1 do
begin
ysteps[i] := x2 - x1;
x1 := x2;
x2 := (i + 2) * intscale shr 16;
end;
dymin := Ceil(yscale - 1);
dymax := trunc(yscale + 1);
SetLength(weights, dxmax - dxmin + 1, dymax - dymin + 1);
for i := 0 to dxmax - dxmin do
begin
fact := 1 / (dxmin + i);
for j := 0 to dymax - dymin do
weights[i, j] := round(fact / (dymin + j) * $10000);
end;
end;
procedure MakeThumbNailMod(const Src, Dest: TBitmap;
NewWidth, NewHeight: integer);
var
xscale, yscale: Single;
x1: integer;
ix, iy: integer;
totalRed, totalGreen, totalBlue: integer;
ratio: integer;
p: PRGB32;
pt1: PRGB32;
ptrD, ptrS: integer;
x, y: integer;
r1, r2: TRect;
x3: integer;
RowDest, RowSource, RowSourceStart: integer;
weights: TDeltaArray;
xsteps, ysteps: TIntArray;
w, h, dxmin, dymin: integer;
dx, dy: integer;
begin
Dest.PixelFormat := pf32bit;
Src.PixelFormat:=pf32bit; //to be on the safe side
Dest.Width := NewWidth;
Dest.Height := NewHeight;
if (Dest.Width >= Src.Width) or (Dest.Height >= Src.Height) then
begin //we don't do upsampling
r1 := rect(0, 0, Src.Width, Src.Height);
r2 := r1;
OffsetRect(r2, (Dest.Width - Src.Width) div 2,
(Dest.Height - Src.Height) div 2);
Dest.Canvas.CopyRect(r2, Src.Canvas, r1);
exit;
end;
w := Dest.Width;
h := Dest.Height;
ptrD := (w * 32 + 31) and not 31;
ptrD := ptrD div 8; // BytesPerScanline
ptrS := (Src.Width * 32 + 31) and not 31;
ptrS := ptrS div 8;
xscale := Src.Width / w;
yscale := Src.Height / h; // turns div into mults
MakeStepsAndWeights(xscale, yscale, w, h, dxmin, dymin, weights, xsteps, ysteps);
// Make 3 lookup tables for the steps and the ratios
w := w - 1;
h := h - 1;
RowDest := integer(Dest.Scanline[0]);
RowSourceStart := integer(Src.Scanline[0]);
RowSource := RowSourceStart;
for y := 0 to h do
begin
dy := ysteps[y];
x1 := 0;
x3 := 0;
for x := 0 to w do
begin
dx := xsteps[x];
totalRed := 0;
totalGreen := 0;
totalBlue := 0;
RowSource := RowSourceStart;
for iy := 1 to dy do
begin
p := PRGB32(RowSource + x1);
for ix := 1 to dx do
begin
totalRed := totalRed + p^.r;
totalGreen := totalGreen + p^.g;
totalBlue := totalBlue + p^.b; //maybe add the alpha-channel optionally
inc(p);
end;
RowSource := RowSource - ptrS;
end;
pt1 := PRGB32(RowDest + x3);
ratio := weights[dx - dxmin, dy - dymin];
pt1^.r := (totalRed * ratio) shr 16; //"rounding"
pt1^.g := (totalGreen * ratio) shr 16;
pt1^.b := (totalBlue * ratio) shr 16;
x1 := x1 + 4 * dx;
x3 := x3 + 4;
end;
RowDest := RowDest - ptrD;
RowSourceStart := RowSource;
end;
//SharpenMod(Work, Dest, min(1 + 0.4 * (xscale - 1), 2.5));
//The sharpening makes the thumb look nicer, but is omitted here
end;
I want to draw a curved right arrow at TCanvas as shape in Microsoft Word.
Does anybody know an working method?
Simple method to draw complex figures. If you need antialiasing, use GDIPlus or other advanced graphic means.
procedure DrawCurveArrow(ACanvas: TCanvas; AColor: TColor;
X0, Y0, Size: Integer);
const
Magic = 0.552; // constant to approximate circular arc with Bezier curve
var
Pt: array of TPoint;
Flags: array of Byte;
R, RMag: Integer;
begin
SetLength(Pt, 18);
SetLength(Flags, 18);
R := 5 * Size div 16;
RMag := Round(R * Magic);
Pt[0] := Point(X0 + 1, Y0); // to thicken tail a bit
Flags[0] := PT_MOVETO;
Pt[1] := Point(X0 + 1, Y0 - RMag);
Flags[1] := PT_BEZIERTO;
Pt[2] := Point(X0 + R - RMag, Y0 - R);
Flags[2] := PT_BEZIERTO;
Pt[3] := Point(X0 + R, Y0 - R);
Flags[3] := PT_BEZIERTO;
Pt[4] := Point(X0 + R + RMag, Y0 - R);
Flags[4] := PT_BEZIERTO;
Pt[5] := Point(X0 + 2 * R, Y0 - RMag);
Flags[5] := PT_BEZIERTO;
Pt[6] := Point(X0 + 2 * R, Y0);
Flags[6] := PT_BEZIERTO;
Pt[7] := Point(X0 + Size div 2, Y0);
Flags[7] := PT_LINETO;
Pt[8] := Point(X0 + Size * 3 div 4, Y0 + Size div 4);
Flags[8] := PT_LINETO;
Pt[9] := Point(X0 + Size, Y0);
Flags[9] := PT_LINETO;
Pt[10] := Point(X0 + 7 * Size div 8, Y0);
Flags[10] := PT_LINETO;
R := 7 * Size div 16;
RMag := Round(R * Magic);
Pt[11] := Point(X0 + 2 * R, Y0 - RMag);
Flags[11] := PT_BEZIERTO;
Pt[12] := Point(X0 + R + RMag, Y0 - R);
Flags[12] := PT_BEZIERTO;
Pt[13] := Point(X0 + R, Y0 - R);
Flags[13] := PT_BEZIERTO;
Pt[14] := Point(X0 + R - RMag, Y0 - R);
Flags[14] := PT_BEZIERTO;
Pt[15] := Point(X0, Y0 - RMag);
Flags[15] := PT_BEZIERTO;
Pt[16] := Point(X0, Y0);
Flags[16] := PT_BEZIERTO;
Pt[17] := Point(X0 + 1, Y0);
Flags[17] := PT_LINETO or PT_CLOSEFIGURE;
BeginPath(ACanvas.Handle);
PolyDraw(ACanvas.Handle, Pt[0], Flags[0], Length(Pt));
EndPath(ACanvas.Handle);
ACanvas.Brush.Color := AColor;
FillPath(ACanvas.Handle);
end;
begin
DrawCurveArrow(Canvas, clBlue, 100, 200, 300);
Well, it seems that MBo was quicker then me and his solution is better then my. But I'll put my answer anyway. Note that it counts with white background (MBo's solution is background-independent).
procedure draw_arrow(canvas: TCanvas; x, y, size: Integer; color: TColor);
begin
with canvas do
begin
Pen.Style:=psClear;
Brush.Style:=bsSolid;
Brush.Color:=color;
Ellipse(x+1, y, x+size+1, y+size);
Brush.Color:=clWhite;
Ellipse(x, y+size div 6, x+Round(size/1.5), y+Round(size/1.2));
Rectangle(x, y+size div 2, x+size+1, y+size);
Brush.Color:=color;
Polygon([Point(x+size div 2, y+size div 2), Point(x+size div 2+Round(size/1.5), y+size div 2), Point(x+size-size div 6, y+Round(size/1.2))]);
end;
end;
I want to "fade" in / out an image. But not opacity-wise.
Pictures say more than words:
Original image:
Desired image:
How can I do that programatically? Not the way like "use Bitmap.Canvas" but the mathematical approach. ("For dummies" if possible ... :D)
I want the image to have a fade-in / -out area, not linear increasing but "curvy". I guess it has something to do with Bezier curves? If yes, how would I setup the points to get a curve like that?
Or what would be your approach here?
Thanks for any help! :)
Here is roughly how you would go about doing it (as you said, you're looking for the logic and not the full implementation)
Create the basic shape outline: Create a partial sine-wave, such that the semi-period (half-wavelength: P1 = L/2) equals the length (x-coordinate size) of your image.
Add Overtones: Add to it another sine-function. This time with wavelength given by P2 = P1 / 2 + rnd where rnd is a random real number in the interval (-P1/4 , +P1 / 4)
Repeat: Now P2 becomes the new P1.
That way you can generate the 'wavy-waves' by modulating the main wave and you will get the top boundary.
You can change the sign and get the lower boundary.
The word you might be looking for (for the shape, i.e.) is Overtones. You could look up more on generating overtones for optics or acoustics.
This example for adding overtones to a straight line would give a better idea. The code above adds up these sinusoidal waves of randomly shortening periods to create the wave-on-wave effect (source)
Thanks again, hnk. You got me the right ideas. :)
I did a little work and ended up with this:
procedure GenerateOverlayEdges(ABitmap: TBitmap; ARadiusX, ARadiusY: Integer);
const
MAX_ANGLE = 90;
var
ShapePosition, ShapeIndex, ShapesCount,
Angle, X, Y, RadiusX, RadiusY, CenterY: Integer;
PolyPoints: Array of TPoint;
begin
ABitmap.Canvas.Pen.Color := clBlack;
ABitmap.Canvas.Brush.Color := clBlack;
//ABitmap.Canvas.Pen.Color := clWhite;
//ABitmap.Canvas.Brush.Color := clWhite;
RadiusX := ARadiusX;
RadiusY := ARadiusY;
CenterY := Round(ABitmap.Height / 2);
ShapesCount := Ceil(CenterY / RadiusY);
for ShapePosition := 1 to 4 do // 1 = TopLeft, 2 = BottomLeft, 3 = TopRight, 4 = BottomRight
for ShapeIndex := 0 to ShapesCount - 1 do // Index of current "stair"
begin
Finalize(PolyPoints);
SetLength(PolyPoints, MAX_ANGLE + 1);
for Angle := 0 to MAX_ANGLE do
begin
case ShapePosition of
1, 3:
begin
RadiusX := Abs(RadiusX);
RadiusY := Abs(RadiusY);
end;
2, 4:
begin
RadiusX := Abs(RadiusX);
RadiusY := -Abs(RadiusY);
end;
end;
X := Trunc(RadiusX * Cos(Angle * 2 * Pi / 360));
Y := Trunc(RadiusY * Sin(Angle * 2 * Pi / 360));
case ShapePosition of
1:
begin
X := X + ShapeIndex * RadiusX;
Y := Y + CenterY - RadiusY - ShapeIndex * RadiusY;
end;
2:
begin
X := X + ShapeIndex * RadiusX;
Y := Y + CenterY - RadiusY + ShapeIndex * Abs(RadiusY);
end;
3:
begin
X := ABitmap.Width - X - ShapeIndex * Abs(RadiusX);
Y := Y + CenterY - RadiusY - ShapeIndex * RadiusY;
end;
4:
begin
X := ABitmap.Width - X - ShapeIndex * Abs(RadiusX);
Y := Y + CenterY + Abs(RadiusY) + ShapeIndex * Abs(RadiusY);
end;
end;
// Add points as part of a Polyon
PolyPoints[Angle] := Point(X, Y);
end;
// Set Y to the Y borders for the very first and last point of the polygon so we will get a "closed" shape
case ShapePosition of
1, 3:
begin
PolyPoints[0] := Point(PolyPoints[0].X, 0);
PolyPoints[Angle - 1] := Point(PolyPoints[Angle - 1].X, 0);
end;
2, 4:
begin
PolyPoints[0] := Point(PolyPoints[0].X, ABitmap.Height);
PolyPoints[Angle - 1] := Point(PolyPoints[Angle - 1].X, ABitmap.Height);
end;
end;
// Draw the poly points ... and fill the background at the same time
ABitmap.Canvas.Polygon(PolyPoints);
end;
Finalize(PolyPoints);
end;
Usage:
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.LoadFromFile('C:\Temp\Osc 2.bmp'); // Original Oscilloscope Image
GenerateOverlayEdges(Bmp, 15, 20);
Bmp.SaveToFile('C:\Temp\Osc 3.bmp');
finally
Bmp.Free;
end;
end;
By changing the RadiusX and RadiusY parameters of the GenerateOverlayEdges function I can adjust the results:
8x8:
15x20:
20x10:
Any library/code to fade the edges of a bitmap in a gradient manner?
Something like this:
Edit: final code
Ok came up with this code after your example, it's ~10 times faster after optimization with scanlines. Ideally I think I should convert it to use a 32bit bitmap instead and modify the actual alpha layer, but this works for now, ty!
procedure FadeEdges(b: TBitmap; Depth, Start, Col: TColor);
Var f, x, y, i: Integer;
w,h: Integer;
pArrays: Array of pRGBArray;
xAlpha: Array of byte;
sR, sG, sB: Byte;
a,a2: Double;
r1,g1,b1: Double;
Lx,Lx2: Integer;
procedure AlphaBlendPixel(X, Y: Integer);
begin
pArrays[y,x].rgbtRed := Round(r1 + pArrays[y,x].rgbtRed * a2);
pArrays[y,x].rgbtGreen := Round(g1 + pArrays[y,x].rgbtGreen * a2);
pArrays[y,x].rgbtBlue := Round(b1 + pArrays[y,x].rgbtBlue * a2);
end;
procedure AlphaBlendRow(Row: Integer; Alpha: Byte);
Var bR, bG, bB, xA: Byte;
t: Integer;
s,s2: Double;
begin
s := alpha / 255;
s2 := (255 - Alpha) / 255;
for t := 0 to b.Width-1 do begin
bR := pArrays[Row,t].rgbtRed;
bG := pArrays[Row,t].rgbtGreen;
bB := pArrays[Row,t].rgbtBlue;
pArrays[Row,t].rgbtRed := Round(sR*s + bR*s2);
pArrays[Row,t].rgbtGreen := Round(sG*s + bG*s2);
pArrays[Row,t].rgbtBlue := Round(sB*s + bB*s2);
end;
end;
begin
b.PixelFormat := pf24bit;
// cache scanlines
SetLength(pArrays,b.Height);
for y := 0 to b.Height-1 do
pArrays[y] := pRGBArray(b.ScanLine[y]);
// pre-calc Alpha
SetLength(xAlpha,Depth);
for y := 0 to (Depth-1) do
xAlpha[y] := Round(Start + (255 - Start)*y/(Depth-1));
// pre-calc bg color
sR := GetRValue(Col);
sG := GetGValue(Col);
sB := GetBValue(Col);
// offsets
w := b.Width-Depth;
h := b.Height-Depth;
for i := 0 to (Depth-1) do begin
a := xAlpha[i] / 255;
a2 := (255 - xAlpha[i]) / 255;
r1 := sR * a;
g1 := sG * a;
b1 := sB * a;
Lx := (Depth-1)-i;
Lx2 := i+w;
for y := 0 to b.Height - 1 do begin
AlphaBlendPixel(Lx, y); // Left
AlphaBlendPixel(Lx2, y); // right
end;
end;
for i := 0 to (Depth-1) do begin
AlphaBlendRow((Depth-1)-i, xAlpha[i]); // top
AlphaBlendRow(i+(h), xAlpha[i]); // bottom
end;
SetLength(xAlpha,0);
SetLength(pArrays,0);
end;
Final result: (left = original, right = blended on hovering with a ListView)
edit: further speed improvements, twice as fast as original proc.
I can give you some code I wrote a couple of years ago to achieve this. It might be useful as a guide. The code is part of a class that manipulates a bitmap and this is the part that fades the left edge of the bitmap into a white background:
procedure TScreenShotEnhancer.FadeOutLeft(Position, Start: Integer);
var
X, Y: Integer;
F, N: Integer;
I: Integer;
begin
BeginUpdate;
try
N := Position;
for I := 0 to N - 1 do begin
X := Position - I - 1;
F := Round(Start + (255 - Start)*I/N);
for Y := 0 to Height - 1 do
AlphaBlendPixel(X, Y, clWhite, F);
end;
finally
EndUpdate;
end;
end;
The actual work is done in this method:
procedure TScreenShotEnhancer.AlphaBlendPixel(X, Y: Integer; Color: TColor;
Alpha: Byte);
var
backgroundColor: TColor;
displayColor: TColor;
dR, dG, dB: Byte;
bR, bG, bB: Byte;
sR, sG, sB: Byte;
begin
backgroundColor := Bitmap.Canvas.Pixels[X, Y];
bR := GetRValue(backgroundColor);
bG := GetGValue(backgroundColor);
bB := GetBValue(backgroundColor);
sR := GetRValue(Color);
sG := GetGValue(Color);
sB := GetBValue(Color);
dR := Round(sR * alpha / 255 + bR * (255 - alpha) / 255);
dG := Round(sG * alpha / 255 + bG * (255 - alpha) / 255);
dB := Round(sB * alpha / 255 + bB * (255 - alpha) / 255);
displayColor := RGB(dR, dG, dB);
Bitmap.Canvas.Pixels[X, Y] := displayColor;
end;