I am using Windows 10, Delphi 7. Trying to make Pdf document with SynPDF using it's canvas directly. I need to draw in the rectangle only that part of the text that corresponds to the length of the rectangle, the rest cut off. I am using DrawText (and DrawTextEx) functions to write text in the given rectangle with alignment (TA_LEFT, TA_RIGHT, TA_CENTER).
The problem: these functions draw the text, but do not take into account the given boundaries - they do not clip(crop) this text.
var
R: TRect;
s: String;
begin
R:= Rect(50, 50, 120, 75);
Canvas.Brush.Color:=clYellow;
Canvas.Rectangle(R);
Canvas.Font.Name:='Arial';
Canvas.Font.Size:=10;
Canvas.Font.Style:=[];
Canvas.Brush.Style:= bsClear;
s:='Sample for text clipping';
DrawText(Canvas.Handle, PChar(s), -1, R, TA_LEFT or
{DT_END_ELLIPSIS or }DT_VCENTER or DT_SINGLELINE);
end;
If I add DT_END_ELLIPSIS it works correctly but adds three dots - I do not need dots. What I am doing wrong? Or I need to use other functions for my task?
Unfortunately, I'm not allowed (by StackOverflow) to add a photo with the result...
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.
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;
I am trying to make a kind of bitmap editor so I just want to draw a line on a bitmap with no anti-aliasing effect in Firemonkey. Something like this:
var
Bmp: TBitmap;
Bmp := TBitmap.Create(2000, 2000);
if (Bmp.Canvas.BeginScene) then
begin
Bmp.Canvas.Stroke.Color := TAlphaColors.Aquamarine;
Bmp.Canvas.DrawLine(PointF(5, 5), PointF(100, 100), 1);
Bmp.Canvas.EndScene;
Bmp.SaveToFile('c:\temp\result.bmp');
end;
FreeAndNil(Bmp);
But it doesn't work. I am trying for a while with several ideas with no luck:
Using Map/Unmap to access the bitmap data directly is very slow with big bitmaps according to my coworkers.
Using a TImage with DisableInterpolation=true and even GlobalUseGPUCanvas=False doesn't work.
Using a TPaintBox component doesn't fit our needs.
The solution would be the use of Canvas.Quality=HighPerformance but it's a read-only property. I tried to change the bitmap Canvas.Quality in different ways but it doesn't work.
So how can I simply draw a line with no anti-aliasing effect at all in Firemonkey?
PS: I am using Delphi 10.2.3 (Tokyo)
Finally I found a way to do this. It's so simple that I am wondering if there is some hidden poison in the solution (LOL). TCanvasManager allows the creation of a HighPerformance Canvas from a given bitmap. It draws with no antialiasing according to my tests. Here the code:
var
Bmp: TBitmap;
TmpCanvas: TCanvas;
begin
Bmp := TBitmap.Create(2000, 2000);
TmpCanvas := TCanvasManager.CreateFromBitmap(Bmp, TCanvasQuality.HighPerformance);
if (TmpCanvas.BeginScene) then
begin
TmpCanvas.Stroke.Color := TAlphaColors.Aquamarine;
TmpCanvas.DrawLine(PointF(5, 5), PointF(100, 100), 1);
TmpCanvas.EndScene;
Bmp.SaveToFile('c:\temp\result.bmp');
end;
FreeAndNil(TmpCanvas);
FreeAndNil(Bmp);
I also found that it doesn't work with the method to write text on Canvas (Canvas.FillText).
I hope this helps many others with the same problem.
FireMonkey paints lines on the grid between the pixels and not on the pixels. So you have to add 0.5 to each coordinate in order to paint on the pixels:
Bmp.Canvas.DrawLine(PointF(5.5, 5.5), PointF(100.5, 100.5), 1);
This does not disable anti-aliasing, but avoids the excessive anti-aliasing that happens otherwise. I'm not aware of a FireMonkey function that disables anti-alisiasing. You would have to call a native OS function, for example CGContextSetAllowsAntialiasing on MacOS, but usually it is not needed anymore as soon as you figure out how to paint on the pixels.
Hi i have the following code to add an image from a Timage that for now is populated from a blob. My issue is this code does not add the image to the paintbox but rather to the form.
var
RectangleCanvas, RectanglePicture: TRectF;
BlobStream: TStream;
begin
BlobStream := qrypunchsheetitemphoto.CreateBlobStream(qrypunchsheetitemphoto.FieldByName('Photo'),TBlobStreamMode.bmRead);
imgviewimage.Bitmap.LoadFromStream(BlobStream);
fdrawbox:= TMyPaintBox.Create(panel1);
fdrawbox.Canvas.BeginScene;
fdrawbox.BitmapStamp := imgviewimage.Bitmap;
fdrawbox.Height := imgviewimage.Bitmap.Height;
fdrawbox.Width := imgviewimage.Bitmap.Width;
RectangleCanvas := RectF(10, 10, imgviewimage.Bitmap.Width, imgviewimage.Bitmap.Height);
RectanglePicture := RectF(10, 10, imgviewimage.Bitmap.Width, imgviewimage.Bitmap.Height);
fdrawbox.Canvas.DrawBitmap(imgviewimage.Bitmap, RectangleCanvas , RectanglePicture, 1);
fdrawbox.Canvas.EndScene;
fdrawbox.BringToFront;
BlobStream.Free;
TabControl1.ActiveTab := tabViewImage;
end;
end;
The FMX Paintbox is different to older Delphi Paintboxes. Previously you could put a Paintbox anywhere on your form and start drawing. The results would be within the confines of the Paintbox where you placed it.
The FMX Paintbox isn't like that and I don't understand their reasoning. I've been told it has a something to do with cross-platform compatibility and how devices handle canvas operations.
You can verify canvas width for yourself easily enough.
If you have a form width of 640 pixels and place a 50 x 50 Paintbox in the middle you'd expect drawing to occur in the middle.
Check it yourself;
ShowMessage(FloatToStr(Paintbox1.Width)); // Result will be 50
Now check Paintbox1.Canvas.Width and you'll get a different result.
ShowMessage(IntToStr(Paintbox1.Canvas.Width)); // Result is 640
When you pass parameters to drawing functions you need to take this into account and offset accordingly. I have read something about parental clipping having some effect, but I've not seen it work.
Another potential solution is to use a TPanel and draw on it's canvas.
I am trying to capture Printer.Canvas as a Bitmap using BitBlt. I want to then take that Bitmap and display it on a paintbox. However, when I attempt this I am given only a white rectangle proportionate to the values I entered for Bitmap.SetSize. My printout looks correct, so I am almost positive the canvas of the printer is being properly drawn to. I attempted the following code using the variable bitmap as the destination and the paintbox as the source (in essence I was drawing a simple rectangle and line of text to the Paintbox, bitblt-ing it to a bitmap, clearing it, and then posting it back to the paintbox), but now that Printer.Canvas.Handle is the source it doesn't display.
I understand that the dimensions between the screen and printer are different so I will clearly indicate dimensions, just in case I am doing it wrong.
procedure TForm2.btnDrawClick(Sender: TObject);
begin
Printer.BeginDoc;
Printer.Canvas.Font.Size := 10; //Not Sure if this is necessary
Printer.Canvas.Font.Name := 'Arial'; //Not Sure if this is necessary
Printer.Canvas.Font.Color := clBlack; //Not Sure if this is necessary
Printer.Canvas.Rectangle(100,100,200,200); //Should print very tiny to paper
//But will look bigger when posted to
//The Paintbox
Printer.Canvas.TextOut(120,120,'XRay-Cat');
PCBitmap.SetSize(Paintbox1.Width,Paintbox1.Height); //Paint box is 300W,300H
Application.ProcessMessages;
BitBlt(PCBitmap.Canvas.Handle, //PCBitmap, is created on create, freed on destroy,
//Defined in the private section
0,
0,
PCBitmap.Width, //300
PCBitmap.Height, //300
Printer.Canvas.Handle,
0,
0,
SRCCOPY);
Application.ProcessMessages;
Printer.EndDoc;
procedure TForm2.btnPostBMClick(Sender: TObject);
begin
PaintBox1.Canvas.Draw(0,0,PCBitmap);
end;
I expect that the canvas would be written too, the canvas would be copied to a bitmap, then be available to be drawn on the paintbox. However all I see is a white rectangle. I am setting the dimensions of the bitmap to be the entire paintbox rather than the entire canvas of the printer. I am doing this because if I understand it correctly I should be only be drawing between the printer canvas's TopLeft 0,0 and BottomRight 300,300 the same way I would on my paint box. I would expect to see the same results as I would if I did this directly to the Paintbox.
Any help would be greatly appreciated. Thanks in advance.
Given the comments I've received it seems what I was trying to do was not possible. What I wanted to do was to write to a printers canvas and then get the image data of that canvas and store it in a bitmap. Since BitBlt can't be used is there a way to do what I wanted? I assume not, as I was told Printer.Canvas cannot be read from. At this point I have Found a way around it but I am just curious.
Switch your logic...draw to the PaintBox...and Print the PaintBox
procedure TForm55.Button1Click(Sender: TObject);
var
a_BM: TBitMap;
begin
a_BM := TBitmap.Create;
try
PaintBox1.Canvas.Font.Size := 10; //Not Sure if this is necessary
PaintBox1.Canvas.Font.Name := 'Arial'; //Not Sure if this is necessary
PaintBox1.Canvas.Font.Color := clBlack; //Not Sure if this is necessary
PaintBox1.Canvas.Rectangle(0,0,300,300); //Should print very tiny to paper
//But will look bigger when posted to
//The Paintbox
PaintBox1.Canvas.TextOut(120,120,'XRay-Cat');
PaintBox1.Width := 300;
PaintBox1.Height := 300;
a_BM.SetSize(PaintBox1.Width, PaintBox1.Height);
BitBlt(a_BM.Canvas.Handle, 0, 0, a_BM.Width, a_BM.Height, PaintBox1.Canvas.Handle, 0, 0, SRCCOPY);
Application.ProcessMessages;
Printer.BeginDoc;
Printer.Canvas.Draw(a_BM.Canvas.ClipRect.Left, a_BM.Canvas.ClipRect.Top, a_BM);
Printer.EndDoc;
Application.ProcessMessages;
finally
a_BM.Free;
end;
end;