Can't get how to draw PNG properly via GraphicEx in Delphi - image

I have a little problem with PNG format. To read and display PNG files I use GraphicEx library by Mike Lischke (got it there). All was good before I decided to draw PNG file with transparent background.
I use this code to load and draw PNG on form's canvas:
procedure TForm1.aButton1Click(Sender: TObject);
var
PNGGraph: GraphicEx.TPNGGraphic;
begin
PNGGraph := GraphicEx.TPNGGraphic.Create;
PNGGraph.PixelFormat := pf32bit; - added code line
PNGGraph.LoadFromFile('demo.png');
Form1.Canvas.Draw(10, 10, PNGGraph);
PNGGraph.Free;
end;
What I get you can see on a picture below:
After hours searching in Internet, I found that I should multiple alpha channel. I get some code from here (Mike Sutton's answer): Fade in an alpha-blended PNG form in Delphi
procedure PreMultiplyBitmap(Bitmap: TBitmap);
var
Row, Col: integer;
p: PRGBQuad;
PreMult: array[byte, byte] of byte;
begin
// precalculate all possible values of a*b
for Row := 0 to 255 do
for Col := Row to 255 do
begin
PreMult[Row, Col] := Row*Col div 255;
if (Row <> Col) then
PreMult[Col, Row] := PreMult[Row, Col]; // a*b = b*a
end;
for Row := 0 to Bitmap.Height-1 do
begin
Col := Bitmap.Width;
p := Bitmap.ScanLine[Row];
while (Col > 0) do
begin
p.rgbBlue := PreMult[p.rgbReserved, p.rgbBlue];
p.rgbGreen := PreMult[p.rgbReserved, p.rgbGreen];
p.rgbRed := PreMult[p.rgbReserved, p.rgbRed];
inc(p);
dec(Col);
end;
end;
end;
Using this code I got a little odd result:
The picture above has black background and in the same time looks almost as an original image.
On a picture below you can see an original PNGimage:
So, my question is: how to draw PNG file correctly with transparency and without black background?
I looked into GraphicEx's units, but can't get enough info about my question. Can't believe that such serious graphic library as GraphicEx is not able to draw PNG files without any troubles.
P.S.
Bitmap property Transparent doesn't work properly - black background still on a picture.
Thanks to everyone who can give me advice!
EDIT
When I set PixelFormat = pf32bit, it makes bitmap 'broken' visually.
Picture below demonstrates this effect:

The problem is that Mike's PNG graphic doesn't support drawing transparency.
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
g: TGraphic;
begin
g := TPNGGraphic.Create;
g.LoadFromFile('D:\Temp\FolderOpen_48x48_72.png');
PaintBox1.Canvas.Draw(0, 0, g);
end;
Comes out without the alpha channel being taken into account:
TPNGObject
For Delphi 2005 use can use Gustavo Daud's pngdelphi library (It is the class that was later absorbed into Delphi). It fully supported drawing with alpha blending:
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
g: TGraphic;
begin
// g := TPNGGraphic.Create;
g := TPNGObject.Create;
g.LoadFromFile('D:\Temp\FolderOpen_48x48_72.png');
PaintBox1.Canvas.Draw(0, 0, g);
end;
It draws correctly:
Windows Imaging Component
I don't know when Borland added Windows Imaging Component (WIC) to Delphi. But in Delphi 5 i translated the headers myself, and created a TGraphic that uses WIC to perform all the work: TWicGraphic:
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
g: TGraphic;
begin
// g := TPNGGraphic.Create;
// g := TPNGObject.Create;
g := TWicGraphic.Create;
g.LoadFromFile('D:\Temp\FolderOpen_48x48_72.png');
PaintBox1.Canvas.Draw(0, 0, g);
end;
It also paints correctly:
GDI+
There's also GDI+. I also don't know when Borland added support for GDI+ to Delphi. But in Delphi 5 i translated GDI+ myself and created a TGraphic that uses GDI+ for all the work, TGDIPlusGraphic:
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
g: TGraphic;
begin
// g := TPNGGraphic.Create;
// g := TPNGObject.Create;
// g := TWicGraphic.Create;
g := TGDIPlusGraphic.Create;
g.LoadFromFile('D:\Temp\FolderOpen_48x48_72.png');
PaintBox1.Canvas.Draw(0, 0, g);
end;
it also draws correctly:
But to answer your question: You cannot. Not without re-writing Mike's TPNGGraphic to support the alpha channel.

Related

Change background color of TListView header in older Delphi

An old app using Delphi 7, but should be similar code in older Delphi versions up to perhaps 2010. I need to change the background color of a TListView header so I can offer a dark theme. I can change the colors of everything else. I found the thread below which apparently works for changing the font color on a column header, but I need to adjust the background color of the entire header as well.
Delphi: ListView (vsReport) single column header caption with custom font color?
Can someone please help as I am lost. Windows message notifications are beyond my comprehension.
Many thanks.
I'm fairly proud of myself and somehow found bits and pieces of code that all went together to make it all work. Something like this...
procedure TTntListView.WMNotify(var AMessage: TWMNotify);
const
DT_ALIGN: array[TAlignment] of integer = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
NMCustomDraw: TNMCustomDraw;
i: Integer;
r: TRect;
begin
if (AMessage.NMHdr.hwndFrom = FHeaderHandle) and
(AMessage.NMHdr.code = NM_CUSTOMDRAW) then
begin
NMCustomDraw := PNMCustomDraw(TMessage(AMessage).LParam)^;
case NMCustomDraw.dwDrawStage of
CDDS_PREPAINT: AMessage.Result := CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT: begin
i := NMCustomDraw.dwItemSpec;
r := NMCustomDraw.rc;
FillRect(NMCustomDraw.hdc, r, Sender.Canvas.Brush.Handle);
SetBkColor(NMCustomDraw.hdc, ColorToRGB(Sender.Canvas.Brush.Color));
SetTextColor(NMCustomDraw.hdc, ColorToRGB(Sender.Canvas.Font.Color));
DrawEdge(NMCustomDraw.hdc,r,EDGE_SUNKEN,BF_LEFT);
Inc(r.Left,2);
Dec(r.Right,2);
if Sender.Column[i].Alignment = taLeftJustify then Inc(r.Left,3)
else Dec(r.Right,3);
DrawTextW(NMCustomDraw.hdc,
pWideChar(Sender.Column[i].Caption),
length(Sender.Column[i].Caption),
r,
DT_SINGLELINE or DT_ALIGN[Sender.Column[i].Alignment] or
DT_VCENTER or DT_END_ELLIPSIS);
Message.Result := CDRF_SKIPDEFAULT;
end;
else AMessage.Result := CDRF_DODEFAULT;
end;
end
else inherited;
end;

Can a TEdit show color emoji?

I'd like to see emojis in color in a TEdit or TMemo control using VCL and Delphi 10+.
Can it be done?
Text entered:
πŸ‘¨πŸΌβ€πŸŽ€πŸ‘©πŸΎβ€πŸ‘©πŸΌβ€πŸ‘§πŸ»β€πŸ‘¦πŸΏ
What I see:
What I'd like to see:
Your question made me curious, so tried and here is the result:
Drawing colored fonts in general
Apparently FMX supports this out of the box in later versions, but not in Seattle, which I happen to have. I don't know if the VCL also supports it out of the box in your version, but if not, you can achieve using Direct2D. The trick is to draw text using the D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT option.
In Seattle (10), this constant is not defined, and - unfortunately - not used in the default TCanvas-compatible functions. But you can call DrawText or one of the other functions yourself and specify the option.
The general structure is based on this Embarcadero docwiki. The rest is peeked from TDirect2DCanvas, combined with the DrawText documentation.
uses Vcl.Direct2D, Winapi.D2D1;
{$R *.dfm}
procedure TForm1.FormPaint(Sender: TObject);
const
str: string = 'xyzπŸ‘¨πŸΌβ€πŸŽ€πŸ‘©πŸΎβ€πŸ‘©πŸΌβ€πŸ‘§πŸ»β€πŸ‘¦πŸΏ';
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = 4;
var
c: TDirect2DCanvas;
r: D2D_RECT_F;
begin
c := TDirect2DCanvas.Create(Canvas.Handle, Rect(0, 0, 100, 100));
c.BeginDraw;
try
r.left := 0;
r.top := 0;
r.right := 100;
r.bottom := 50;
// Brush determines the font color.
c.Brush.Color := clBlack;
c.RenderTarget.DrawText(
PWideChar(str), Length(Str), c.Font.Handle, r, c.Brush.Handle,
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);
finally
c.EndDraw;
c.Free;
end;
end;
This little piece of code works in a fairly ugly way (in terms of positioning the text), but you can also peek in TDirect2DCanvas, and copy the implementation of one of its text methods to create a function for outputting text in a specific way that you want. And after that it should be fairly easy to apply this to your own TGraphicControl or TCustomControl descendant to create an emoji-supporting label.
Doing that in TEdit
To manage this in TEdit is harder, since drawing the text (and the emoji) is handled by the control itself. It should be possible to create a TEdit descendant and/or hook into its WM_PAINT message and paint over the text using this same trick, but I'm not sure how well that would work.
I gave that a quick shot, but it doesn't really work well perfectly, especially when editing. So I've made this descendant of TEdit. When focused, it draws the text in a normal way, and the colored emoji will be black and white, and split into two characters (the emoji and the color combination character). When the edit loses its focus, the custom paint code takes over, which works well in that scenario. Maybe you can attempt to polish it to make it work while editing as well, but then you have to take scrolling, positioning the caret and other stuff into account. For a TMemo descendant that would be even harder. I hope you're happy with just colored display for now. :-)
type
TMyEdit = class(Vcl.StdCtrls.TEdit)
protected
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
end;
implementation
uses Vcl.Direct2D, Winapi.D2D1;
{$R *.dfm}
const
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = 4;
constructor TMyEdit.Create(AOwner: TComponent);
begin
inherited;
DoubleBuffered := True;
end;
procedure TMyEdit.PaintWindow(DC: HDC);
var
c: TDirect2DCanvas;
r: D2D_RECT_F;
begin
// Default drawing when focused. Otherwise do the custom draw.
if Focused then
begin
Inherited;
Exit;
end;
c := TDirect2DCanvas.Create(dc, ClientRect);
c.BeginDraw;
try
r.left := ClientRect.Left;
r.top := ClientRect.Top;
r.right := ClientRect.Right;
r.bottom := ClientRect.Bottom;
// Basic font properties
c.Font.Assign(Font);
// Brush determines the font color.
c.Brush.Color := Font.Color;
c.RenderTarget.DrawText(
PWideChar(Text), Length(Text), c.Font.Handle, r, c.Brush.Handle,
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);
finally
c.EndDraw;
c.Free;
end;
end;

Why doesn't OpenGL correctly display the image I loaded?

I have two images, both are 24 color .bmp 32x32 pixels. If I load one with OpenGL it works, if I load the other with OpenGL it just shows black and white lines.
Is there something else that could be different, thus not letting one of the images show?
This one does not work in code:
This one does work in code:
Also checked info size and file header size. Both images were 40 on info and 14 on file size. Both images biWidth and BiHeight were still 32x32.
This shows how I texture a hex with the image grass
//GRASS
glTexImage2d(GL_TEXTURE_2D,Level,Colorcomps,sGrass,tGrass,Border,GL_RGB,GL_UNSIGNED_BYTE,grass);
glLoadName(1);
glBegin(GL_POLYGON);
for I := 0 to 6 do
begin
glTexCoord2f(COS(i/6.0*2*PI),SIN(i/6.0*2*pi));
glVertex3f((((COS(i/6.0*2*PI)/12)+offsetx)+0.2),((SIN(i/6.0*2*pi)/12)+offsety),-2);
end;
glEnd;
grass is a pointer and filled like so:
grass := Readbitmap('Grass.bmp',sGrass,tGrass);
And how do I get the image data (which should be OK as it works with other images, I really think its something else about an image that would make the two different)?
Function TFCreateMap.ReadBitmap(const FilePath:String;var sWidth,tHeight:GLsizei):pointer;
const
szh=SizeOf(TBitmapFileHeader);
szi=SizeOf(TBitmapInfoHeader);
var
bmpfile: file;
bfh:TBitmapFileHeader;
bmi:TBitmapInfoHeader;
t:byte;
x,
fpos,
size: integer;
begin
assignfile(bmpfile,FilePath);
reset(bmpfile,1);
size := FileSize(bmpfile)-szh-szi;
blockread(bmpfile,bfh,szh);
if bfh.bfType<>$4D42 then
raise EinvalidGraphic.Create('Invalid Bitmap');
blockread(bmpfile,bmi,szi);
with bmi do
begin
sWidth := biWidth;
tHeight := biHeight;
end;
getmem(result,size);
blockread(bmpfile,result^,size);
for x := 0 to sWidth*tHeight-1 do
with TWrap(result^)[x] do
begin
t := r;
r := b;
b := t;
end;
end;
Your bitmaps differ at least in bit depth. The one which fails you to load is 8-bit, whilst the working one is 24-bit. What you need is to convert your 8-bit bitmap to 24-bit (because of the used format parameter value in your glTexImage2D function call).
Code review:
I've made a review of your code and here's the result; the following code uses file stream for reading the file (since I'm not a fan of the old style I/O routines; anyway you forgot on file closing), removes the color channel rotation part which was, as #Rob pointed wrong (for the reason mentioned below). I've added a check for the necessary bit depth value (which must be 24-bit with the format flag you will use for the glTexImage2D function call):
function TFCreateMap.ReadBitmap(const AFilePath: string; var AWidth,
AHeight: GLsizei): Pointer;
var
DataSize: Integer;
FileStream: TFileStream;
FileHeader: TBitmapFileHeader;
InfoHeader: TBitmapInfoHeader;
const
FileTypeBitmap = $4D42;
FileHeaderSize = SizeOf(TBitmapFileHeader);
InfoHeaderSize = SizeOf(TBitmapInfoHeader);
begin
Result := nil;
FileStream := TFileStream.Create(AFilePath, fmOpenRead);
try
FileStream.ReadBuffer(FileHeader, FileHeaderSize);
if (FileHeader.bfType <> FileTypeBitmap) then
raise EinvalidGraphic.Create('Invalid file type!');
FileStream.ReadBuffer(InfoHeader, InfoHeaderSize);
if (InfoHeader.biBitCount <> 24) then
raise EinvalidGraphic.Create('Invalid bit depth!');
DataSize := FileStream.Size - FileHeaderSize - InfoHeaderSize;
GetMem(Result, DataSize);
FileStream.ReadBuffer(Result^, DataSize);
AWidth := InfoHeader.biWidth;
AHeight := InfoHeader.biHeight;
finally
FileStream.Free;
end;
end;
Now to the reason, why I removed the color channel rotation; I have almost no experience with OpenGL, but something tells me, that GL_BGR value of the format parameter of the glTexImage2D function might simplify this part, because I'd say that the function then expects the BGR pixel array for its data parameter and that's how your bitmaps are stored. So my guess is that you can leave the color channel rotation and call the glTexImage2D function with GL_BGR value of the format parameter:
glTexImage2D(GL_TEXTURE_2D, Level, Colorcomps, sGrass, tGrass, Border, GL_BGR,
GL_UNSIGNED_BYTE, grass);
...
First image has index color format, but second image have RGB. You can try to change color format using GIMP or other editor.

How do I load icons from a resource without suffering from aliasing?

I have a GUI application which includes a number of icons used for toolbar buttons, menu glyphs, notification icons etc. These icons are linked to the application as resources and a variety of different sizes are available. Typically, for toolbar button images I have available 16px, 24px and 32px versions. My icons are 32bpp with partial transparency.
The application is high DPI aware and adjusts the size of all visual elements according to the prevailing font scaling. So, for example, at 100% font scaling, 96dpi, the toolbar icon size is 16px. At 125% scaling, 120dpi, the toolbar icon size is 20px. I need to be able to load an icon of size 20px without any aliasing effects. How can I do this? Note that I would like to support Windows 2000 and later.
On Vista and up a number of new functions were added that make this task trivial. The function that is most appropriate here is LoadIconWithScaleDown.
This function will first search the icon file for an icon having exactly the same size. If a match is not found, then unless both cx and cy match one of the standard icon sizesβ€”16, 32, 48, or 256 pixelsβ€” the next largest icon is selected and then scaled down to the desired size. For example, if an icon with an x dimension of 40 pixels is requested by the callign application, the 48-pixel icon is used and scaled down to 40 pixels. In contrast, the LoadImage function selects the 32-pixel icon and scales it up to 40 pixels.
If the function is unable to locate a larger icon, it defaults to the standard behavior of finding the next smallest icon and scaling it up to the desired size.
In my experience this function does an excellent job of scaling and the results show no signs of aliasing.
For earlier versions of Windows there is, to the very best of my knowledge, no single function that can perform this task adequately. The results obtained from LoadImage are of very poor quality. Instead the best approach I have found is as follows:
Examine the available images in the resource to find the image with the largest size that is less than desired icon size.
Create a new icon of the desired size and initialise it to be fully transparent.
Place the smaller icon from the resource in the centre of the new (larger) icon.
This means that there will be a small transparent border around the icon, but typically this is small enough to be insignificant. The ideal option would be to use code that could scale down just as LoadIconWithScaleDown does, but that is non-trivial to write.
So, without further ado here is the code I use.
unit uLoadIconResource;
interface
uses
SysUtils, Math, Classes, Windows, Graphics, CommCtrl;
function LoadIconResourceSize(const ResourceName: string; IconSize: Integer): HICON;//will not throw an exception
function LoadIconResourceMetric(const ResourceName: string; IconMetric: Integer): HICON;
implementation
function IconSizeFromMetric(IconMetric: Integer): Integer;
begin
case IconMetric of
ICON_SMALL:
Result := GetSystemMetrics(SM_CXSMICON);
ICON_BIG:
Result := GetSystemMetrics(SM_CXICON);
else
raise EAssertionFailed.Create('Invalid IconMetric');
end;
end;
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;
function CreateIconFromSmallerIcon(IconSize: Integer; SmallerIcon: HICON): HICON;
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;
function LoadIconResourceSize(const ResourceName: string; IconSize: Integer): HICON;//will not throw an exception
function LoadImage(IconSize: Integer): HICON;
begin
Result := Windows.LoadImage(HInstance, PChar(ResourceName), IMAGE_ICON, IconSize, IconSize, LR_DEFAULTCOLOR);
end;
type
TGrpIconDir = packed record
idReserved: Word;
idType: Word;
idCount: Word;
end;
TGrpIconDirEntry = packed record
bWidth: Byte;
bHeight: Byte;
bColorCount: Byte;
bReserved: Byte;
wPlanes: Word;
wBitCount: Word;
dwBytesInRes: DWORD;
wID: WORD;
end;
var
i, BestAvailableIconSize, ThisSize: Integer;
ResourceNameWide: WideString;
Stream: TResourceStream;
IconDir: TGrpIconDir;
IconDirEntry: TGrpIconDirEntry;
begin
//LoadIconWithScaleDown does high quality scaling and so we simply use it if it's available
ResourceNameWide := ResourceName;
if Succeeded(LoadIconWithScaleDown(HInstance, PWideChar(ResourceNameWide), IconSize, IconSize, Result)) then begin
exit;
end;
//XP: find the closest sized smaller icon and draw without stretching onto the centre of a canvas of the right size
Try
Stream := TResourceStream.Create(HInstance, ResourceName, RT_GROUP_ICON);
Try
Stream.Read(IconDir, SizeOf(IconDir));
Assert(IconDir.idCount>0);
BestAvailableIconSize := high(BestAvailableIconSize);
for i := 0 to IconDir.idCount-1 do begin
Stream.Read(IconDirEntry, SizeOf(IconDirEntry));
Assert(IconDirEntry.bWidth=IconDirEntry.bHeight);
ThisSize := IconDirEntry.bHeight;
if ThisSize=0 then begin//indicates a 256px icon
continue;
end;
if ThisSize=IconSize then begin
//a perfect match, no need to continue
Result := LoadImage(IconSize);
exit;
end else if ThisSize<IconSize then begin
//we're looking for the closest sized smaller icon
if BestAvailableIconSize<IconSize then begin
//we've already found one smaller
BestAvailableIconSize := Max(ThisSize, BestAvailableIconSize);
end else begin
//this is the first one that is smaller
BestAvailableIconSize := ThisSize;
end;
end;
end;
if BestAvailableIconSize<IconSize then begin
Result := CreateIconFromSmallerIcon(IconSize, LoadImage(BestAvailableIconSize));
if Result<>0 then begin
exit;
end;
end;
Finally
FreeAndNil(Stream);
End;
Except
;//swallow because this routine is contracted not to throw exceptions
End;
//final fallback: make do without
Result := 0;
end;
function LoadIconResourceMetric(const ResourceName: string; IconMetric: Integer): HICON;
begin
Result := LoadIconResourceSize(ResourceName, IconSizeFromMetric(IconMetric));
end;
end.
Using these function is quite obvious. They assume that the resource is located in the same module as the code. The code could readily be generalised to receive an HMODULE in case you needed support for that level of generality.
Call LoadIconResourceMetric if you wish to load icons of size equal to the system small icon or system large icon. The IconMetric parameter should be either ICON_SMALL or ICON_BIG. For toolbars, menus and notification icons, ICON_SMALL should be used.
If you wish to specify the icon size in absolute terms use LoadIconResourceSize.
These functions return an HICON. You can of course assign this to the Handle property of a TIcon instance. More likely you will wish to add to an image list. The easiest way to do this is to call ImageList_AddIcon passing the Handle of the TImageList instance.
Note 1: Older versions of Delphi do not have LoadIconWithScaleDown defined in CommCtrl. For such Delphi versions you need to call GetProcAddress to load it. Note that this is a Unicode only API and so you must send it a PWideChar for the resource name. Like this: LoadIconWithScaleDown(..., PWideChar(WideString(ResourceName)),...).
Note 2: The definition of LoadIconWithScaleDown is flawed. If you call it after the common controls library has been initialised then you will have no problems. However, if you call the function early on in the life of your process then LoadIconWithScaleDown can fail. I have just submitted QC#101000 to report this problem. Again, if you are afflicted by this then you have to call GetProcAddress yourself.

How to save a png file with transparency?

I am using Barcode Studio 2011 to paint a QR Code into a Graphics32 - TImage32 Component and I want to save it in png format but with the white colour as transparent this I have specified in the OuterColor of Graphics32.
OnFormCreate I have just
procedure TForm1.FormCreate(Sender: TObject);
begin
psBarcodeComponent1.BarCode := 'some text here...';
end;
and for the moment I have the painting assigned to a Button Click Event
procedure TForm1.Button8Click(Sender: TObject); // Paint the barcode
var
bmp: TBitmap32;
Coords: TRect;
begin
bmp := TBitmap32.Create;
bmp.SetSize(image.Width, image.Height);
bmp.Canvas.Brush.Color := color;
bmp.Canvas.Rectangle(-1, -1, image.Width+2, image.Height+2);
bmp.DrawMode := dmTransparent;
bmp.OuterColor := clWhite;
// make Coords the size of image
Coords := Rect(0,0,image.Width,image.Height);
psBarcodeComponent1.PaintBarCode(bmp.Canvas, Coords);
image.Bitmap.Assign(bmp);
end;
I am using the Vampyre Imaging Library to convert the Bitmap into PNG Format but I will gladly use any library, function, and advice - I have been trying to do this now for nearly a week! I have read through and re-read the documentation of graphics32 and also of the Vampyre Imaging Library but nothing I try will convert the white to a transparent colour. I have tried clWhite, clWhite32 and also setting the drawMode to dmBlend and applying the ChromaKey Function all to no avail but plenty frustration, coffee and a little beer also ;)
This is how I am saving it...
procedure TForm1.Button7Click(Sender: TObject); // Save with Vampyre Imaging Lib
{ Try to save in PNG format with transparancy }
var
FImage: TSingleImage;
begin
FImage := TSingleImage.Create;
ConvertBitmap32ToImage(image.Bitmap, FImage);
FImage.SaveToFile('VampyreLibIMG.png');
end;
This results in a Black coloured thumbnail and when viewed in Windows Photo Viewer it is completely transparent.
I hope that I have provided enough information and that someone is able to help me.
Chris
You haven't specified the Delphi version, but if your delphi version has "PngImage"(I believe it comes with D2009+) the code bellow works perfectly(loaded in Gimp and Windows Photo Viewer, it draws a frame and some text with transparent background, feel free to play with it:
uses
PngImage;
procedure TForm1.OnBtnClick(Sender: TObject);
var
bmp: TBitmap;
png: TPngImage;
begin
bmp := TBitmap.Create;
bmp.Width := 200;
bmp.Height := 200;
bmp.Canvas.Brush.Color := clBlack;
bmp.Canvas.Rectangle( 20, 20, 160, 160 );
bmp.Canvas.Brush.Style := bsClear;
bmp.Canvas.Rectangle(1, 1, 199, 199);
bmp.Canvas.Brush.Color := clWhite;
bmp.Canvas.Pen.Color := clRed;
bmp.Canvas.TextOut( 35, 20, 'Hello transparent world');
bmp.TransparentColor := clWhite;
bmp.Transparent := True;
png := TPngImage.Create;
png.Assign( bmp );
png.SaveToFile( 'C:\test.png' );
bmp.Free;
png.Free;
end;
This approach works for me:
uses GR32, GR32_PNG, GR32_PortableNetworkGraphic;
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
function IsWhite(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 255) and
(TColor32Entry(Color32).G = 255) and
(TColor32Entry(Color32).R = 255);
end;
begin
with Image321 do
begin
Bitmap.ResetAlpha;
for Y := 0 to Bitmap.Height-1 do
for X := 0 to Bitmap.Width-1 do
begin
if IsWhite(Bitmap.Pixel[X, Y]) then
Bitmap.Pixel[X,Y]:=Color32(255,255,255,0);
end;
Png:= TPortableNetworkGraphic32.Create;
Png.Assign(Bitmap);
Png.SaveToFile('C:\Temp\NowTransparent.png');
Png.Free;
end;
end;
This uses the GR32 PNG library. It's a pretty direct way, setting all white pixels to transparent.
PS: Image321 is a TImage32 component, containing my TBitmap32.

Resources