Metafile clipping rectangle - delphi

Following code makes quite some troubles:
procedure TForm1.Button1Click(Sender: TObject);
var dc : HDC;
meta : TMetafile;
metaCanv : TMetafileCanvas;
cr : TRect;
sz : TSize;
begin
dc := GetDC(0);
SetWindowExtEx(dc, 4800, 1300, #sz);
ShowMessage(Format('size %d, %d', [sz.cx, sz.cy]));
meta := TMetafile.Create;
meta.SetSize(4500, 1300);
metaCanv := TMetafileCanvas.Create(meta, dc);
try
IntersectClipRect(metaCanv.Handle, 0, 0, 4600, 1300);
cr := metaCanv.ClipRect;
with cr do
ShowMessage(Format('clip rect: %d, %d, %d, %d', [Top, Left, Bottom, Right]));
finally
metaCanv.Free;
meta.Free;
end;
DeleteDC(dc);
end;
The problem is that the clipping rectangle is bound to the display resolution e.g. if your screen has 1920 pixels width the clipping rectangle is bound to this value.
Note it is NOT a problem to remove clipping at all and paint lines event to the complete bottom rect corner. The problem arises if a clipping region is set (e.g. to the complete metafile width/height as shown in the example) and then paint the line -> it is clipped to the screen width/height.
I know that I could use e.g. a printer dc as reference which will basically fix the problem but there are a few side effects (e.g. gdi+ drawing on metafiles with such
dc's simply does not work).
Anyone knows how to "trick" the system such that this odd clipping behaviour is not
there any more?

ClipRect being the only part in which you can draw is a false presumption.
The documentation on TCustomCanvas.ClipRect:
Use ClipRect to determine where the canvas needs painting.
This is easily verified by drawing beyond ClipRect and trying to show what has been drawn, for example as follows:
procedure TForm1.Button1Click(Sender: TObject);
var
MetaFile: TMetafile;
MetaCanvas: TMetafileCanvas;
begin
MetaFile := TMetafile.Create;
try
MetaCanvas := TMetafileCanvas.Create(MetaFile, 0);
try
MetaFile.SetSize(4500, 1300);
MetaCanvas.LineTo(4500, 1300);
finally
MetaCanvas.Free;
end;
Canvas.Draw(-4400, -1200, MetaFile);
finally
MetaFile.Free;
end;
end;

Related

Delphi FMX TImage manual alpha transparency mapping failure

I am trying to create a TImage with alpha transparency using code.
In this example, an anti-aliased circle.
I create an 8bit opacity map for the circle and then apply it to the TImage's TBitmap using this piece of code:
type
TOpacityMap = Array[0..4095] of PByteArray;
procedure DrawAntiAliasedCircle(srcBitmap: TBitmap; FillColor : TAlphaColor; CenterX, CenterY, Radius, LineWidth, Feather: single);
var
FillR : Integer;
FillG : Integer;
FillB : Integer;
FillRGB : Integer;
OpacityMap : TOpacityMap;
AlphaScanLine : Array[0..4095] of TAlphaColor;
bitmapData : FMX.Graphics.TBitmapData;
tmpScanLine : Pointer;
X,Y : Integer;
tmpMS : TMemoryStream;
begin
{Initialization}
FillR := TAlphaColorRec(FillColor).R;
FillG := TAlphaColorRec(FillColor).G;
FillB := TAlphaColorRec(FillColor).B;
CreateAntiAliasedCircleOpacityMap(OpacityMap, srcBitmap.Width, srcBitmap.Height, CenterX, CenterY, Radius, LineWidth, Feather);
{create image based on opacity map and free memory}
If srcBitmap.Map(TMapAccess.Write, bitmapData) then
try
FillRGB := (FillR shl 16)+(FillG shl 8)+FillB;
for Y := 0 to srcBitmap.Height-1 do
begin
for X := 0 to srcBitmap.Width-1 do
AlphaScanLine[X] := (OpacityMap[Y][X] shl 24)+FillRGB; // Opacity
tmpScanLine := bitmapData.GetScanline(Y);
AlphaColorToScanLine(#AlphaScanLine,tmpScanLine,srcBitmap.Width,srcBitmap.PixelFormat);
FreeMem(OpacityMap[Y]);
end;
finally
srcBitmap.Unmap(bitmapData);
end;
// Work-around fix
{tmpMS := TMemoryStream.Create;
srcBitmap.SaveToStream(tmpMS);
srcBitmap.LoadFromStream(tmpMS);
tmpMS.Free;}
end;
The result is the image on the left.
The actual TBitmap seems to be good, calling "srcBitmap.SaveToFile('circle.png')" results in a PNG file with a valid alpha channel.
I can work-around this issue by simply saving/loading the bitmap using a TMemoryStream.
How do I get the desired image on the right without the performance penalty of passing the image through a TMemoryStream?
These screenshots are from the minimal example project demonstrating this issue :
https://github.com/bLightZP/AntiAliasedCircle
edit #1 :
The github code linked above has been updated with an optimized (about 25% faster) version of Tom Brunberg's suggested fix.
You can achieve your goal with applying alpha channel premultiplying to your overlay image. For example in the loop where you add the alpha channel:
for X := 0 to srcBitmap.Width-1 do
begin
AlphaScanLine[X] := (OpacityMap[Y][X] shl 24)+FillRGB;
AlphaScanLine[X] := PremultiplyAlpha(AlphaScanLine[X]); // Add this for premultiplied Alpha
end;
The result looks like this (ofcourse without the stream work-around)

Take screenshot of specific part of screen

I'm trying to take a screenshot of a specific part of the screen. Here is the coordinates of the part of the screen i want to 'cut' :
Left : 442
Top : 440
Right : 792
Bottom : 520
That is, a rectangle of width 350px and height of 80px. But i don't know how to use CopyRect to achieve this task, instead i'm getting a blank image. Here is my code :
function screenshot: boolean;
var
Bild : TBitmap;
c: TCanvas;
rect_source, rect_destination : TRect;
begin
c := TCanvas.Create;
bild := tbitmap.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
try
rect_source := Rect(0, 0, Screen.Width, Screen.Height);
rect_destination := Rect(442,440,792,520);
Bild.Width := 350;
Bild.Height := 80;
Bild.Canvas.CopyRect(rect_destination, c, rect_source);
Bild.savetofile('c:\users\admin\desktop\screen.bmp');
finally
ReleaseDC(0, c.Handle);
Bild.free;
c.Free;
end;
end;
What you are doing here is copying the whole screen and draw it at coordinate Rect(442,440,792,520); in your new bitmap... Which is off its canvas.
The coordinate Rect(442,440,792,520) correspond to the part you want to get from the source bitmap. You want to copy it "inside" your new bitmap, so within the rect Rect(0,0,350,80)
You can simply adjust your rect like this :
rect_source := Rect(442,440,792,520);
rect_destination := Rect(0,0,350,80);
The rest of your code seems correct.

Saving ImgView32 transparent layers to PNG

I have problems saving an ImgView32 layer as a TRANSPARENT PNG.
I use the code from this question to do the saving.
However, the image saves with a white background.
Here is how I initialize my ImgView32, create a layer on it, and then draw a line on it:
procedure TputLine.FormCreate(Sender: TObject);
var
P: TPoint;
W, H: Single;
imwidth: integer;
imheight: integer;
begin
imwidth := Iv1.Width;
imheight := Iv1.Height;
with iv1 do
begin
Selection := nil;
Layers.Clear;
Scale := 1;
Scaled := True;
Bitmap.DrawMode := dmTransparent;
Bitmap.SetSize(imwidth, imheight);
Bitmap.Canvas.Pen.Width := 4;
end;
BL := TBitmapLayer.Create(iv1.Layers);
try
BL.Bitmap.DrawMode := dmTransparent;
BL.Bitmap.SetSize(imwidth,imheight);
BL.Bitmap.Canvas.Pen.Width := penwidth;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Location := GR32.FloatRect(0, 0, imwidth, imheight);
BL.Scaled := False;
except
BL.Free;
raise;
end;
end;
So iv1 is the name of my ImgView32.
Then I draw a line on it using this code:
var
bm32:TBitmapLayer;
...
begin
bm32:=(iv1.Layers[0] as TBitmapLayer).Bitmap;
bm32.canvas.pen.color:=clwhite;
bm32.canvas.brush.color:=clwhite;
bm32.canvas.rectangle(0,0,bm32.width-1, bm32.height-1);
bm32.canvas.Pen.Color:=WinColor(ColorPickerGTK1.SelectedColor);
bm32.canvas.brush.color:=clWhite;
bm32.Canvas.Pen.Width:=3;
bm32.Canvas.MoveTo(0,bm32.Height);
bm32.Canvas.LineTo(0+150,bm32.Height-250);
end;
If I use the clWhite32 for the above code when drawing the rectangle, then when saving the PNG, the background of the imgView turns black... So I do not understand the problem really.
I do the saving like this:
procedure TputLine.Button2Click(Sender: TObject);
var
myLay:TBitmapLayer;
begin
mylay := iv1.Layers.Items[0] as TBitmapLayer;
SavePNGTransparentX(mylay.Bitmap);
end;
and the actual saving code (from the link described above)
procedure TPutLine.SavePNGTransparentX(bm32:TBitmap32);
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
bm32.ResetAlpha;
for Y := 0 to bm32.Height-1 do
for X := 0 to bm32.Width-1 do
begin
if IsWhite(bm32.Pixel[X, Y]) then
bm32.Pixel[X,Y]:=Color32(255,255,255,0);
end;
Png:= TPortableNetworkGraphic32.Create;
Png.Assign(bm32);
Png.SaveToFile('C:\ThisShouldBeTransparent.png');
Png.Free;
end;
I do not understand why it does not save the layer as transparent PNG.
How can I fix it? Any idea is welcome.
You can replicate my problem using the above code. It uses GR32_PNG and GR32_PortableNetworkGraphic. You only need to add a TImgView32 control to your form and add the code listed above.
The reason to the problem seems to be two-fold.
First, when you call Png.Assign(bm32); in unit GR32_PNG, it attempts to find out what the smallest format would be to store the image in. If the image has less than 256 distinct colors, it creates a paletted format, and depending on how many colors it finds, the bit depth can become 1, 2, 4 or 8. As far as my knowledge goes, only images with TrueColor and Alpha can be saved as variable transparency png images.
Secondly, you draw with only one color, which triggers the above problem. This is of course not your fault, IMO the above mentioned analysis should be possible to bypass.
The TPortableNetworkGraphic32 class has two properties, BitDepth and ColorType wich control the format of the png image, that would be useful, if they were settable! Attempting to set them in code as:
Png.BitDepth := 8;
Png.ColorType := ctTrueColorAlpha;
leads to exceptions
EPngError with message 'Bit depth may not be specified directly yet!
EPngError with message 'Color Type may not be specified directly yet!
From the wording we can assume some further development in the future.
The cure
To bypass the above described image analysis, you can change line 459 in GR32_PNG.pas.
procedure TPortableNetworkGraphic32.AssignPropertiesFromBitmap32()
var
...
begin
...
IsPalette := True; // <--- change to False
...
That will take care of the bit depth analysis and prevents palette creation if less than 256 colors.
After this hack you can use the SavePNGTransparentX() procedure to save a TBitmap32 to a .png file and preserving transparency.
Then, there's one change more that you may be interested in, regarding the SavePNGTransparentX() procedure. As you have seen, it requires the background of your drawing surface to be white, because it specifically sets the Alpha channel to zero for all white pixels. A TBitmapLayer is however initialized with all pixels (RGBA) as all zeros, so the color components of each pixel makes up to black color (which is not visible because the alpha channel is zero). Therefore you need to fill the drawing layer with white, which makes it opaque, which again covers up all lower layers (beneath the drawing layer).
To make a correction to this you can
remove the initialization of the drawing layer to all white
change the IsWhite function into an IsBlack function
change the assignment of the transparent pixels
Code would become
procedure TForm8.SavePNGTransparentX(bm32:TBitmap32);
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
function IsBlack(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 0) and
(TColor32Entry(Color32).G = 0) and
(TColor32Entry(Color32).R = 0);
end;
function IsWhite(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 255) and
(TColor32Entry(Color32).G = 255) and
(TColor32Entry(Color32).R = 255);
end;
begin
bm32.ResetAlpha;
for Y := 0 to bm32.Height-1 do
for X := 0 to bm32.Width-1 do
begin
// if IsWhite(bm32.Pixel[X, Y]) then
// bm32.Pixel[X,Y]:=Color32(255,255,255, 0);
if IsBlack(bm32.Pixel[X, Y]) then
bm32.Pixel[X,Y]:=Color32( 0, 0, 0, 0);
end;
Png:= TPortableNetworkGraphic32.Create;
Png.Assign(bm32);
Png.SaveToFile('C:\tmp\imgs\ThisShouldBeTransparent3.png');
Png.Free;
end;
With this change you can see the layers beneath your drawing layer and the resulting file of your drawing layer will have all non-drawn pixels transparent.
There is however still one problem in general with the above procedure, and that is that partially transparent pixels loose their transparency, but that will remain for a future excercise.
Here's a few images, First the ImageView with a bitmap loaded on the bottom layer:
Then, I draw a blue cross on the BL layer (ref. your code) using basically the code in your Button1Click() but without the white rectangle.
Then I save the BL layer to a .png file and look at it with Windows Explorer "Preview":

Filling a region draws it off canvas

Using the following code in Delphi 2007:
procedure TfrmTest.PaintBox1Paint(Sender: TObject);
const
Rect_Size = 10;
begin
PaintBox1.Canvas.Brush.Color := clYellow;
PaintBox1.Canvas.FillRect(Rect(0, 0, PaintBox1.width, PaintBox1.height));
PaintBox1.Canvas.Brush.Color := clRed;
DrawARect(PaintBox1.Canvas, 0, 0, Rect_Size, Rect_Size);
end;
procedure TfrmTest.DrawARect(ACanvas: TCanvas; iLeft, iTop, iWidth, iHeight: Integer);
var
rgnMain: HRGN;
begin
rgnMain := CreateRectRgn(iLeft, iTop, iLeft + iWidth, iTop + iHeight);
try
SelectClipRgn(ACanvas.handle, rgnMain);
ACanvas.FillRect(ACanvas.ClipRect);
SelectClipRgn(ACanvas.handle, 0);
finally
DeleteObject(rgnMain);
end;
end;
I get this:
(Yellow area shows boundaries of PaintBox1).
alt text http://www.freeimagehosting.net/uploads/62cf687d29.jpg
(Image shows a form with a yellow box [PaintBox1] in the center. However my red rectange [rgnMain] has been drawn at pos 0,0 on the form)
My expectation was that the red rectangle would be at the top left of the PaintBox1 canvas, not the form's canvas. Why is it not? Can regions only be used with controls that have a Windows handle?
Thanks
Device Contexts require a window handle. What VCL does for non-windowed controls is to offset the view port of the DC acquired for the TWinControl they are on, by using SetWindowOrgEx in TWinControl.PaintControls. The new view port is in logical units. So for 'TGraphicControl's, which does not descend from TWinControl, you can use GDI functions which work on logical coordinates. See the remarks section for SelectClipRgn, which says the coordinates should be specified in device units. You'd offset the region or the coordinates.

How to tile a Image in TImage?

How do I tile an image in a TImage in Delphi?
Why I need it: Instead of creating more TImages at runtime, I could create one and store my image there knowing that it will be 'fit' until it reaches TImage's height and width.
Please suggest any ideas to do this.
Thank you!
EDIT: Please note, I'm not asking for streching the image, but filling the canvas by repeating the image.
Assuming your image is a bitmap and loaded into the TImage you can use the following
procedure TmyForm.Button1Click(Sender: TObject);
var mybmp:TBitmap;
begin
mybmp:= TBitmap.Create();
try
mybmp.Assign(Image1.Picture.Bitmap);
Image1.Picture.Bitmap.SetSize(Image1.Width,Image1.Height);
Image1.Canvas.Brush.Bitmap := mybmp;
Image1.Canvas.FillRect(Image1.BoundsRect);
mybmp.FreeImage;
finally
FreeandNil(mybmp)
end;
end;
Some notes:
If you save the image after titling it you will save the titled version not the original.
Image1.Canvas and Image1.Picture.Bitmap.Canvas are one and the same, that's why you need to resize the bitmap before painting on the canvas.
If you try and assign the bitmap in the TImage to the brush without assigning it to another bitmap object first like so Image1.Canvas.Brush.Bitmap := Image1.Picture.Bitmap you get an exception "not enough storage".
The following is the function that I have used, taking an existing TImage component and tiling it over a target canvas:
procedure TileImage(const Source:tImage;
Target: TCanvas;
TargetHeight,TargetWidth:integer);
// Tiles the source image over the given target canvas
var
X, Y: Integer;
dX, dY: Integer;
begin
dX := Source.Width;
dY := Source.Height;
Y := 0;
while Y < TargetHeight do
begin
X := 0;
while X < TargetWidth do
begin
Target.Draw(X, Y, Source.Picture.graphic);
Inc(X, dX);
end;
Inc(Y, dY);
end;
end;
Because a tLabel exposes a canvas, you can do tricks like the following:
TileImage(Image1,Label1.Canvas,Label1.Height,Label1.Width);
You could set the canvas.brush.bitmap := to the image of the tile. then canvas.fillrect(canvas.cliprect) to tile the whole canvas with the selected tile image. I haven't done it in a long time and I am not able to check if this is really how it's done in Delphi right now, but I am pretty sure this is what you're after.
Delphi installation comes with a Demo named 'Bitmap' (you can find the project in Help dir.).
It uses the following method to draw a tiled image:
procedure TBmpForm.FormPaint(Sender: TObject);
var
x, y: Integer;
begin
y := 0;
while y < Height do
begin
x := 0;
while x < Width do
begin
// Bitmap is a TBitmap.
// form's OnCreate looks like this:
// Bitmap := TBitmap.Create;
// Bitmap.LoadFromFile('bor6.bmp');
// or you can use Canvas.Draw(x, y, Image1.Picture.Bitmap),
// instead of Canvas.Draw(x, y, Bitmap);
//
Canvas.Draw(x, y, Bitmap); //Bitmap is a TBitmap.
x := x + Bitmap.Width; // Image1.Picture.Bitmap.Width;
end;
y := y + Bitmap.Height; // Image1.Picture.Bitmap.Height;
end;
end;
Hope that helps!
By "fitting" do you mean "tiling"?
As far as I know, TImage does not support this out of the box. You'd have to manually draw your picture on the TImage's Canvas in a repeating pattern.

Resources