Quick Smooth Resizing of Bitmaps - delphi

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;

Related

Draw curved arrow in delphi

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;

Draw a stretched and rotated image on TCanvas

i am trying to draw a rotated bitmap on a TImage canvas at some specified points, what i tried so far is i rotated the bitmap and then used stretched draw but i am not getting the results i want, the scenario goes like this
I map 4 points on a TImage canvas with mouse clicks and get its angle, the angle can be 0, 45, 90 anything, something like in the image i have attached
Now what i need is to draw another bitmap rotated and stretched on these points, i am having a hard time figuring this thing out
Regards
Many years ago, when stars was brighter and girls was younger, i wrote this code for unknown reason. It is VCL compatible, but can be adopter in order to be used in both VCL/FMX. It is simple class to draw arbitrary rectangle from bitmap to arbitrary rectangle at destination DC (so it could be bitmap or something else). It can paint destination picture with bilinear interpolation, then result looks not so ugly as with simple stretching. Maybe it can be useful for someone.
unit uBMPUtils;
interface
uses
windows, graphics, math, sysutils;
type
PIntegers = ^TIntegers;
TIntegers = array[0..high(integer) div sizeof(integer) - 16] of integer;
TDrawLine = procedure( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer) of object;
TDrawMode = (dmSimple, dmBilinear);
TBitmapDrawer = class
protected
tmp : TBitmap;
koefs : array[0..4096*4-1] of integer; // addr(Ux, Vy) = 4 * ( (trunc(Ux*16) << 6) + trunc(Vy*16) )
calculated : boolean;
DrawModeFlag : TDrawMode;
DrawLine : TDrawLine;
procedure precalculate; // precalculate koefs for fast bilinear interpolation
procedure drawLineSimple( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer);
procedure drawLineBilinear( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer);
procedure setDrawMode(m : TDrawMode);
public
constructor Create;
destructor Destroy; override;
procedure DrawTriangle(src : TBitmap; // source bitmap (pf24 or pf32!)
dst_dc : cardinal; // destination DC
dstRect : TRect; // limiting rect for output
A1, A2, A3, // arbitrary rectange at Src bitmap
B1, B2, B3 : TPoint); // arbitrary rectange at DST_DC device
procedure DrawRectangle(src : TBitmap; // source bitmap (pf24 or pf32!)
dst_dc : cardinal; // destination DC
dstRect : TRect; // limiting rect for output
A1, A2, A3, A4, // arbitrary rectange at Src bitmap
B1, B2, B3, B4 : TPoint); // arbitrary rectange at DST_DC device
property DrawMode: TDrawMode read DrawModeFlag write setDrawMode; // Default: dmBilinear
end;
implementation
function HorAtLine(var x : integer; y, x1,y1,x2,y2 : integer):boolean;
begin
if y1 = y2 then result := false else
begin
result := (y >= y1) and (y <= y2) or (y >= y2) and (y <= y1);
if result then x := x1 + (x2 - x1) * (y - y1) div (y2 - y1);
end;
end;
procedure LineProportion(var src_x, src_y : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
dst_x, dst_y : integer;
dst_x1, dst_y1, dst_x2, dst_y2 : integer);
begin
if abs(dst_x2 - dst_x1) > abs(dst_y2 - dst_y1) then begin // proportions form Y
src_x := src_x1 + (src_x2 - src_x1) * (dst_x - dst_x1) div (dst_x2 - dst_x1);
src_y := src_y1 + (src_y2 - src_y1) * (dst_x - dst_x1) div (dst_x2 - dst_x1);
end else begin
src_x := src_x1 + (src_x2 - src_x1) * (dst_y - dst_y1) div (dst_y2 - dst_y1);
src_y := src_y1 + (src_y2 - src_y1) * (dst_y - dst_y1) div (dst_y2 - dst_y1);
end;
end;
// ---------------------------------------------- TBitmapDrawer --------------------------------------------------------
procedure TBitmapDrawer.precalculate;
var
n, u, v : integer;
Uf, Vf, k1,k2,k3,k4 : double;
begin
calculated := true;
for V := 0 to 63 do
for U := 0 to 63 do
begin
Uf := U / 64;
Vf := V / 64;
k1 := (1 - Uf) * (1 - Vf);
k2 := Uf * (1 - Vf);
k3 := (1 - Uf) * Vf;
k4 := Uf * Vf;
n := ((U shl 6) + V) * 4;
koefs[n] := trunc(k1*65536);
koefs[n+1] := trunc(k2*65536);
koefs[n+2] := trunc(k3*65536);
koefs[n+3] := trunc(k4*65536);
end;
end;
constructor TBitmapDrawer.create;
begin
inherited create;
tmp := TBitmap.create;
tmp.Height := 1;
drawMode := dmBilinear;
precalculate;
end;
destructor TBitmapDrawer.Destroy;
begin
FreeandNil(tmp);
inherited;
end;
procedure TBitmapDrawer.DrawRectangle(src : TBitmap;
dst_dc : cardinal;
dstRect : TRect;
A1, A2, A3, A4,
B1, B2, B3, B4 : TPoint);
begin
DrawTriangle(src, dst_dc, dstRect, A1, A2, A3, B1, B2, B3);
DrawTriangle(src, dst_dc, dstRect, A1, A3, A4, B1, B3, B4);
end;
procedure TBitmapDrawer.DrawTriangle(src : TBitmap;
dst_dc : cardinal;
dstRect : TRect;
A1, A2, A3,
B1, B2, B3 : TPoint);
var
pixelSize, srcAdd, left_x, left_y, right_x, right_y: integer;
minx, maxx, x, y, top, bottom : integer;
pb : pointer;
begin
if src.height > 1 then srcAdd := integer(PAnsiChar(src.scanline[1]) - PAnsiChar(src.scanline[0])) else srcAdd := 0;
top := min(min(b1.y, b2.y), b3.y);
bottom := max(max(b1.y, b2.y), b3.y);
if (top > dstRect.Bottom) or (bottom < dstRect.Top) then exit;
if top < dstRect.Top then top := dstRect.Top;
if bottom > dstRect.Bottom then bottom := dstRect.Bottom;
case src.pixelFormat of
pf24bit : pixelsize := 3;
pf32bit : pixelsize := 4;
else raise exception.create('Error');
end;
if tmp.PixelFormat <> src.PixelFormat then tmp.PixelFormat := src.PixelFormat;
y := max(max(b1.X, b2.x), b3.x) - min(min(b1.X, b2.x), b3.x) + 1;
if (tmp.Width < y) then tmp.Width := y;
pb := tmp.scanline[0];
for y := top to bottom do // Y at destination picture
begin
minx := high(integer);
maxx := low(integer);
if HorAtLine(x,y, b1.X, b1.Y, b2.x, b2.Y) then
begin
if x < minx then begin
minx := x;
LineProportion(left_x, left_y, a1.X, a1.Y, a2.x, a2.Y, x,y, b1.X, b1.Y, b2.X, b2.Y);
end;
if x > maxx then begin
LineProportion(right_x, right_y, a1.X, a1.Y, a2.x, a2.Y, x,y, b1.X, b1.Y, b2.X, b2.Y);
maxx := x;
end;
end;
if HorAtLine(x,y, b2.X, b2.Y, b3.x, b3.Y) then
begin
if x < minx then begin
minx := x;
LineProportion(left_x, left_y, a2.X, a2.Y, a3.x, a3.Y, x,y, b2.X, b2.Y, b3.X, b3.Y);
end;
if x > maxx then begin
LineProportion(right_x, right_y, a2.X, a2.Y, a3.x, a3.Y, x,y, b2.X, b2.Y, b3.X, b3.Y);
maxx := x;
end;
end;
if HorAtLine(x,y, b3.X, b3.Y, b1.x, b1.Y) then
begin
if x < minx then begin
minx := x;
LineProportion(left_x, left_y, a3.X, a3.Y, a1.x, a1.Y, x,y, b3.X, b3.Y, b1.X, b1.Y);
end;
if x > maxx then begin
LineProportion(right_x, right_y, a3.X, a3.Y, a1.x, a1.Y, x,y, b3.X, b3.Y, b1.X, b1.Y);
maxx := x;
end;
end;
if minx > maxx then continue;
// destination line (minx, y) - (maxx, y) - now we can find it at source picture
drawLine(pixelSize, src.ScanLine[0]^, srcAdd, left_x, left_y, right_x, right_y, pb^, maxx - minx + 1);
bitblt(dst_dc, minx, y, maxx-minx+1, 1, tmp.Canvas.Handle, 0,0, srccopy);
end;
end;
procedure TBitmapDrawer.drawLineSimple( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer);
var
dst_ptr : PAnsiChar;
i, px, py : integer;
begin
dst_ptr := #dst;
px := (src_x2 - src_x1) * 65536 div dstLen;
py := (src_y2 - src_y1) * 65536 div dstLen;
src_x1 := src_x1 * 65536;
src_y1 := src_y1 * 65536;
for i := 0 to dstLen - 1 do
begin
pinteger(dst_ptr)^ := pinteger( PAnsiChar(#src) +
((src_y1 + i * py) shr 16) * srcLineAdd +
((src_x1 + i * px) shr 16) * pixelSize
)^;
inc(dst_ptr, pixelSize);
end;
end;
procedure TBitmapDrawer.drawLineBilinear( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer);
var
src_ptr, dst_ptr : PAnsiChar;
u,v,Uf,Vf : integer;
i : integer;
k : PIntegers;
c1,c2,c3,c4 : TColor;
begin
dst_ptr := #dst;
for i := 0 to dstLen - 1 do
begin
u := src_x1 + i * (src_x2 - src_x1) div dstLen;
v := src_y1 + i * (src_y2 - src_y1) div dstLen;
Uf := (src_x1 + i * (src_x2 - src_x1) * 64 div dstLen) and $3f;
Vf := (src_y1 + i * (src_y2 - src_y1) * 64 div dstLen) and $3f;
k := #koefs[4*((Uf shl 6) + Vf)];
src_ptr := PAnsiChar(#src) + v * srcLineAdd + u * pixelSize;
c1 := pinteger(src_ptr)^;
c2 := pinteger(src_ptr + 4)^;
c3 := pinteger(src_ptr + srcLineAdd)^;
c4 := pinteger(src_ptr + srcLineAdd + 4)^;
pinteger(dst_ptr)^ :=
( (c1 and $FF)*k[0] shr 16 +
(c2 and $FF)*k[1] shr 16 +
(c3 and $FF)*k[2] shr 16 +
(c4 and $FF)*k[3] shr 16 )
or
( ((c1 shr 8) and $FF)*k[0] shr 16 +
((c2 shr 8) and $FF)*k[1] shr 16 +
((c3 shr 8) and $FF)*k[2] shr 16 +
((c4 shr 8) and $FF)*k[3] shr 16 ) shl 8
or
( ((c1 shr 16) and $FF)*k[0] shr 16 +
((c2 shr 16) and $FF)*k[1] shr 16 +
((c3 shr 16) and $FF)*k[2] shr 16 +
((c4 shr 16) and $FF)*k[3] shr 16 ) shl 16
or $02000000;
inc(dst_ptr, pixelSize);
end;
end;
procedure TBitmapDrawer.setDrawMode(m: TDrawMode);
begin
drawModeFlag := m;
case drawModeFlag of
dmSimple : drawLine := drawLineSimple;
dmBilinear : drawLine := drawLineBilinear;
end;
end;
end.
I finally got the desired output using Projective transformation method in Graphics32 http://graphics32.org/wiki/

Create a transparent bitmap and UpdateLayeredWindow

I'm trying to create a mask window with "loading" text, to alert the user about a busy state of my application.
For this, I first created a single form with:
BorderStyle = bsNone
Color = clBlack
AlphaBlend = True
AlphaBlendValue = 180;
As the second step, I want to create another Form, but this one will has dynamic content.
I need to create a transparent bitmap with some status text and use the UpdateLayeredWindow to draw the window as the text.
Take a look and my desired result:
Remember: the text will be different in some cases, like:
Recalculating
Loading resources
Loading report
That's the reason what I need a dynamic bitmap generation.
QUESTION
How can I create a transparent bitmap with text and use it on a form with UpdateLayeredWindow?
I'm trying this, but without success ( to try the code put a Button5 and Label2 on a form):
procedure Inc(var p: pointer);
begin
p := Pointer(Integer(p) + 1);
end;
var
s: string;
frm: TForm;
f: HFont;
tx: HDC;
bmp, old: HBITMAP;
rc: TRect;
h: BITMAPINFOHEADER;
pvBits: Pointer;
t: tagBITMAPINFO;
x,y: integer;
a, r, g, b: byte;
sz: TSize;
p: tpoint;
BlendFunction: TBlendFunction;
begin
tx := CreateCompatibleDC(0);
s := label2.Caption;
f := SelectObject(tx, label2.Font.Handle);
fillchar(rc, SizeOf(rc), 0);
DrawText(tx, PChar(s), length(s), rc, DT_CALCRECT);
fillchar(h, SizeOf(h), 0);
pvBits := nil;
h.biSize := SizeOf(h);
h.biWidth := rc.Right - rc.Left;
h.biHeight := rc.Bottom - rc.Top;
h.biPlanes := 1;
h.biBitCount := 32;
h.biCompression := BI_RGB;
FillChar(t, SizeOf(t), 0);
t.bmiHeader := h;
bmp := CreateDIBSection(tx, t, 0, pvBits, 0, 0);
old := SelectObject(tx, bmp);
if old > 0 then
begin
SetTextColor(tx, $00FFFFFF);
SetBkColor(tx, $00000000);
SetBkMode(tx, TRANSPARENT);
DrawText(tx, PChar(s), length(s), rc, DT_NOCLIP);
r := GetRValue($FF);
g := GetGValue($FF);
b := GetBValue($FF);
for x := 0 to h.biWidth-1 do
for y := 0 to h.biHeight-1 do
begin
a := Byte(pvBits^);
Inc(pvBits);
Byte(pvBits^) := (b * a) shr 8;
Inc(pvBits);
Byte(pvBits^) := (g * a) shr 8;
Inc(pvBits);
Byte(pvBits^) := (r * a) shr 8;
Inc(pvBits);
Byte(pvBits^) := a;
end;
SelectObject(tx, old);
end;
SelectObject(tx, f);
deleteDC(tx);
sz.cx := h.biWidth;
sz.cy := h.biHeight;
p := Point(0,0);
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
frm := TForm.CreateNew(self);
frm.BorderStyle := bsNone;
frm.Position := poOwnerFormCenter;
frm.Show;
UpdateLayeredWindow(frm.Handle, 0, nil, #sz, bmp, #p, 0, #BlendFunction, ULW_ALPHA);
end;
Assuming you can use Windows API functions from Delphi (since you've tagged winapi), one easy way is:
CreateDIBSection() to create a 32 bit bitmap
FillRect() to fill the background, DrawText() to draw the text
Fix up the alpha
Use that bitmap with UpdateLayeredWindow()
Fixing up the alpha is done by directly modifying the bitmap bits that you get back from CreateDIBSection(). Note that UpdateLayeredWindow() requires pre-multiplied alpha, so you have to multiple the RGB components by the alpha value in advance.
The following code is C but hopefully will give you the idea:
LPVOID pBits; // bits from CreateDIBSection
const int width, height; // size of bitmap
const int alpha; // level of transparency
RGBQUAD* pPtr = (RGBQUAD*)pBits;
for (int y = 0; y < height; ++y)
{
for (int x = 0; x < width; ++x, ++pPtr)
{
pPtr->rgbBlue = (alpha * pPtr->rgbBlue) / 255;
pPtr->rgbGreen = (alpha * pPtr->rgbGreen) / 255;
pPtr->rgbRed = (alpha * pPtr->rgbRed) / 255;
pPtr->rgbReserved = alpha;
}
}

Delphi - gradial fade of bitmap edges

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;

converting a PNGImage to grayscale using delphi

hi there
here it is my code:
procedure TForm4.Button1Click(Sender: TObject);
var
png: TPNGImage;
data: PRGBQarray;
p: ^tagRGBQuad;
i, o: integer;
begin
png := TPNGImage.Create;
try
png.LoadFromFile('C:\Untitled.png');
for o := 1 to 100 do
begin
data:=png.Scanline[o];
for I := 1 to 400 do
begin
p := #data^[i];
p.rgbGreen := p.rgbBlue;
p.rgbRed := p.rgbGreen;
end;
end;
img.picture.Assign(png);
finally
png.Free;
end;
end;
it doesn't work and it makes the pic messy, I'm sure it's because of the rgbReserved.
what should i do?
This is how to greyify a bitmap. (And, yes, if you want to greyify a PNG, you first need to get the bitmap data out of it. I think the VCL will do this for you.)
type
PRGB32Array = ^TRGB32Array;
TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;
procedure MakeGrey(Bitmap: TBitmap);
var
w, h: integer;
y: Integer;
sl: PRGB32Array;
x: Integer;
grey: byte;
begin
Bitmap.PixelFormat := pf32bit;
w := Bitmap.Width;
h := Bitmap.Height;
for y := 0 to h - 1 do
begin
sl := Bitmap.ScanLine[y];
for x := 0 to w - 1 do
with sl[x] do
begin
grey := (rgbBlue + rgbGreen + rgbRed) div 3;
rgbBlue := grey;
rgbGreen := grey;
rgbRed := grey;
end;
end;
end;
Sample usage:
procedure TForm4.Button1Click(Sender: TObject);
var
bm: TBitmap;
begin
bm := TBitmap.Create;
try
bm.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\Porträtt, litet, kvadratiskt.bmp');
MakeGrey(bm);
Canvas.Draw(0, 0, bm);
finally
bm.Free;
end;
end;
Andreas's answer will give you a good, fast approximation, but you'll lose some quality, because red, green and blue don't mix with equal intensities in the human eye. If you want to "get it right", instead of
grey := (rgbBlue + rgbGreen + rgbRed) div 3;
try this:
grey := round(rgbRed * .3) + round(rgbGreen * .59) + round(rgbBlue * .11);
You'll get a bit of a performance hit over the simple average, though it probably won't be noticeable unless you're on a very large image.
I know the question has already been answered but here is my 2c worth...
The following code comes from the PNGComponents package (PngFunctions.pas) produced by Thany.
//
//The Following code comes from the PNGComponents package from Thany...
//
procedure MakeImageGrayscale(Image: TPNGObject; Amount: Byte = 255);
procedure GrayscaleRGB(var R, G, B: Byte);
var
X: Byte;
begin
X := Round(R * 0.30 + G * 0.59 + B * 0.11);
R := Round(R / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
G := Round(G / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
B := Round(B / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
end;
var
X, Y, PalCount: Integer;
Line: Pointer;
PaletteHandle: HPalette;
Palette: array[Byte] of TPaletteEntry;
begin
//Don't do anything if the image is already a grayscaled one
if not (Image.Header.ColorType in [COLOR_GRAYSCALE, COLOR_GRAYSCALEALPHA])
then begin
if Image.Header.ColorType = COLOR_PALETTE
then begin
//Grayscale every palette entry
PaletteHandle := Image.Palette;
PalCount := GetPaletteEntries(PaletteHandle, 0, 256, Palette);
for X := 0 to PalCount - 1
do GrayscaleRGB(Palette[X].peRed, Palette[X].peGreen, Palette[X].peBlue);
SetPaletteEntries(PaletteHandle, 0, PalCount, Palette);
Image.Palette := PaletteHandle;
end
else begin
//Grayscale every pixel
for Y := 0 to Image.Height - 1
do begin
Line := Image.Scanline[Y];
for X := 0 to Image.Width - 1
do GrayscaleRGB(PRGBLine(Line)^[X].rgbtRed, PRGBLine(Line)^[X].rgbtGreen, PRGBLine(Line)^[X].rgbtBlue);
end;
end;
end;
end;
There is a set of routines, that was originally published by the author of the PNGImage components, that can be found on Code Central that shows how to do other things like Alpha blending two images, rotation, overlay, etc. CodeCentral Link
This really should have been a comment to #Mason's routine to turn RGB into GreyScale, but since I don't know how to make a comment show code, I'm making it an answer instead.
This is how I do the conversion:
FUNCTION RGB2GRAY(R,G,B : BYTE) : BYTE; Register; ASSEMBLER;
ASM
IMUL EAX,19595
IMUL EDX,38470
IMUL ECX,7471
ADD EAX,EDX
ADD EAX,ECX
SHR EAX,16
END;
FUNCTION GreyScale(C : TColor) : TColor; Register; ASSEMBLER;
ASM
MOVZX EDX,AH
MOV ECX,EAX
SHR ECX,16
MOVZX EAX,AL
CALL RGB2GRAY
MOVZX EAX,AL
MOV AH,AL
SHL EAX,8
MOV AL,AH
END;
I don't know if it is NTSC formula or whatever, but they seem to work in my programs :-).

Resources