Applying transformations to Bitmap before calling Canvas.DrawBitmap (Firemonkey) - delphi

Good afternoon.
I'm working on a drawing program that allows the user to drag and drop TImages loaded with a Bitmap over a canvas. (In a Firemonkey HD application in RAD Studio XE2) The user can then change x and y scales and rotation before saving the image.
All TImages are kept in a list and this list is then written to the underlying canvas using this simple procedure:
for i := 0 to DroppedList.Count - 1 do
begin
AImage := DroppedList[i];
SourceRect.Left := 0;
SourceRect.Right := AImage.Bitmap.Width;
SourceRect.Top := 0;
Sourcerect.Bottom := AImage.Bitmap.Height;
TargetRect.Left := AImage.Position.X;
TargetRect.Right := AImage.Position.X + AImage.Bitmap.Width;
TargetRect.Top := AImage.Position.Y;
TargetRect.Bottom := AImage.Position.Y + AImage.Bitmap.Height;
with FImage.Bitmap do
begin
Canvas.BeginScene;
Canvas.DrawBitmap(AImage.Bitmap, SourceRect, TargetRect, 1, True);
Canvas.EndScene;
BitmapChanged
end;
end;
FImage.Bitmap.SaveToFile('test.bmp');
The problem with this is that transformations to the scale and rotation of the images that are visible in the window are not taken into account by DrawBitmap, and are lost when saving.
I am looking for a way to apply the transformations to the bitmap before drawing it to the background.
I was unable to find any info on this, so i was hoping someone here could help.
Thank you,
Daniël

