How to merge two PNG's together? I know that you can't use PNGObject.Draw because it doesn't copy alpha transaperncy (I am not sure but it doesn't work anyway) so custom procedure/function is needed. I didn't come with empty hands, I have this procedure:
procedure MergePNGLayer(Layer1,Layer2: TPNGObject; Const aLeft,aTop:Integer);
var
x, y: Integer;
SL1, SL2, SLBlended : pRGBLine;
aSL1, aSL2, aSLBlended: PByteArray;
blendCoeff: single;
blendedPNG, Lay2buff: TPNGObject;
begin
blendedPNG:=TPNGObject.Create;
blendedPNG.Assign(Layer1);
Lay2buff:=TPNGObject.Create;
Lay2buff.Assign(Layer2);
SetPNGCanvasSize(Layer2,Layer1.Width,Layer1.Height,aLeft,aTop);
for y := 0 to Layer1.Height-1 do
begin
SL1 := Layer1.Scanline[y];
SL2 := Layer2.Scanline[y];
aSL1 := Layer1.AlphaScanline[y];
aSL2 := Layer2.AlphaScanline[y];
SLBlended := blendedPNG.Scanline[y];
aSLBlended := blendedPNG.AlphaScanline[y];
for x := 0 to Layer1.Width-1 do
begin
blendCoeff:=aSL1[x] * 100/255/100;
aSLBlended[x] := round(aSL2[x] + (aSL1[x]-aSL2[x]) * blendCoeff);
SLBlended[x].rgbtRed := round(SL2[x].rgbtRed + (SL1[x].rgbtRed-SL2[x].rgbtRed) * blendCoeff);
SLBlended[x].rgbtGreen := round(SL2[x].rgbtGreen + (SL1[x].rgbtGreen-SL2[x].rgbtGreen) * blendCoeff);
SLBlended[x].rgbtBlue := round(SL2[x].rgbtBlue + (SL1[x].rgbtBlue-SL2[x].rgbtBlue) * blendCoeff);
end;
end;
Layer1.Assign(blendedPNG);
Layer2.Assign(Lay2buff);
blendedPNG.Free;
Lay2buff.Free;
end;
But sadly it doesn't work how it should, it does the job but not right. When it merges empty image with loaded image, it works fine, but when both images aren't empty, it makes them loss transparancy.
procedure TForm1.FormClick(Sender: TObject);
var
PNG1, PNG2, PNG3, Dest: TPNGObject;
begin
PNG1 := TPNGObject.Create;
PNG2 := TPNGObject.Create;
PNG3 := TPNGObject.Create;
PNG1.LoadFromFile('Aero\TopLeft.png');//Width 10
PNG2.LoadFromFile('Aero\Top.png');//Width 200
PNG3.LoadFromFile('Aero\TopRight.png');//Width 10
Dest := TPNGObject.CreateBlank(COLOR_RGBALPHA, 16, 220, 10);
MergePNGLayer(Dest, PNG1, 0, 0);
MergePNGLayer(Dest, PNG2, 10, 0);
MergePNGLayer(Dest, PNG3, 210, 0);
Dest.SaveToFile('C:\OUT.PNG');
end;
Wanted result:
Actual result:
I am not sure if you can see differences between these imgaes, but you should open these in PNG editor software and you will see the difference. So I need other procedure to merge PNGs. I am using newest version of PNGImage by the way.
Thanks and have a good day!
This seems to work just fine:
procedure DrawPngWithAlpha(Src, Dest: TPNGObject; const R: TRect);
var
X, Y: Integer;
Alpha: PByte;
begin
Src.Draw(Dest.Canvas, R);
// I have no idea why standard implementation of TPNGObject.Draw doesn't apply transparency.
for Y := R.Top to R.Bottom - 1 do
for X := R.Left to R.Right - 1 do
begin
Alpha := #Dest.AlphaScanline[Y]^[X];
Alpha^ := Min(255, Alpha^ + Src.AlphaScanline[Y - R.Top]^[X - R.Left]);
end;
end;
Related
For testing purposes, in my Delphi 10.3 application, I'd like to decorate images in a TImageCollection with the dimensions of each image. For bitmaps, it's no problem but for PNG files, I can't paint to that canvas, neither can I assign from a BMP to a PNG in TWICImage because of a runtime exception "cannot assign a TPngImage to a TWICImage".
procedure DecorateImageCollection(imcMainMisc: TImageCollection);
var
i, j: Integer;
bmp:Graphics.TBitmap;
item:TImageCollectionItem;
img:TImageCollectionSourceItem;
begin
for i := 0 to imcMainMisc.Count - 1 do
begin
item:=imcMainMisc.Images.Items[i];
for j := 0 to item.SourceImages.Count - 1 do
begin
img:=item.SourceImages.Items[j];
case img.Image.ImageFormat of
wifBmp:
;
wifPng:
begin
bmp:=Graphics.TBitmap.Create;
try
bmp.Assign(img.Image);
bmp.Canvas.Font.Name:='Small Fonts';
bmp.Canvas.Font.Size:=6;
bmp.Canvas.Font.Color:=clRed;
bmp.Canvas.Brush.Style:=bsClear;
bmp.Canvas.Pen.Style:=psSolid;
bmp.Canvas.TextOut(0, 0, IntToStr(bmp.Height));
// *cannot assign a TPngImage to a TWICImage*
img.Image.Assign(bmp);
finally
bmp.Free;
end;
end;
wifJpeg:
;
wifGif:
;
wifTiff:
;
wifWMPhoto:
;
wifOther:
;
end;
end;
end;
end;
I expect such an operation should be simple but I haven't yet found out how.
Thank you!
The solution I ended up using was deleting the PNG source item, adding a new source item and using LoadFromStream( ).
procedure DecorateImageCollection(imc: TImageCollection);
var
i, j, x, y: Integer;
r:TRect;
rSize:TSize;
sTag:string;
bmp:TBitmap;
png:TPngImage;
item:TImageCollectionItem;
str:TMemoryStream;
img, icsiNew:TImageCollectionSourceItem;
Alpha: PByte;
begin
for i := 0 to imc.Count - 1 do
begin
item:=imc.Images.Items[i];
for j := item.SourceImages.Count - 1 downto 0 do
begin
img:=item.SourceImages.Items[j];
case img.Image.ImageFormat of
wifBmp:
begin
bmp:=TBitmap.Create;
try
bmp.Assign(img.Image);
sTag:=IntToStr(bmp.Height);
bmp.Canvas.Font.Name:='Small Fonts';
bmp.Canvas.Font.Size:=6;
rSize:=bmp.Canvas.TextExtent(sTag);
r.Top:=0;
r.Left:=0;
r.Width:=rSize.Width;
r.Height:=rSize.Height;
bmp.Canvas.Brush.Color:=clWhite;
bmp.Canvas.Brush.Style:=bsSolid;
bmp.Canvas.Font.Color:=clRed;
bmp.Canvas.Pen.Style:=psSolid;
bmp.Canvas.TextOut(r.Left, r.Top, sTag);
img.Image.Assign(bmp);
finally
bmp.Free;
end;
end;
wifPng:
begin
png:=TPngImage.Create;
str:=TMemoryStream.Create;
try
img.Image.SaveToStream(str);
str.Position:=0;
png.LoadFromStream(str);
sTag:=IntToStr(png.Height);
png.Canvas.Font.Name:='Small Fonts';
png.Canvas.Font.Size:=6;
rSize:=png.Canvas.TextExtent(sTag);
r.Top:=0;
r.Left:=0;
r.Width:=rSize.Width;
r.Height:=rSize.Height;
// knock out transparency in that area
for Y := r.Top to r.Bottom - 1 do
for X := r.Left to r.Right - 1 do
begin
Alpha := #png.AlphaScanline[Y]^[X];
Alpha^ := 255; // opaque
end;
png.Canvas.Brush.Color:=clWhite;
png.Canvas.Brush.Style:=bsSolid;
png.Canvas.Font.Color:=clRed;
png.Canvas.Pen.Style:=psSolid;
png.Canvas.TextOut(r.Left, r.Top, sTag);
str.Clear;
png.SaveToStream(str);
item.SourceImages.Delete(j);
icsiNew:=item.SourceImages.Add;
str.Position:=0;
icsiNew.Image.LoadFromStream(str);
finally
png.Free;
str.Free;
end;
end;
wifJpeg:
;
wifGif:
;
wifTiff:
;
wifWMPhoto:
;
wifOther:
;
end;
end;
end;
end;
I want to assign a given buffer with a bitmap in Mono8 format (Monochrome 8 Bits) to a bitmap. I then assign the resulting bitmap to a TImage component to display it. The pictures are screenshots of the resulting display.
The following code works but seems a bit wasteful:
procedure CopyToBitmapMono824(_Buffer: PByte; _Bmp: TBitmap);
var
y: Integer;
x: Integer;
ScanLine: PdzRgbTripleArray;
begin
for y := 0 to _Bmp.Height - 1 do begin
ScanLine := _Bmp.ScanLine[y];
for x := 0 to _Bmp.Width - 1 do begin
// monochrome: all 3 colors set to the same value
ScanLine[x].Red := _Buffer^;
ScanLine[x].Green := _Buffer^;
ScanLine[x].Blue := _Buffer^;
Inc(_Buffer);
end;
end;
end;
// [...]
fBmp.PixelFormat := pf24Bit;
FBmp.Monochrome := False;
CopyToBitmap(Buffer, fBmp);
I would rather use a bitmap in pf8Bit format which I tried:
procedure CopyToBitmapMono8(_Buffer: PByte; _Bmp: TBitmap);
var
y: Integer;
x: Integer;
ScanLine: PByteArray;
begin
for y := 0 to _Bmp.Height - 1 do begin
ScanLine := _Bmp.ScanLine[y];
for x := 0 to _Bmp.Width - 1 do begin
ScanLine[x] := _Buffer^;
Inc(_Buffer);
end;
end;
end;
// [...]
FBmp.PixelFormat := pf8bit;
FBmp.Monochrome := False; // I also tried Monochrome := true
CopyToBitmapMono8(Buffer, FBmp)
If MonoChrome is true, the picture only has about 1/4 of the expected width, the rest is white.
If MonoChrome is false, the picture has the expected width, but the left 1/4 of it is monochrome, the rest contains false colors.
I'm obviously missing something, but what?
EDIT: The effect that the bitmap is only 1/4 of the expected size apparently was a side effect of converting it to a JPEG for saving prior to displaying it (code that I did not show above, mea culpa). So the problem was simply that I did not set a monochrome palette for the bitmap.
Monochrome has sense for pf1bit bitmaps.
Otherwise Monochrome := True changes bitmap format to DDB (pfDevice). Your screen is 32-bit, so call to Scanline caused DibNeeded call and transformation to 32bit, and using of function CopyToBitmapMono8 (intended for 8-bit) filled only 1/4 of screen.
For proper usage of 8-bit bitmaps you have to change standard weird palette (used in the right part of last image) to gray one.
procedure CopyToBitmapMono8(_Buffer: PByte; _Bmp: TBitmap);
var
y: Integer;
x: Integer;
ScanLine: PByteArray;
begin
for y := 0 to _Bmp.Height - 1 do begin
ScanLine := _Bmp.ScanLine[y];
for x := 0 to _Bmp.Width - 1 do begin
ScanLine[x] := _Buffer^;
Inc(_Buffer);
end;
end;
end;
var
FBmp: TBitmap;
Buffer: PbyteArray;
i: integer;
begin
GetMem(Buffer, 512 * 100);
for i := 0 to 512 * 100 - 1 do
Buffer[i] := (i and 511) div 2; // gray gradient
FBmp := Tbitmap.Create;
FBmp.Width := 512;
FBmp.Height := 100;
FBmp.PixelFormat := pf8bit;
CopyToBitmapMono8(PByte(Buffer), FBmp);
Canvas.Draw(0, 0, FBmp);
//now right approach
FBmp.Palette := MakeGrayPalette; // try to comment
CopyToBitmapMono8(PByte(Buffer), FBmp);
Canvas.Draw(0, 110, FBmp);
end;
function TForm1.MakeGrayPalette: HPalette;
var
i: integer;
lp: TMaxLogPalette;
begin
lp.palVersion := $300;
lp.palNumEntries := 256;
for i := 0 TO 255 do begin
lp.palPalEntry[i].peRed := i;
lp.palPalEntry[i].peGreen := i;
lp.palPalEntry[i].peBlue := i;
lp.palPalEntry[i].peFlags := PC_RESERVED;
end;
Result := CreatePalette(pLogPalette(#lp)^);
end;
And example at efg2 page
I have an image list containing several bitmaps which I would like to save together as one single bitmap, but I need it saving just like how a spritesheet or tilesheet is drawn in 2d and rpg games etc.
Typically the tilesheet is drawn with several images across (in a row), so for example if I wanted a maximum of 6 images per row, it will only draw 6, with further images been drawn underneath in a new row.
I can save it in one single row like so:
var
CurrentFrame: Integer;
StripWidth: Integer;
Strip: TBitmap;
Bmp: TBitmap;
I: Integer;
begin
if SaveDialog.Execute then
begin
StripWidth := ImageList1.Width * ImageList1.Count - ImageList1.Width;
CurrentFrame := - ImageList1.Width;
Strip := TBitmap.Create;
try
Strip.SetSize(StripWidth, ImageList1.Height);
Bmp := TBitmap.Create;
try
for I := 0 to ImageList1.Count - 1 do
begin
CurrentFrame := CurrentFrame + ImageList1.Width;
ImageList1.GetImage(I, Bmp);
Strip.Canvas.Draw(CurrentFrame, 0, Bmp);
end;
finally
Bmp.Free;
end;
Strip.SaveToFile(SaveDialog.FileName);
finally
Strip.Free;
end;
end;
end;
So imagine the result for the above is:
The result I want is something like:
So the above would have considered in the procedure/ function a parameter to allow only 3 images per row as an example.
How do I export all images from an imagelist into one single bitmap, allowing only x amount if images to be drawn horizontally before creating a new row?
Thanks.
EDIT
Thanks to David's answer, I put together these procedures:
procedure DrawImageOnSheet(Images: TImageList; Sheet: TBitmap;
ImageIndex, X, Y: Integer);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Images.GetBitmap(ImageIndex, Bitmap);
Sheet.Canvas.Draw(X, Y, Bitmap);
finally
Bitmap.Free;
end;
end;
procedure SaveImageListAsSheet(Images: TImageList; FileName: string;
NumberOfColumns: Integer);
var
Sheet: TBitmap;
nImage: Integer;
nCol: Integer;
nRow: Integer;
nToDraw: Integer;
nRemaining: Integer;
ImageIndex: Integer;
X, Y: Integer;
I: Integer;
begin
Sheet := TBitmap.Create;
try
nImage := Images.Count;
nCol := NumberOfColumns;
nRow := (nImage + nCol - 1) div nCol;
Sheet.Height := nRow * Images.Height;
Sheet.Width := nCol * Images.Width;
nRemaining := nImage;
ImageIndex := 0;
Y := 0;
while nRemaining > 0 do
begin
nToDraw := Math.Min(nRemaining, nCol);
X := 0;
for I := 0 to nToDraw - 1 do
begin
DrawImageOnSheet(Images, Sheet, ImageIndex, X, Y);
Inc(ImageIndex);
Inc(X, Images.Width);
end;
Inc(Y, Images.Height);
Dec(nRemaining, nToDraw);
end;
Sheet.SaveToFile(FileName);
finally
Sheet.Free;
end;
end;
According to clarification from the comments, you are struggling with the counting of the images, the organisation of the rows/columns and so on. So, let's assume you already have this function which draws image ImageIndex to the output bitmap at a position of X, Y.
procedure Draw(ImageIndex, X, Y: Integer);
Let's also assume that the images have dimensions given by ImageWidth and ImageHeight. Finally, there are nImage images and you want to have nCol images per column.
So, first of all, how many rows do you need?
nRow := (nImage + nCol - 1) div nCol;
Now you can set the size of the output bitmap. Its width is nCol * ImageWidth and its height is nRow * ImageHeight.
Now to draw the images.
nRemaining := nImage;
ImageIndex := 0;
Y := 0;
while nRemaining > 0 do
begin
nToDraw := Math.Min(nRemaining, nCol);
X := 0;
for i := 0 to nToDraw - 1 do
begin
Draw(ImageIndex, X, Y);
inc(ImageIndex);
inc(X, ImageWidth);
end;
inc(Y, ImageHeight);
dec(nRemaining, nToDraw);
end;
I have ImageList sized 72x72, handle to the icon (HICON), obtained by SHGetFileInfo (for example a large icon sized 32x32). How to add it to this ImageList keeping transparency, but without stretching? Now I draw the icon in the middle of a temporary bitmap desired size, then add it to the ImageList.
SHGetFileInfo(PChar(Path + sr.Name), sr.FindData.dwFileAttributes, fi, SizeOf(fi), SHGFI_ICON or SHGFI_LARGEICON or SHGFI_USEFILEATTRIBUTES);
Bmp:=TBitmap.Create;
Bmp.PixelFormat:=pf32bit;
Bmp.SetSize(72, 72);
DrawIcon(Bmp.Canvas.Handle, 20, 20, fi.hIcon);
iIcon:=ImageList_AddMasked(ilThumbs.Handle, Bmp.Handle, 0);
Bmp.Free;
But I think a way faster exists (without drawing on temporary bitmap). Also image in ImageList loses transparency and when I set index of this Image in ImageList for ListView item.ImageIndex it looks not pretty (when this item is selected, white background around is present). Is any way to solve this problem?
Thanks.
This is the code that I use to perform this task.
Note that I am assuming that the original icon uses 32 bit colour, with alpha channel. That's reasonable in the settings that I use this code, but I can't be sure whether or not it's reasonable for you.
uses
Windows, Graphics;
function CreateIconFromSmallerIcon(IconSize: Integer; SmallerIcon: HICON): HICON;
procedure GetDIBheaderAndBits(bmp: HBITMAP; out bih: BITMAPINFOHEADER; out bits: Pointer);
var
pbih: ^BITMAPINFOHEADER;
bihSize, bitsSize: DWORD;
begin
bits := nil;
GetDIBSizes(bmp, bihSize, bitsSize);
pbih := AllocMem(bihSize);
Try
bits := AllocMem(bitsSize);
GetDIB(bmp, 0, pbih^, bits^);
if pbih.biSize<SizeOf(bih) then begin
FreeMem(bits);
bits := nil;
exit;
end;
bih := pbih^;
Finally
FreeMem(pbih);
End;
end;
procedure InitialiseBitmapInfoHeader(var bih: BITMAPINFOHEADER);
begin
bih.biSize := SizeOf(BITMAPINFOHEADER);
bih.biWidth := IconSize;
bih.biHeight := 2*IconSize;//height of xor bitmap plus height of and bitmap
bih.biPlanes := 1;
bih.biBitCount := 32;
bih.biCompression := BI_RGB;
end;
procedure CreateXORbitmap(const sbih, dbih: BITMAPINFOHEADER; sptr, dptr: PDWORD);
var
line, xOffset, yOffset: Integer;
begin
xOffset := (IconSize-sbih.biWidth) div 2;
yOffset := (IconSize-sbih.biHeight) div 2;
inc(dptr, xOffset + IconSize*yOffset);
for line := 0 to sbih.biHeight-1 do begin
Move(sptr^, dptr^, sbih.biWidth*SizeOf(DWORD));
inc(dptr, IconSize);//relies on the fact that no padding is needed for RGBA scanlines
inc(sptr, sbih.biWidth);//likewise
end;
end;
var
SmallerIconInfo: TIconInfo;
sBits, xorBits: PDWORD;
xorScanSize, andScanSize: Integer;
xorBitsSize, andBitsSize: Integer;
sbih: BITMAPINFOHEADER;
dbih: ^BITMAPINFOHEADER;
resbitsSize: DWORD;
resbits: Pointer;
begin
Result := 0;
Try
if not GetIconInfo(SmallerIcon, SmallerIconInfo) then begin
exit;
end;
Try
GetDIBheaderAndBits(SmallerIconInfo.hbmColor, sbih, Pointer(sBits));
if Assigned(sBits) then begin
Try
if (sbih.biWidth>IconSize) or (sbih.biHeight>IconSize) or (sbih.biPlanes<>1) or (sbih.biBitCount<>32) then begin
exit;
end;
xorScanSize := BytesPerScanline(IconSize, 32, 32);
Assert(xorScanSize=SizeOf(DWORD)*IconSize);
andScanSize := BytesPerScanline(IconSize, 1, 32);
xorBitsSize := IconSize*xorScanSize;
andBitsSize := IconSize*andScanSize;
resbitsSize := SizeOf(BITMAPINFOHEADER) + xorBitsSize + andBitsSize;
resbits := AllocMem(resbitsSize);//AllocMem zeroises the memory
Try
dbih := resbits;
InitialiseBitmapInfoHeader(dbih^);
xorBits := resbits;
inc(PByte(xorBits), SizeOf(BITMAPINFOHEADER));
CreateXORbitmap(sbih, dbih^, sBits, xorBits);
//don't need to fill in the mask bitmap when using RGBA
Result := CreateIconFromResourceEx(resbits, resbitsSize, True, $00030000, IconSize, IconSize, LR_DEFAULTCOLOR);
Finally
FreeMem(resbits);
End;
Finally
FreeMem(sBits);
End;
end;
Finally
if SmallerIconInfo.hbmMask<>0 then begin
DeleteObject(SmallerIconInfo.hbmMask);
end;
if SmallerIconInfo.hbmColor<>0 then begin
DeleteObject(SmallerIconInfo.hbmColor);
end;
End;
Finally
DestroyIcon(SmallerIcon);
End;
end;
Ok, my solution below:
procedure SetAlpha(Bitmap: TBitmap);
type
PPixelRec = ^TPixelRec;
TPixelRec = packed record
B, G, R, Alpha: Byte;
end;
var
X, Y: Integer;
Pixel: PPixelRec;
begin
for Y := 0 to (Bitmap.Height - 1) do
begin
Pixel := Bitmap.ScanLine[Y];
for X := 0 to (Bitmap.Width - 1) do
begin
Pixel.Alpha:=255;
Inc(Pixel);
end;
end;
end;
//skipped
var Bmp: TBitmap;
fi: TSHFileInfo;
ImageList1: TImageList;
begin
ImageList1:=TImageList.CreateSize(72, 72);
ImageList1.DrawingStyle:=dsTransparent;
ImageList1.ColorDepth:=cd32Bit;
SHGetFileInfo('c:\Windows\notepad.exe', FILE_ATTRIBUTE_NORMAL, fi, SizeOf(fi), SHGFI_ICON or SHGFI_LARGEICON or SHGFI_USEFILEATTRIBUTES);
Bmp:=TBitmap.Create;
Bmp.SetSize(72, 72);
SetAlpha(Bmp);
Bmp.Canvas.Brush.Color:=clWhite;
Bmp.Canvas.FillRect(Rect(0, 0, 72, 72));
DrawIcon(Bmp.Canvas.Handle, 20, 20, fi.hIcon);
fi.iIcon:=ImageList1.Add(Bmp, nil);
ImageList1.Draw(Canvas, 0, 0, fi.iIcon); //just to see that's alright
end;
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 :-).