Decorating TImageCollection images with code - delphi

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;

Related

In Delphi, how does TBitmap.Monochrome and .PixelFormat influcence the format of .ScanLine?

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

How to get icon for hidden file (like Explorer) for ListView in Delphi?

I useSHGetFileInfo('', 0, aFileInfo, SizeOf(TSHFileInfo), SHGFI_ICON or SHGFI_SYSICONINDEX) to extract an icon list in TImageList and then associate index with TListView. Which flag I must use to get hidden style like Explorer?
To the best of my knowledge, the system does not offer such functionality. You need to create faded icons yourself, based on the original icon. You can use a function along these lines to do that:
function CreateFadedIcon(Icon: HICON): HICON;
type
TRGBA = record
B,G,R,A: Byte
end;
procedure InitialiseBitmapInfoHeader(Width, Height: Integer; var bih: BITMAPINFOHEADER);
begin
bih.biSize := SizeOf(BITMAPINFOHEADER);
bih.biWidth := Width;
bih.biHeight := 2*Height;//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
i, j: Integer;
begin
for i := 0 to sbih.biHeight-1 do begin
for j := 0 to sbih.biWidth-1 do begin
dptr^ := sptr^;
TRGBA(dptr^).A := TRGBA(dptr^).A div 3;
inc(dptr);//relies on the fact that no padding is needed for RGBA scanlines
inc(sptr);//likewise
end;
end;
end;
var
IconInfo: 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(Icon, IconInfo) then begin
exit;
end;
Try
GetDIBheaderAndBits(IconInfo.hbmColor, sbih, Pointer(sBits));
if Assigned(sBits) then begin
Try
if (sbih.biPlanes<>1) or (sbih.biBitCount<>32) then begin
exit;
end;
xorScanSize := BytesPerScanline(sbih.biWidth, 32, 32);
Assert(xorScanSize=SizeOf(DWORD)*sbih.biWidth);
andScanSize := BytesPerScanline(sbih.biWidth, 1, 32);
xorBitsSize := sbih.biHeight*xorScanSize;
andBitsSize := sbih.biHeight*andScanSize;
resbitsSize := SizeOf(BITMAPINFOHEADER) + xorBitsSize + andBitsSize;
resbits := AllocMem(resbitsSize);//AllocMem zeroises the memory
Try
dbih := resbits;
InitialiseBitmapInfoHeader(sbih.biWidth, sbih.biHeight, 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, sbih.biWidth, sbih.biHeight, LR_DEFAULTCOLOR);
Finally
FreeMem(resbits);
End;
Finally
FreeMem(sBits);
End;
end;
Finally
if IconInfo.hbmMask<>0 then begin
DeleteObject(IconInfo.hbmMask);
end;
if IconInfo.hbmColor<>0 then begin
DeleteObject(IconInfo.hbmColor);
end;
End;
Finally
DestroyIcon(Icon);
End;
end;

Combination of Canvas.TransparentColor and Canvas.Draw with Opacity