the problem seems to be that the Scaling and the Rotation are applyed to a source TImage. In this "source TImage", the transformations are not done to the bitmap but rather at the TImage level (beause it's a TControl and as all TControl they can be scaled and rotated). Later you copy the source Bitmap elsewhere, but actually this Bitmap has never changed.
So would have to rotate and scale the bitmap in the loop, according to the settings in the source TImage:
with FImage.Bitmap do
begin
Canvas.BeginScene;
LBmp := TBitmap.Create;
try
// create a copy on which transformations will be applyed
LBmp.Assign(AImage.Bitmap);
// rotate the local bmp copy according to the source TImage.
if AImage.RotationAngle <> 0 then
LBmp.Rotate( AImage.RotationAngle);
// scale the local bmp copy...
If AImage.Scale.X <> 1
then ;
Canvas.DrawBitmap(LBmp, SourceRect, TargetRect, 1, True);
finally
LBmp.Free;
Canvas.EndScene;
BitmapChanged
end;
end;
This simple code sample explains well the problem. For example, RotatationAngle is a property of AImage and not of AImage.Bitmap.
A workaround that would avoid to implement the transformations would be to use TControl.MakeScreenshot(). (to be verified, this coulds fail)
with FImage.Bitmap do
begin
Canvas.BeginScene;
LBmpInclTranformations := AImage.MakeScreenShot;
Canvas.DrawBitmap(LBmpInclTranformations, SourceRect, TargetRect, 1, True);
Canvas.EndScene;
BitmapChanged
end;

Related

Fast crop .png images in Delphi

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.

Delphi print a custom area of a form

I have a form which I need to print but only a certain section of it and then enlarge it (increase the scale). So far I have the following code:
procedure TForm1.PrintButtonClick(Sender: TObject);
var
printDialog : TPrintDialog;
begin
printDialog := TPrintDialog.Create(Form1);
if printDialog.Execute then
begin
Printer.Orientation := poLandscape; //Better fit than portrait
Form1.PrintScale:=poPrintToFit;
Form1.Print;
end;
end;
However, this prints the whole form. I've googled around and found a few different things that might help but I'm not sure how to use them:
GetFormImage - Is there a way of selecting a specific area with this or does it just take the whole form?
Using a rectangle with given coordinates e.g rectangle1:= rect(Left, Top, Right, Bottom); but then how do I print scale the rectangle to a larger size and print it? As well, seen as though Delphi only gives Left and Top properties, is Right just another name for the furthest left value you want to go to?
UPDATE:
I have tried to create a custom bitmap and then stretch it but I'm not using the strechdraw correctly. It doesn't actually stretch when printed:
procedure TForm1.PrintButtonClick(Sender: TObject);
var
printDialog: TPrintDialog;
Rectangle, stretched: TRect;
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Rectangle := Rect(0, 90, 1450, 780);
stretched := Rect(0, 0, 5000, 3000); //what numbers do i put in here for streching it?
Bitmap.SetSize(Form1.Width, Form1.Height);
Bitmap.Canvas.CopyRect(Rectangle, Form1.Canvas, Rectangle);
Bitmap.Canvas.StretchDraw(stretched, Bitmap); //not sure how to use this
finally
printDialog := TPrintDialog.Create(Form1);
if printDialog.Execute then
begin
with printer do
begin
BeginDoc;
Canvas.Draw(0, 90, Bitmap);
EndDoc;
end;
end;
Bitmap.Free;
end;
end;
Is the try and finally necessary?
When I printed without the stretchdraw it was really small but when I printed with the stretchdraw, a lot of the image was missing so I must be using it wrong
Get rid of your stretched variable and the Bitmap.Canvas.StretchDraw (you can also get rid of the TPrintDialog if you'd like).
// Capture your bitmap content here, and then use this code to scale and print.
Printer.Orientation := poLandscape;
Printer.BeginDoc;
Printer.Canvas.StretchDraw(Rect(0, 0, Printer.PageWidth, Printer.PageHeight), Bitmap);
Printer.EndDoc;

BitBlt Printer.Canvas to a TBitMap displays as solid white

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;

Is there a reliable way to draw a bitmap on a Tprinter canvas?

I have created a print preview object which allows me to organise several graphic objects from different sources onto a printed page.
In order to render these objects on the printer canvas I have to first render them to a bitmap of the calculated size and then render the bitmap to the Tprinter canvas at the correct positions using the canvas.draw(x,y,bitmap) method.
I found out early on that a device independent bitmap is required and set the pixel format to pf24bit.
Tried this on the office HP laserjet, works fine, HP colour Deskjet works fine, Cannon colour printer however does not work or occasionally gives intermittent graphics at random points.
Now if I get the graphical objects to render directly to the printer canvas, then all work OK.
Rendering directly to the printer canvas however is not a workable long term solution for me for various reasons.
So, my question is, what is it about the Tprinter.canvas that makes it hardware dependent and is there any workarounds ?
Some example code which divides the page up into 4 quadrants with margins and cell padding and puts a graphical object in each quadrant. Each graphical object has a RenderToBitmap method which draws the graphics.
procedure TMultiPrintForm.PrintBtnClick(Sender: TObject);
var w,h,h2,w2,mv,iw,ih,pv,cw,ch:integer; Abmp:Tbitmap;
begin
Abmp:=Tbitmap.create;
Abmp.PixelFormat := pf24bit;
try
with Printer do
begin
w:=pagewidth;
h:=pageheight;
h2:=h div 2;
w2:=w div 2;
mv:=h*margin.value div 200; //margin percentage div 2
pv:=h*padding.value div 400; //padding percentage div 4
iw:=w-mv; //internal width
ih:=h-mv; //internal height
cw:=(iw-mv) div 2-pv; //Quadrant Cell Width
ch:=(ih-mv) div 2-pv; //Quadrant Cell Height
Abmp.width:=cw;
Abmp.height:=ch;
If Fsources[0]<>nil then
begin
Fsources[0].rendertoBitmap(Abmp);
canvas.draw(mv,mv,Abmp);
end;
If Fsources[1]<>nil then
begin
Fsources[1].rendertoBitmap(Abmp);
canvas.draw(w2+pv,mv,Abmp);
end;
If Fsources[2]<>nil then
begin
Fsources[2].rendertoBitmap(Abmp);
canvas.draw(mv,h2+pv,Abmp);
end;
If Fsources[3]<>nil then
begin
Fsources[3].rendertoBitmap(Abmp);
canvas.draw(w2+pv,h2+pv,Abmp);
end;
end;
finally
printer.Enddoc;
Abmp.free;
end
end;
On further investigation around the net, I accumulated some suggestions into a PrintBitmap procedure which uses a technique recommended by Microsoft.
I replaced all the Canvas.draw calls with PrintBitmap calls (it assumes begindoc and enddoc are set outside the calls).
Being as its the weekend, I can't test it on the problem printers in the office but it does at least not break the printing on the home HP Deskjet printer (which works anyway with both methods).
procedure PrintBitmap(X,Y:integer; Abmp:Tbitmap);
var Info: PBitmapInfo;
InfoSize,ImageSize: DWORD; Image: Pointer;
DIBWidth, DIBHeight: LongInt;
begin
with Printer do
begin
GetDIBSizes(Abmp.Handle, InfoSize, ImageSize);
Info := AllocMem(InfoSize);
Image := AllocMem(ImageSize);
try
GetDIB(Abmp.Handle, 0, Info^, Image^);
with Info^.bmiHeader do
begin
DIBWidth := biWidth;
DIBHeight := biHeight;
end;
StretchDIBits(Canvas.Handle, X, Y, DIBWidth, DIBHeight, 0, 0,
DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Image, ImageSize);
FreeMem(Info, InfoSize);
end
end;
end;

CopyRect (scaling) with the correct colors in Delphi

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.

Resources