My application allows users to create text objects on a canvas. This object can be saved to a project file to be loaded later.
In order that the objects look the same after loading on various platforms I have implemented the text object as a path. This also allows users to use downloaded fonts and then open the project file on a different device without that font - without the text changing appearance.
The path is created using TTextLayout.ConvertToPath and drawn using TCanvas.FillPath. This works fine for most fonts, but has an issue with some others.
The image below shows the result (top) with the Bahnschrift font. Bottom shows how it should look using MS Paint. This font seems to have intersecting paths and I think the issue is that FillPath is using an alternate fill mode, which doesn't seem to be an option to change.
I have also tested the same font in Inkscape as an SVG by creating the text and converting it to a path, but it's drawn correctly. The path data created by Delphi and Inkscape are essentially the same (the t consists of 2 closed regions that cross each other), so it's the way they're drawn that must be different.
Can anyone suggest a fix for this?
Here's the code
procedure TMainForm.Button1Click(Sender: TObject);
Var
LPath : TPathData;
LLayout : TTextLayout;
begin
LLayout := TTextLayoutManager.DefaultTextLayout.Create;
LLayout.Text := 'test';
LLayout.Font.Family := 'Bahnschrift';
LPath := TPathData.Create;
LLayout.ConvertToPath(LPath);
// Draw the path to a bitmap
SavePathBitmap(LPath, 'Path_test');
LLayout.Free;
LPath.Free;
end;
procedure TMainForm.SavePathBitmap(APath : TPathData ; AFileName : String);
var
bmp : TBitmap;
rect : TRectF;
begin
APath.Scale(10, 10); // Enlarge
rect := APath.GetBounds;
APath.Translate(-rect.Left + 5, -rect.Top + 5); // offset onto bitmap
bmp := TBitmap.Create(Trunc(rect.Width)+10, Trunc(rect.Height)+10);
with bmp.Canvas do if BeginScene then begin
Clear(TAlphaColorRec.White);
Fill.Color := TAlphaColorRec.Black;
FillPath(APath, 1);
EndScene;
bmp.SaveToFile(AFileName + '.png');
end;
bmp.Free;
end;
Related
I don't know what to do here anymore, so I hope that somebody can help me.
I'm using Delphi 10.4 and Windows 10.
Basically, my problem is that cutting a part of the .png image with transparent background is to slow. I use scanline.
I have one background image (back.bmp) that is drawn on the form. That image can be also a .png (with no transparency) if that can help to solve this.
From the second image (frontsigns.bmp) I cat different parts and need to draw them to that background.
Old version of this program used .bmp as second image (with no transparent background) so that was very fast.
procedure TfrmMain.btnDrawBMPClick(Sender: TObject);
var
frontsigns : TBitmap;
begin
frontsigns := TBitmap.Create;
frontsigns.LoadFromFile('E:\frontsigns.bmp');
frmMain.Canvas.CopyRect(Rect(0,0,302,869), frontsigns.Canvas, Rect(0, yStartPos, 302, yEndPos)); // yStartPos and yEndPos are variables
end;
This draw part of the second image (303x870 px) on the background in the 0.415 ms. That is OK (probably can't be faster).
Now I need to use a second image with transparent backgrounds, so I use .png. Because I cut and draw different parts of the second image on the background my idea is that I use temp background image and draw part of the .png on that temp image and after that I draw it on the form.
Here is the code.
procedure TfrmMain.btnDrawBMPClick(Sender: TObject);
var
background, tmpbackground : TBitmap;
frontsigns, CroppedPng : TPngImage;
begin
background := TBitmap.Create;
background.LoadFromFile('E:\back.bmp');
frontsigns := TPngImage.Create;
frontsigns.LoadFromFile('E:\frontsigns.png');
tmpbackground := TBitmap.Create(303, 870);
tmpbackground.Canvas.CopyRect(Rect(0, 0, 302, 869), background.Canvas, Rect(0, 0, 302, 869));
CropPng(frontsigns, 0, yStartPos, 302, yEndPos, CroppedPng); // yStartPos and yEndPos are variables
tmpbackground.Canvas.Draw(0, 0, CroppedPng);
end;
This draw part of the second image (303x870 px) on the background in the 13.5 ms!!!!!!!
Reason is slow scanline I think. I should write here that frontsigns.png has only fully transparent background. There are not any semi-transparent pixels.
Here is my code for cropping .png images.
const
ColorTabMax = 10;
ColorTab : array[0..ColorTabMax-1] of TColor =
(ClBlack, ClMaroon, ClRed, ClWebDarkOrange, ClYellow, ClGreen, ClBlue, ClPurple, ClGray, ClWhite);
procedure CropPng(Source: TPngImage; Left, Top, Width, Height: Integer; out Target : TPngImage);
function ColorToTriple(Color: TColor): TRGBTriple;
begin
Color := ColorToRGB(Color);
Result.rgbtBlue := Color shr 16 and $FF;
Result.rgbtGreen := Color shr 8 and $FF;
Result.rgbtRed := Color and $FF;
end;
var
X, Y : Integer;
Bitmap : TBitmap;
BitmapLine : PRGBLine;
AlphaLineA, AlphaLineB : pngImage.PByteArray;
begin
if (Source.Width < (Left + Width)) or (Source.Height < (Top + Height)) then
raise Exception.Create('Invalid position/size');
Bitmap := TBitmap.Create;
try
Bitmap.Width := Width;
Bitmap.Height := Height;
Bitmap.PixelFormat := pf24bit;
for Y := 0 to Bitmap.Height - 1 do
begin
BitmapLine := Bitmap.Scanline[Y];
for X := 0 to Bitmap.Width - 1 do
BitmapLine^[X] := ColorToTriple(Source.Pixels[Left + X, Top + Y]);
end;
Target := TPngImage.Create;
Target.Assign(Bitmap);
if Source.Header.ColorType in [COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA] then
begin
Target.CreateAlpha;
for Y := 0 to Target.Height - 1 do
begin
AlphaLineA := Source.AlphaScanline[Top + Y];
AlphaLineB := Target.AlphaScanline[Y];
for X := 0 to Target.Width - 1 do
AlphaLineB^[X] := AlphaLineA^[X + Left];
end;
end;
finally
Bitmap.Free;
end;
end;
I'm open for any ideas here. Can I make scanline works fatser? I don't have semi-transparent pixels so maybe I don't need to do all this.
I've tried with 32bit .bmp images with alpha channel, but haven't made it work with alphablend function.
I'me even open for third party libraries if there is no otehr option.
Thanks.....
In library PngComponents unit PngFunctions offers procedure SlicePNG, which allows to split a TPngImage into separate parts of equal size. As this has to be done only once it may significantly reduce the drawing time.
The problem with your approach is that you are reading your source image by accessing individual pixels using Source.Pixels and not using ScanLine
BitmapLine^[X] := ColorToTriple(Source.Pixels[Left + X, Top + Y]);
If you want to benefit properly by using ScanLine make sure you use ScanLine for both source and target images.
Also since your source and target images are both TPngImage you probably don't even need to create the temporary TBitmap.
And if color palettes of your PNG's match then you don't even need to do any color decoding/encoding but instead just copy data directly from one image to another. Of course you do need to make sure that color palette in your PNG's match each other in advance.
I remember reading about a tool that modifies a PNG's palette information to match with other files some years ago. Unfortunately I don't remember its name. I do remember reading about it in an article about creating of PNG based image atlases for games.
Here is my current progress thank you to the SilverWariors answer. I've just implemented first tip for now.
I was using information from:
https://delphi.cjcsoft.net/viewthread.php?tid=48996
https://en.wikipedia.org/wiki/BMP_file_format
I've replaced:
BitmapLine^[X] := ColorToTriple(Source.Pixels[Left + X, Top + Y]);
with:
BitmapLine^[X] := GetPixel(source, Left + X, Top + Y);
GetPixel function is bellow.
function GetPixel(Source: TPngImage; X, Y: Integer): TRGBTriple;
var
LineSource : pngImage.PByteArray;
begin
LineSource := Source.Scanline[y];
// Get blue value - stored in lowest order byte in a TColor
Result.rgbtBlue := PByteArray(LineSource)^[(x*3)+0];
// Get Green value - second lowest byte in TColor
Result.rgbtGreen := PByteArray(LineSource)^[(x*3)+1];
// Get Red value - third lowest byte in TColor
Result.rgbtRed := PByteArray(LineSource)^[(x*3)+2];
end;
I'm not sure why the color order is like this and not like in the article on the link above. Maybe because .png file is 32bit.
With this change I've decreased time from 13.5 ms to 6.44 ms. That is great, but I think it can be even much better.
Here is where is I see potential improvement.
Now I scan every line two times. One for the RGB colors and one for for ALPA information.
AlphaLineA := Source.AlphaScanline[Top + Y];
I think that I can get ALPHA info from scanline if I scanline returns all four bytes in a 32bit image. I'm I correct?
Maybe something like:
PByteArray(LineSource)^[(x*3)+3];
Another idea is that I can directly write to the final background. Now I cut part of the .png image and draw it on the background at the end. I must use draw because transparency that .png image that I got as result of croping original image will be lost if I use CopyRect.
But If I draw pixels directly to the background (that has ALPHA 255) that would be much faster. Maybe I can avoid that because the background is 32bit .bmp (it can be 32bit .png) without any transparency (ALPHA is 255 for all bits). Also ALPHA for .png that I'm cutting of can be only 255 (not transparent) and 0 (fully transparent).
I'm not sure how I can accomplish this.
I want to load a picture (32 bit-depth, transparent) from a TImageList to an TImage. The standard approach would be ImageList.GetBitmap(Index, Image.Picture.Bitmap);. However the GetBitmap method doesn't work with transparency, so I always get a non-transparent bitmap.
The workaround is rather simple - ImageList offers another method, GetIcon, which works OK with transparency. Code to load a transparent Image would be:
ImageList.GetIcon(Index, Image.Picture.Icon);
And don't forget to set proper ImageList properties:
ImageList.ColorDepth:=cd32bit;
ImageList.DrawingStyle:=dsTransparent;
I too have had various issues with passing in images from the a tImageList. So I have a simple wrapper routine that generally does the job and it enforces the transparency. The code below is Delphi 2005 and imlActiveView is the tImageList component that has my set of button glyph images.
procedure TfrmForm.LoadBitmap (Number : integer; bmp : tBitMap);
var
ActiveBitmap : TBitMap;
begin
ActiveBitmap := TBitMap.Create;
try
imlActiveView.GetBitmap (Number, ActiveBitmap);
bmp.Transparent := true;
bmp.Height := ActiveBitmap.Height;
bmp.Width := ActiveBitmap.Width;
bmp.Canvas.Draw (0, 0, ActiveBitmap);
finally
ActiveBitmap.Free;
end
end;
Here is an example of use where the 5th imlActiveView image is passed into the btnNavigate.Glyph.
LoadBitmap (5, btnNavigate.Glyph)
In this question I asked about the correct use of the CopyRect method. I got an answer which fixed my problem, but now the colors of the copied rectangle are wrong (limited to 256 values?).
This is the code:
var
Bmp: TBitmap;
begin
Image1.Picture.LoadFromFile(SomeJPGimage);
Bmp := TBitmap.Create;
try
Bmp.Assign(Image1.Picture.Graphic);
with Bmp do
Image2.Canvas.CopyRect(Image2.Canvas.ClipRect, Canvas, Canvas.ClipRect);
finally
Bmp.Free;
end;
end;
The inset with the false colors is Image2. The colors are right if I don't resize.
How do I get the 24 bit color of the source image (a JPG) when resizing?
edit
Draw is not an alternative; I want to copy a scaled version of part of the source image.
This is not caused because of color reduction, or a wrong pixelformat etc.. You're probably shrinking the image while copying and 'StretchBlt' compresses the image to fit in, and depending on the mode, produces some artifacts. For instance the below 128x128 image
is displayed exactly the same if no resizing is applied. However if it is applied on a 90x100 image for instance, the output is .
You can change the stretching mode for a slightly better result:
var
Bmp: TBitmap;
begin
Image1.Picture.LoadFromFile(SomeJPGimage);
Bmp := TBitmap.Create;
try
Bmp.Assign(Image1.Picture.Graphic);
SetStretchBltMode(Image2.Canvas.Handle, HALFTONE); // <- here
with Bmp do
Image2.Canvas.CopyRect(Image2.Canvas.ClipRect, Canvas, Canvas.ClipRect);
finally
Bmp.Free;
end;
end;
For the above source picture the output now becomes:
(Having browsed a little 'graphics.pas', the VCL seems to be using halftone only for 8-bit images. I may be wrong or right in this assessment, but in any case halftone stretching mode has no such constraint.)
For anything better, I believe, you have to use a proper graphics library.
Edited again:
Turns out the issue is going against the WRONG canvas (too easy with TImage if you're not used to it). Tried to save files on my last sample and got a huge file on the one I assigned. So I Started looking into some of the other values and found that you need to work against the Bitmap Canvas...
var
BMP: TBitmap;
MyClipRect: TRect;
begin
if OpenDialog1.Execute then
begin
Image1.Picture.LoadFromFile(OpenDialog1.FileName);
Bmp := TBitmap.Create;
try
Bmp.Assign(Image1.Picture.Graphic);
myClipRect.Left := (Bmp.Width div 2);
myClipRect.Top := (Bmp.Height div 2);
myClipRect.Right := (Bmp.Width);
myClipRect.Bottom := (Bmp.Height);
with Image2.Picture.Bitmap do
begin
Width := Bmp.Width div 2;
Height := Bmp.Height div 2;
Canvas.CopyRect(Canvas.ClipRect, Bmp.Canvas, MyClipRect);
end;
Image2.Picture.SaveToFile('image2.bmp');
finally
Bmp.Free;
end;
end;
end;
Hope that finally got it. Yeesh.
I've spended hours for this (simple) one and don't find a solution :/
I'm using D7 and the TImageList. The ImageList is assigned to a toolbar.
When I populate the ImageList at designtime, the icons (with partial transparency) are looking fine.
But I need to populate it at runtime, and when I do this the icons are looking pretty shitty - complete loose of the partial transparency.
I just tried to load the icons from a .res file - with the same result.
I've tried third party image lists also without success.
I have no clue what I could do :/
Thanks 2 all ;)
edit:
To be honest I dont know exactly whats going on. Alpha blending is the correkt term...
Here are 2 screenies:
Icon added at designtime:
(source: shs-it.de)
Icon added at runtime:
(source: shs-it.de)
Your comment that alpha blending is not supported just brought the solution:
I've edited the image in an editor and removed the "alpha blended" pixels - and now it looks fine.
But its still strange that the icons look other when added at runtime instead of designtime. If you (or somebody else ;) can explain it, I would be happy ;)
thanks for you support!
To support alpha transparency, you need to create the image list and populate it at runtime:
function AddIconFromResource(ImageList: TImageList; ResID: Integer): Integer;
var
Icon: TIcon;
begin
Icon := TIcon.Create;
try
Icon.LoadFromResourceID(HInstance, ResID);
Result := ImageList.AddIcon(Icon);
finally
Icon.Free;
end;
end;
function AddPngFromResource(ImageList: TImageList; ResID: Integer): Integer;
var
Png: TPngGraphic;
ResStream: TStream;
Bitmap: TBitmap;
begin
ResStream := nil;
Png := nil;
Bitmap := nil;
try
ResStream := TResourceStream.CreateFromID(HInstance, ResID, RT_RCDATA);
Png := TPNGGraphic.Create;
Png.LoadFromStream(ResStream);
FreeAndNil(ResStream);
Bitmap := TBitmap.Create;
Bitmap.Assign(Png);
FreeAndNil(Png);
Result := ImageList.Add(Bitmap, nil);
finally
Bitmap.Free;
ResStream.Free;
Png.Free;
end;
end;
// this could be e.g. in the form's or datamodule's OnCreate event
begin
// create the imagelist
ImageList := TImageList.Create(Self);
ImageList.Name := 'ImageList';
ImageList.DrawingStyle := dsTransparent;
ImageList.Handle := ImageList_Create(ImageList.Width, ImageList.Height, ILC_COLOR32 or ILC_MASK, 0, ImageList.AllocBy);
// populate the imagelist with png images from resources
AddPngFromResource(ImageList, ...);
// or icons
AddIconFromResource(ImageList, ...);
end;
I had the exact same problems a couple of years ago. It's a Delphi problem. I ended up putting the images in the list at design time, even though I really didn't want to. I also had to use a DevExpress image list to get the best results and to use 32 bit color images.
As Jeremy said this is indeed a Delphi limitation.
One work around I've used for images that I was putting onto buttons (PNGs with alpha transparency in my case) is to store the PNGs as resources, and at run time paint them onto a button sized bitmap filled with clBtnFace. The bitmap was then used as the control's glyph.
Delphi's built in support for icons with alpha masks is very limited, however there's an excellent icon library kicon which may help.
Here is my problem, I want to know actual length of the text in pixels (note that various letters have different length in some fonts). I am going to use this for better column width adjustment in DBGrid.
You can use the Canvas.TextWidth and Canvas.TextHeight functions.
Option 1, using the canvas of the control
WidthInPixels := Label1.Canvas.TextWidth('My Text');
Option 2, creating a temporary canvas (using a Tbitmap)
Function GetWidthText(const Text:String; Font:TFont) : Integer;
var
LBmp: TBitmap;
begin
LBmp := TBitmap.Create;
try
LBmp.Canvas.Font := Font;
Result := LBmp.Canvas.TextWidth(Text);
finally
LBmp.Free;
end;
end;
if you have a Delphi component has a "Canvas" property, then you can use Component.Canvas.TextWidth. For example: to get the width of the text of DBGrid you can use:
DBGrid1.Canvas.TextWidth('Stack');
Here you can find complete reference about this issue:
Length of Delphi string in pixels