Compare Image by Pixel

procedure TForm1.Button1Click(Sender: TObject);
var
b1, b2: TBitmap;
c1, c2: PByte;
x, y, i,
different: Integer; // Counter for different pixels
begin
b1 := Image1.Picture.Bitmap;
b2 := Image2.Picture.Bitmap;
Assert(b1.PixelFormat = b2.PixelFormat); // they have to be equal
different := 0;
for y := 0 to b1.Height - 1 do
begin
c1 := b1.Scanline[y];
c2 := b2.Scanline[y];
for x := 0 to b1.Width - 1 do
for i := 0 to BytesPerPixel - 1 do // 1, to 4, dep. on pixelformat
begin
Inc(different, Integer(c1^ <> c2^));
Inc(c1);
Inc(c2);
end;
end;
end;

Scale By Precent

{ .... }

private
function ScalePercentBmp(bitmp: TBitmap; iPercent: Integer): Boolean;

{ .... }

function TForm1.ScalePercentBmp(bitmp: TBitmap;
iPercent: Integer): Boolean;
var
TmpBmp: TBitmap;
ARect: TRect;
h, w: Real;
hi, wi: Integer;
begin
Result := False;
try
TmpBmp := TBitmap.Create;
try
h := bitmp.Height * (iPercent / 100);
w := bitmp.Width * (iPercent / 100);
hi := StrToInt(FormatFloat('#', h)) + bitmp.Height;
wi := StrToInt(FormatFloat('#', w)) + bitmp.Width;
TmpBmp.Width := wi;
TmpBmp.Height := hi;
ARect := Rect(0, 0, wi, hi);
TmpBmp.Canvas.StretchDraw(ARect, Bitmp);
bitmp.Assign(TmpBmp);
finally
TmpBmp.Free;
end;
Result := True;
except
Result := False;
end;
end;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
ScalePercentBmp(Image1.Picture.Bitmap, 33);
end;

Convert Bitmap to Sephia

function bmptosepia(const bmp: TBitmap; depth: Integer): Boolean;
var
color,color2:longint;
r,g,b,rr,gg:byte;
h,w:integer;
begin
for h := 0 to bmp.height do
begin
for w := 0 to bmp.width do
begin
//first convert the bitmap to greyscale
color:=colortorgb(bmp.Canvas.pixels[w,h]);
r:=getrvalue(color);
g:=getgvalue(color);
b:=getbvalue(color);
color2:=(r+g+b) div 3;
bmp.canvas.Pixels[w,h]:=RGB(color2,color2,color2);
//then convert it to sepia
color:=colortorgb(bmp.Canvas.pixels[w,h]);
r:=getrvalue(color);
g:=getgvalue(color);
b:=getbvalue(color);
rr:=r+(depth*2);
gg:=g+depth;
if rr <= ((depth*2)-1) then
rr:=255;
if gg <= (depth-1) then
gg:=255;
bmp.canvas.Pixels[w,h]:=RGB(rr,gg,b);
end;
end;
end;

//Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
bmptosepia(image1.picture.bitmap, 20);
end;

Resize Image 2

uses Windows, SysUtils, Graphics;

procedure ResizeImage(Src, Dst: TBitmap);
type
TRGBArray = array[Word] of TRGBTriple;
pRGBArray = ^TRGBArray;

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;
Inc(yP, yP2);
DstLine := pRGBArray(Integer(DstLine) + DstGap);
end;
end;
end;

Making Pen 2

procedure TXBitmap.XDot(x,y : integer);
begin
Dot(x,y);
makeModRect(x,y,x,y,(FXPenwidth shr 1)+2);
end;