i want to draw a bitmap on a canvas with opacity where the bitmap has a transparent color.
i could create a bitmap with transparent color and draw it to a
canvas i could create a bitmap and draw it to a canvas with opacity
but i couldn't combine it. if i combine it the opacity is ignored.
here is the code i wrote:
procedure TForm1.FormPaint(Sender: TObject);
var b1,b2:TBitmap;
begin
// Example how it opacity works:
b1 := TBitmap.Create;
b1.SetSize(20,20);
b1.Canvas.Brush.Color := clBlue;
b1.Canvas.Rectangle(0,0,20,20);
Canvas.Draw(10,10,b1,$ff); // Works
Canvas.Draw(40,10,b1,$66); // Works
// I need it in combination with TransparentColor:
b2 := TBitmap.Create;
// next 3 lines are different from above
b2.Transparent := true;
b2.TransparentColor := clFuchsia;
b2.Canvas.Brush.Color := clFuchsia;
b2.SetSize(20,20);
b2.Canvas.Brush.Color := clBlue;
b2.Canvas.Ellipse(0,0,20,20);
Canvas.Draw(10,40,b2,$ff); // Works (full opacity)
Canvas.Draw(40,40,b2,$66); // Ignores the $66 Opacity
b1.Free;
b2.Free;
end;
produces:
how could i draw (f.e. a blue circle) with transparent background and just 40% opacity?
i would prefere a solution without direct winapi (like bitblt, ...) if possible.
i tried a few hacks like bitshifting a alpha channel to a TColor value but it didn't work.
here i what i tried:
procedure TForm1.FormPaint(Sender: TObject);
var b:TBitmap;
begin
b := TBitmap.Create;
b.PixelFormat := pf32bit;
b.AlphaFormat := afDefined;
b.Canvas.Brush.Color := 0 and ($ff shl 32); // Background Transperency
b.SetSize(20,20);
b.Canvas.Brush.Color := clBlue + (($ff-$66) shl 32);
b.Canvas.Ellipse(0,0,20,20);
Canvas.Draw(10,10,b);
b.Free;
end;
produces:
thanks in advance!
EDIT: my system: delphi xe 5 on windows 7 64bit (but using the 32bit compiler)
What happens can be seen in procedure TBitmap.DrawTransparent in the unit Graphics.
If the property of the image is set to transparent as show for b2 in your example the Bitmap will be drawn with
Graphics.TransparentStretchBlt which is using StretchBlt with differnt masks to draw the image and is not able to use the alpha channel.
A not tranparent Bitmap , your b1, will be draw with
AlphaBlend.
To reach your goal you might use another bitmap b2, set the Alphachannel to 0, paint b2 with opacity $66 on b3, set set the Alphachannel to 255 for every pixel which is clFuchsia in b2 and then paint this bitmap with the desired opacity
type
pRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = ARRAY [0 .. 0] OF TRGBQuad;
TRefChanel=(rcBlue,rcRed,rcGreen);
procedure SetBitmapAlpha(ABitmap: TBitMap; Alpha: Byte);
var
pscanLine32: pRGBQuadArray;
nScanLineCount, nPixelCount : Integer;
begin
with ABitmap do
begin
PixelFormat := pf32Bit;
HandleType := bmDIB;
ignorepalette := true;
alphaformat := afDefined;
for nScanLineCount := 0 to Height - 1 do
begin
pscanLine32 := Scanline[nScanLineCount];
for nPixelCount := 0 to Width - 1 do
with pscanLine32[nPixelCount] do
begin
rgbReserved := Alpha;
end;
end;
end;
end;
procedure AdaptBitmapAlpha(ABitmap,TranspBitmap:TBitmap);
var
pscanLine32,pscanLine32_2: pRGBQuadArray;
nScanLineCount, nPixelCount : Integer;
begin
with ABitmap do
begin
PixelFormat := pf32Bit;
HandleType := bmDIB;
ignorepalette := true;
alphaformat := afDefined;
for nScanLineCount := 0 to Height - 1 do
begin
pscanLine32 := Scanline[nScanLineCount];
pscanLine32_2 := TranspBitmap.Scanline[nScanLineCount];
for nPixelCount := 0 to Width - 1 do
with pscanLine32[nPixelCount] do
begin
// all picels with are not clFuchsia in the transparent bitmap
if NOT ((pscanLine32_2[nPixelCount].rgbBlue=255) AND (pscanLine32_2[nPixelCount].rgbRed=255) AND (pscanLine32_2[nPixelCount].rgbGreen=0) ) then
begin
rgbReserved := 255;
end
else
begin
rgbBlue := 0;
rgbRed := 0;
rgbGreen := 0;
end;
end;
end;
end;
end;
procedure TAForm.FormPaint(Sender: TObject);
var b1,b2,b3:TBitmap;
BF: TBlendFunction;
begin
// Example how it opacity works:
b1 := TBitmap.Create;
b1.SetSize(20,20);
b1.Canvas.Brush.Color := clBlue;
b1.Canvas.Rectangle(0,0,20,20);
Canvas.Draw(10,10,b1,$ff); // Works
Canvas.Draw(40,10,b1,$66); // Works
// I need it in combination with TransparentColor:
b3 := TBitmap.Create;
b3.PixelFormat := pf32Bit;
b2 := TBitmap.Create;
b2.PixelFormat := pf32Bit;
// next 3 lines are different from above
b2.Transparent := true;
b2.TransparentColor := clFuchsia;
b2.Canvas.Brush.Color := clFuchsia;
b2.SetSize(20,20);
b2.Canvas.Brush.Color := clBlue;
b2.Canvas.Ellipse(0,0,20,20);
Canvas.Draw(10,40,b2,$ff); // Works (full opacity)
b3.SetSize(20,20);
SetBitmapAlpha(b3,0);
b3.Canvas.Draw(0,0,b2,$66);
AdaptBitmapAlpha(b3,b2);
Canvas.Draw(40,40,b3,$66);
b1.Free;
b2.Free;
b3.Free;
end;
thanks to bummi (accepted answer)!
i put his solution in a class helper. here is the code if anybody need it:
unit uBitmapHelper;
interface
uses
Vcl.Graphics;
type
TBitmapHelper = class Helper for TBitmap
private
type
TRgbaRec = packed record
r,g,b,a:Byte;
end;
PRgbaRec = ^TRgbaRec;
PRgbaRecArray = ^TRgbaRecArray;
TRgbaRecArray = array [0 .. 0] of TRgbaRec;
public
procedure TransparentMaskedDraw(ACanvas:TCanvas;AX:Integer;AY:Integer;AMask:TColor;AOpacity:Byte);
end;
implementation
{ TBitmapHelper }
procedure TBitmapHelper.TransparentMaskedDraw(ACanvas:TCanvas;AX,AY:Integer;AMask:TColor;AOpacity:Byte);
var i,j:Integer;
line1,line2:PRgbaRecArray;
mask:PRgbaRec;
tmp:TBitmap;
begin
mask := #AMask;
tmp := TBitmap.Create;
tmp.SetSize(self.Width,self.Height);
tmp.PixelFormat := pf32Bit;
tmp.HandleType := bmDIB;
tmp.IgnorePalette := true;
tmp.AlphaFormat := afDefined;
for i := 0 to tmp.Height - 1 do begin
line1 := tmp.Scanline[i];
for j := 0 to tmp.Width - 1 do begin
line1[j].a := 0;
end;
end;
tmp.Canvas.Draw(0,0,self,AOpacity);
for i := 0 to tmp.Height - 1 do begin
line1 := tmp.ScanLine[i];
line2 := self.ScanLine[i];
for j := 0 to tmp.Width - 1 do begin
if not((line2[j].r = mask.r) and (line2[j].g = mask.g) and (line2[j].b = mask.b)) then begin
line1[j].a := $ff;
end else begin
line1[j].r := 0;
line1[j].g := 0;
line1[j].b := 0;
end;
end;
end;
ACanvas.Draw(AX,AY,tmp,AOpacity);
tmp.Free;
end;
end.
The oldest answer is fine, please find some easy reshuffle.
This example also shows how to put one png-image with opacity on another by respecting the transparency.
procedure TForm2.FormCreate(Sender: TObject);
//define your own transparent color by setting RGB-values
const cTransR=255; cTransG=255; cTransB=255;
clTrans= $10000*cTransB + $100*cTransG + cTransR;
var bmp1,bmp2:TBitmap;
pngTemp: TPngImage;
I:integer;
procedure SetAlphaTransparent(VAR LBitmap:TBitmap);
type TRGBQuadArray = ARRAY [0..0] OF TRGBQuad;
var I, J: integer;
LscanLine32:^TRGBQuadArray;
begin
// I found no other way than scanning pixel by pixel to recover default opacity
for I := 0 to LBitmap.Height - 1 do begin
LscanLine32:=LBitmap.ScanLine[I];
for J := 0 to LBitmap.Width - 1 do
with LscanLine32[J] do
if NOT((rgbRed=cTransR)AND(rgbGreen=cTransG)AND(rgbBlue=cTransB)) then
rgbReserved := 255; // make pixel visible, since transparent is default
end;
end;
Procedure SetAlphaProperty(Var LBitmap:TBitmap; LWidth, LHeight:integer);
begin
// You will need a different format Bitmap to allow alpha values
LBitmap.PixelFormat := pf32Bit;
LBitmap.HandleType := bmDIB;
LBitmap.alphaformat := afDefined;
LBitmap.Canvas.Brush.Color := clTrans;
LBitmap.SetSize(LWidth,LHeight);
end;
begin
// create any background on your Form, by placing IMG:Timage on the From
pngTemp := TPngImage.Create;
pngTemp.LoadFromFile( GetCurrentDir()+'\figure1.png' );
IMG.Canvas.Draw((IMG.Width-pngTemp.Width) div 2, // fit png into the center
(IMG.Height-pngTemp.Height) div 2,pngTemp);
pngTemp.Free;
// First example how it opacity works with transparency
bmp1 := TBitmap.Create;
SetAlphaProperty(bmp1,35,35);
// a circle has a surrouding area, to make transparent
bmp1.Canvas.Brush.Color := clBlue;
bmp1.Canvas.Ellipse(5,5,30,30);
SetAlphaTransparent(bmp1);
// show some circles with different opacity
for I := 0 to 7 do
IMG.Canvas.Draw(I*40-30,10,bmp1,(8-I)*32);
bmp1.Free;
// Another example using a different png-file
bmp2 := TBitmap.Create;
SetAlphaProperty(bmp2,Img.Width,Img.Height);
// load a transparent png-file and put it into the alpha bitmap:
pngTemp := TPngImage.Create;
pngTemp.LoadFromFile( GetCurrentDir()+'\figure2.png' );
pngTemp.Transparent := true;
bmp2.Canvas.Draw((bmp2.Width-pngTemp.Width) div 2,// fit png into the center
(bmp2.Height-pngTemp.Height) div 2,pngTemp);
pngTemp.Free;
// draw the second image with transparancy and opacity onto the first one
SetAlphaTransparent(bmp2);
IMG.Canvas.Draw(0,0,bmp2,$66);
bmp2.Free;
end;

How to add an icon to the ImageList bigger-sized without stretching?

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;

Paint PNG image on other PNG

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;

Resources