unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TRGBArray =
array[Word]
of TRGBTriple;
pRGBArray = ^TRGBArray;
type
TForm1 =
class(TForm)
Image1: TImage;
Image2: TImage;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure SmoothResize(Src, Dst: TBitmap);
var
x, y: Integer;
xP, yP: Integer;
xP2, yP2: Integer;
SrcLine1, SrcLine2: pRGBArray;
t3: Integer;
z, z2, iz2: Integer;
DstLine: pRGBArray;
DstGap: Integer;
w1, w2, w3, w4: Integer;
begin
Src.PixelFormat := pf24Bit;
Dst.PixelFormat := pf24Bit;
if (Src.Width = Dst.Width)
and (Src.Height = Dst.Height)
then
Dst.Assign(Src)
else
begin
DstLine := Dst.ScanLine[0];
DstGap := Integer(Dst.ScanLine[1]) - Integer(DstLine);
xP2 := MulDiv(pred(Src.Width), $10000, Dst.Width);
yP2 := MulDiv(pred(Src.Height), $10000, Dst.Height);
yP := 0;
for y := 0
to pred(Dst.Height)
do
begin
xP := 0;
SrcLine1 := Src.ScanLine[yP
shr 16];
if (yP
shr 16 < pred(Src.Height))
then
SrcLine2 := Src.ScanLine[succ(yP
shr 16)]
else
SrcLine2 := Src.ScanLine[yP
shr 16];
z2 := succ(yP
and $FFFF);
iz2 := succ((
not yp)
and $FFFF);
for x := 0
to pred(Dst.Width)
do
begin
t3 := xP
shr 16;
z := xP
and $FFFF;
w2 := MulDiv(z, iz2, $10000);
w1 := iz2 - w2;
w4 := MulDiv(z, z2, $10000);
w3 := z2 - w4;
DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +
SrcLine1[t3 + 1].rgbtRed * w2 +
SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4)
shr 16;
DstLine[x].rgbtGreen :=
(SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +
SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4)
shr 16;
DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +
SrcLine1[t3 + 1].rgbtBlue * w2 +
SrcLine2[t3].rgbtBlue * w3 +
SrcLine2[t3 + 1].rgbtBlue * w4)
shr 16;
Inc(xP, xP2);
end;
{for}
Inc(yP, yP2);
DstLine := pRGBArray(Integer(DstLine) + DstGap);
end;
{for}
end;
{if}
end;
{SmoothResize}
{---------------------------------------------------------------------------
-----------------------}
procedure TForm1.Button1Click(Sender: TObject);
begin
SmoothResize(Image1.Picture.Bitmap, Image2.Picture.Bitmap);
end;
end.