procedure TXBitmap.Dot(x,y : integer);
//write a single dot,
//use FXpenwidth,Xcliprect,Xlevel,FXpencolor
var i,j : byte;
bitmask,pline : DWORD;
p : PDW; //PDW is pointer to DWORD
xi,yj : integer;
begin
x := x - FXpenBias;
y := y - FXpenBias;
for j := 0 to FXpenwidth-1 do
begin
bitmask := 1;
yj := y + j;
if (yj < FXcliprect.top) or (yj >= FXcliprect.bottom) then continue;
pline := FXpbase-FXlineStep*(yj); //pline points to 1st DWORD of row
for i := 0 to FXpenWidth-1 do
begin
xi := x + i;
if (xi >= FXcliprect.left) and (xi < FXcliprect.right) then
begin
p := PDW(pline + (xi) shl 2); //p points to pixel
if (FXpen[j] and bitmask) <> 0 then
if FXpenlevel <= (p^ and $3) then p^ := FXpencolor;
end;
bitmask := bitmask shl 1;
end;//for i
end;//for j
end;

Making Pen

procedure TXBitmap.setPenwidth(w : byte);
//make pen image
var i,j : byte;
h,v,r,r2 : single;
mask : DWORD;
begin
if w = FXpenwidth then exit;
if w > 32 then w := 32;
FXpenwidth := w;
FXpenBias := (w-1) shr 1;

//------- make pen image --------------------

for i := 0 to 31 do FXpen[i] := 0;//erase pen
r := w/2;
r2 := r * r;
for j := 0 to (w-1) shr 1 do // j is vertical movement over half height
begin
v := r - (0.5 + j);
for i := 0 to (w-1) shr 1 do // i is horizontal movement over half width
begin
h := r - (0.5 + i);
if h*h + v*v <= r2 then // pythagoras lemma
begin
mask := 1 shl i;
mask := mask or (1 shl (w-i-1)); // horizontal copy bit
FXpen[j] := FXpen[j] or mask; // set bits
FXpen[w-j-1] := FXpen[w-j-1] or mask; // vertical copy bits
end;//if
end;//for i
end;//for j
end;

Fill Rectangle XFillrect Method

procedure TForm1.BitBtn7Click(Sender: TObject);
//xdot fill timing
type PDW = ^DWORD;
var x,y : byte;
k : word;
p,pbase,pline : PDW;
begin
clearBM;
t1 := gettickCount;
pbase := bm.scanline[0];
for k := 1 to 10000 do
for y := 0 to 99 do
begin
pline := PDW(DWORD(pbase) - y*400);
for x := 0 to 99 do
begin
p := PDW(DWORD(pline) + (x shl 2));
p^ := $0080ff;
end;
end;
t2 := gettickcount;
showtime(100000000);
end;

Fill Rectangle Scanline Method

procedure TForm1.BitBtn6Click(Sender: TObject);
//scanline fill timing
type PDW = ^DWORD;
var i : integer;
x,y : byte;
k : word;
p,pbase : PDW;
begin
clearBM;
t1 := gettickCount;
for k := 1 to 10000 do
for y := 0 to 99 do
begin
pbase := bm.scanline[y];
for x := 0 to 99 do
begin
p := PDW(DWORD(pbase) + (x shl 2));
p^ := $ff00ff;
end;
end;
t2 := gettickcount;
showtime(100000000);
end;

Fill Rectangle Fillrect Method

procedure TForm1.BitBtn5Click(Sender: TObject);
//fillrect bm
var n : integer;
begin
with bm do with canvas do
begin
brush.style := bssolid;
brush.color := $808080;
t1 := gettickcount;
for n := 0 to 9999 do
fillrect(rect(0,0,width,height));
t2 := gettickcount;
end;
showtime(100000000);
end;

Fill Rectangle Pixel Method

procedure TForm1.BitBtn4Click(Sender: TObject);
//fill bm pixel by pixel
var x,y : byte;
k : integer;
begin
t1 := gettickcount;
with bm do with canvas do
for k := 1 to 100 do
for y := 0 to 99 do
for x := 0 to 99 do
pixels[x,y] := $ff0000;
t2 :=gettickcount;
showtime(1000000);
end;

Draw Line Xdot Method

procedure TForm1.BitBtn2Click(Sender: TObject);
//xdot line drawing
type PDW = ^DWORD;
var i : integer;
k : byte;
p,pbase : PDW;
begin
clearBM;
t1 := gettickCount;
pbase := bm.scanline[0];
for i := 1 to 1000000 do
for k := 0 to 99 do
begin
p := PDW(DWORD(pbase) + (k shl 2)- k * 400);
p^ := $0080ff;
end;
t2 := gettickcount;
showtime(100000000);
end;

Draw Line Scanline Method

procedure TForm1.BitBtn3Click(Sender: TObject);
//scanline line drawing
type PDW = ^DWORD;
var i : integer;
k : byte;
p,pbase : PDW;
begin
clearBM;
t1 := gettickCount;
for i := 1 to 10000 do
for k := 0 to 99 do
begin
pbase := bm.scanline[k];
p := PDW(DWORD(pbase) + (k shl 2));
p^ := $ff00ff;
end;
t2 := gettickcount;
showtime(1000000);
end;

Draw Line To Method

procedure TForm1.BitBtn8Click(Sender: TObject);
//lineto drawing
var i : longInt;
begin
clearBm;
t1 := gettickCount;
with bm do with canvas do
begin
pen.Color := $00ff00;
for i := 1 to 1000000 do
begin
moveto(0,0);
lineto(100,100);
end;
end;
t2 := gettickcount;
showtime(100000000);
end;

Draw Line Pixel Method

procedure TForm1.BitBtn1Click(Sender: TObject);
//pixels line drawing
//paint 1000000 pixels
var i : longInt;
k : byte;
begin
clearBm;
t1 := gettickCount;
with bm do with canvas do
for i := 1 to 10000 do
for k := 0 to 99 do pixels[k,k] := $0;
t2 := gettickcount;
showtime(1000000);
end;

Get Data Color Pixel Scanline

procedure Tform1.getdatapixel;

var

x,y : integer;

img : Pbytearray;

begin

STringgrid1.ColCount:= image1.Picture.Width;

STringgrid1.RowCount:= image1.Picture.Height;

image1.Picture.bitmap.PixelFormat:= pf24Bit;

for y := 0 to image1.Picture.Height-1 do

begin

img := image1.Picture.Bitmap.ScanLine[y];

for x := 0 to image1.Picture.Width-1 do

begin

STringgrid1.Cells[x,y] := 'R :'+IntToStr(img[3*x+2])+

'G :'+IntToStr(img[3*x+1])+

'B :'+IntToStr(img[3*x]);

end;

end;

end;

MakeShadesofGrayImage from RGB Composite Image

PROCEDURE TForm1.MakeShadesOfGrayImage;
VAR
Gray : INTEGER;
i : INTEGER;
j : INTEGER;
rowRGB : pRGBTripleArray;
rowGray: pRGBTripleArray;
BEGIN
Screen.Cursor := crHourGlass;
TRY
FOR j := BitmapRGB.Height-1 DOWNTO 0 DO
BEGIN
rowRGB := BitmapRGB.Scanline[j];
rowGray := BitmapGray.Scanline[j];
FOR i := BitmapRGB.Width-1 DOWNTO 0 DO
BEGIN
// Intensity = (R + G + B) DIV 3
WITH rowRGB[i] DO
Gray := (rgbtRed + rgbtGreen + rgbtBlue) DIV 3;

WITH rowGray[i] DO
BEGIN
rgbtRed := Gray;
rgbtGreen := Gray;
rgbtBlue := Gray
END

END
END;
FINALLY
Screen.Cursor := crDefault
END
END;

Rotate Pixel

unit ScreenPixels;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, Buttons;

type

TFormRotateBitmap = class(TForm)

ImageFrom: TImage;

ImageTo: TImage;

SpeedButton0: TSpeedButton;

SpeedButton90: TSpeedButton;

SpeedButton180: TSpeedButton;

SpeedButton270: TSpeedButton;

procedure SpeedButtonClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

FormRotateBitmap: TFormRotateBitmap;

implementation

{$R *.DFM}

procedure TFormRotateBitmap.SpeedButtonClick(Sender: TObject);

VAR

i: INTEGER;

j: INTEGER;

begin

WITH ImageFrom.Canvas.ClipRect DO

BEGIN

FOR i := Left TO Right DO

BEGIN

FOR j := Top TO Bottom DO

BEGIN

CASE (Sender AS TSpeedButton).Tag OF

0: ImageTo.Canvas.Pixels[i,j] :=

ImageFrom.Canvas.Pixels[i,j];

90: ImageTo.Canvas.Pixels[j,Right-i-1] :=

ImageFrom.Canvas.Pixels[i,j];

180: ImageTo.Canvas.Pixels[Right-i-1,Bottom-j-1] :=

ImageFrom.Canvas.Pixels[i,j];

270: ImageTo.Canvas.Pixels[Bottom-j-1,i] :=

ImageFrom.Canvas.Pixels[i,j]

END

END

END

END

end;

end.

Download Source Code

Scaline Resize Image

Ini adalah contoh source code untuk mengcopy gambar dan menjadikan ukuran gambar menjadi 2 kali ukuran gambar aslinya dengan metoda scanline

procedure TForm1.Button1Click(Sender: TObject);

type

TRGBTripleArray = ARRAY[Word] of TRGBTriple;

pRGBTripleArray = ^TRGBTripleArray; // Use a PByteArray for pf8bit color.

var

x,y : Integer;

bx, by : Integer;

BitMap, BigBitMap : TBitMap;

P, bigP : pRGBTripleArray;

pixForm, bigpixForm : TPixelFormat;

begin

BitMap := TBitMap.create;

BigBitMap := TBitMap.create;

try

BitMap.LoadFromFile('littlefac.bmp');

pixForm := BitMap.PixelFormat;

bigpixForm := BigBitMap.PixelFormat;

BitMap.PixelFormat := pf24bit;

BigBitMap.PixelFormat := pf24bit;

BigBitMap.Height := BitMap.Height * 2;

BigBitMap.Width := BitMap.Width * 2;

for y := 0 to BitMap.Height - 1 do

begin

P := BitMap.ScanLine[y];

for x := 0 to BitMap.Width - 1 do

begin

bx := x * 2;

by := y * 2;

bigP := BigBitMap.ScanLine[by];

bigP[bx] := P[x];

bigP[bx + 1] := P[x];

bigP := BigBitMap.ScanLine[by + 1];

bigP[bx] := P[x];

bigP[bx + 1] := P[x];

end;

end;

Canvas.Draw(0, 0, BitMap);

Canvas.Draw(200, 200, BigBitMap);

finally

BitMap.Free;

BigBitMap.Free;

end;

end;

Graphics To Bitmap

procedure GraphicToBitmap(const Src: Graphics.TGraphic;

const Dest: Graphics.TBitmap; const TransparentColor: Graphics.TColor);

begin

if not Assigned(Src) or not Assigned(Dest) then

Exit;

Dest.Width := Src.Width;

Dest.Height := Src.Height;

if Src.Transparent then

begin

Dest.Transparent := True;

if (TransparentColor <> Graphics.clNone) then

begin

Dest.TransparentColor := TransparentColor;

Dest.TransparentMode := Graphics.tmFixed;

Dest.Canvas.Brush.Color := TransparentColor;

end

else

Dest.TransparentMode := Graphics.tmAuto;

end;

Dest.Canvas.FillRect(Classes.Rect(0, 0, Dest.Width, Dest.Height));

Dest.Canvas.Draw(0, 0, Src);

end;

Bitmap to Metafile

Uses Graphicsh;

............................

procedure BitmapToMetafile(const Bmp: Graphics.TBitmap;

const EMF: Graphics.TMetafile);

var

MetaCanvas: Graphics.TMetafileCanvas; // canvas for drawing on metafile

begin

EMF.Height := Bmp.Height;

EMF.Width := Bmp.Width;

MetaCanvas := Graphics.TMetafileCanvas.Create(EMF, 0);

try

MetaCanvas.Draw(0, 0, Bmp);

finally

MetaCanvas.Free;

end;

end;