How to tile a Image in TImage? - delphi

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.

Related

TImage width with double value instead integer

How can I set TImage size as double value? Example Image1.width := 50.1; or what component accept it, because TImage only accept integer values.
I'm working with download files, and one image should be the number of elements to download, so Image1.width max value is 340, i need to divide this value by the amount of files who will be downloaded, and increase this value on image1.width when every download be finished, but TImage only accept Integer value.
I already did it using "Round" but it is not what I need.
As answered, you cannot set the image's size to any floating point value.
However, using coordinate spaces and transformations functions, you can set an arbitrary transformation between a logical coordinate system and the viewing device. This can be used to increase the logical extent of the image's canvas size with each download and yet keep the image on the screen with an entirely different size.
The below example demonstrates the concept by drawing 4 rows and 4 columns of a 256x256 image on a 105x105 bitmap canvas of a TPicture of a TImage. Basically it achieves to draw a single 256x256 image on a 26.25x26.25 px. surface.
uses
pngimage;
procedure TForm1.Button1Click(Sender: TObject);
const
Col = 4;
Row = 4;
var
Png: TPngImage;
ImgCanvas: TCanvas;
ExtX, ExtY: Integer;
MapMode: Integer;
Size: TSize;
i, j: Integer;
begin
Png := TPngImage.Create;
try
Png.LoadFromFile('...\Attention.png');
Png.Draw(Canvas, Rect(0, 0, Png.Width, Png.Height)); // original picture
Image1.Picture.Bitmap.Canvas.Brush.Color := Color;
Image1.Picture.Bitmap.SetSize(Image1.Width, Image1.Height);
ImgCanvas := Image1.Picture.Bitmap.Canvas;
SetStretchBltMode(ImgCanvas.Handle, HALFTONE);
MapMode := SetMapMode(ImgCanvas.Handle, MM_ISOTROPIC);
if MapMode <> 0 then
try
ExtX := Png.Width * Col;
ExtY := Png.Height * Row;
if not GetWindowExtEx(ImgCanvas.Handle, Size) then
RaiseLastOSError;
if not SetWindowExtEx(ImgCanvas.Handle, Size.cx * ExtX div Image1.Width,
Size.cy * ExtY div Image1.Height, nil) then
RaiseLastOSError;
if not SetViewportExtEx(ImgCanvas.Handle, Size.cx, Size.cy, nil) then
RaiseLastOSError;
i := 0;
j := 0;
while j < ExtY do begin
while i < ExtX do begin
Png.Draw(ImgCanvas, Rect(i, j, i + Png.Width, j + Png.Height));
Inc(i, Png.Width);
end;
i := 0;
Inc(j, Png.Height);
end;
finally
SetMapMode(ImgCanvas.Handle, MapMode);
end
else
RaiseLastOSError;
finally
Png.Free;
end;
end;
Probably worth noting that GDI may not be the best graphics system when scaling is involved. For quick reference, here's what the above yields:
Assuming you're using the VCL framework, all controls across Delphi are Integer based. You simply cannot assign a float value, not without first converting it to an integer.
The Firemonkey framework on the other hand is widely based on float values.

Graphics32 - saving transparent drawing layer to png

I draw a dotted line on a layer of an ImgView32. Later, I want to save each layer as transparent PNGs.
For any other layer that I have, the saving works just fine. But for the drawing layer, it does not.
In order to make the question simpler to understand, take the example code from the gr32 library, more specifically the Layers example. One of the options in its main menu is to add a custom drawing layer (New Custom Layer -> Simple Drawing Layer).
Then try to save that layer as a transparent PNG image and you will end up with a corrupted PNG file (you can't open it with any other picture viewer like for example Paint.net or Microsoft Photo Viewer). Same thing happens if you try to save the layer's bitmap32 as a bitmap as you can see in the bellow code...
I tried two approaches for saving Bitmap32 as a transparent PNG, so the first one is as follows:
procedure TMainForm.SavePNGTransparentX(bm32:TBitmap32; dest:string);
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;
try
Png.Assign(bm32);
Png.SaveToFile(dest);
finally
Png.Free;
end;
end;
So the above method works if I have a PNG loaded into the layer like this:
mypng := TPortableNetworkGraphic32.Create;
mypng.LoadFromStream(myStream);
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
mypng.AssignTo(B.Bitmap);
...
But as soon as I try to save the layer created with the code from the Layers example, the result is corrupted.
Even if I try to save the layer as bitmap like this (though this is not my intention since I need them to be PNG):
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
the same corruption occurs.
So, it's not like I receive an exception or anything... it just gets saved corrupted somehow;
I also tried other ways to save the Bitmap32 as transparent PNG, like for instance the GR32_PNG approach:
function SaveBitmap32ToPNG (sourceBitmap: TBitmap32;transparent: Boolean;bgColor32: TColor32;filename: String;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): boolean;
var png: TPNGImage;
begin
result := false;
try
png := Bitmap32ToPNG (sourceBitmap,false,transparent,WinColor(bgColor32),compressionLevel,interlaceMethod);
try
png.SaveToFile (filename);
result := true;
finally
png.Free;
end;
except
result := false;
end;
end;
where
function Bitmap32ToPNG (sourceBitmap: TBitmap32;paletted, transparent: Boolean;bgColor: TColor;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): TPNGImage; // TPNGObject
var
bm: TBitmap;
png: TPNGImage;//TPngObject;
TRNS: TCHUNKtRNS;
p: pngImage.PByteArray;
x, y: Integer;
begin
Result := nil;
png := TPngImage.Create; // TPNGObject
try
bm := TBitmap.Create;
try
bm.Assign (sourceBitmap); // convert data into bitmap
// force paletted on TBitmap, transparent for the web must be 8bit
if paletted then
bm.PixelFormat := pf8bit;
png.interlaceMethod := interlaceMethod;
png.compressionLevel := compressionLevel;
png.Assign(bm); // convert bitmap into PNG
// this is where the access violation occurs
finally
FreeAndNil(bm);
end;
if transparent then begin
if png.Header.ColorType in [COLOR_PALETTE] then begin
if (png.Chunks.ItemFromClass(TChunktRNS) = nil) then png.CreateAlpha;
TRNS := png.Chunks.ItemFromClass(TChunktRNS) as TChunktRNS;
if Assigned(TRNS) then TRNS.TransparentColor := bgColor;
end;
if png.Header.ColorType in [COLOR_RGB, COLOR_GRAYSCALE] then png.CreateAlpha;
if png.Header.ColorType in [COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA] then
begin
for y := 0 to png.Header.Height - 1 do begin
p := png.AlphaScanline[y];
for x := 0 to png.Header.Width - 1
do p[x] := AlphaComponent(sourceBitmap.Pixel[x,y]); // TARGB(bm.Pixel[x,y]).a;
end;
end;
end;
Result := png;
except
png.Free;
end;
end;
but using this approach, I get an EAccessViolation when trying to save this particular layer. For any other layers (not drawing ones), it does not crash my project except for this custom drawing one.
The access violation occurs at this line:
png.Assign(bm);
inside the Bitmap32ToPNG function
Do you have any idea why that happens and how can I prevent this?
EDIT
I tried using TBitmapLayer instead, because the TPositionedLayer might lack the Bitmap32 for some reason.
So my code is like this:
// adding a BitmapLayer and setting it's onPaint event to my handler
procedure TMainForm.Mynewlayer1Click(Sender: TObject);
var
B: TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.SetSize(100,200);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
with ImgView.Bitmap do
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
OnPaint := PaintMy3Handler;
except
Free;
raise;
end;
Selection := B;
end;
// and the PaintHandler is as follows:
procedure TMainForm.PaintMy3Handler(Sender: TObject;Buffer: TBitmap32);
var
Cx, Cy: Single;
W2, H2: Single;
const
CScale = 1 / 200;
begin
if Sender is TBitmapLayer then
with TBitmapLayer(Sender).GetAdjustedLocation do
begin
// Five black pixels, five white pixels since width of the line is 5px
Buffer.SetStipple([clBlack32, clBlack32, clBlack32, clBlack32, clBlack32,
clWhite32, clWhite32, clWhite32, clWhite32, clWhite32]);
W2 := (Right - Left) * 0.5;
H2 := (Bottom - Top) * 0.5;
Cx := Left + W2;
Cy := Top + H2;
W2 := W2 * CScale;
H2 := H2 * CScale;
Buffer.PenColor := clRed32;
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-2,Top);
Buffer.LineToFSP(Cx-2 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-1,Top);
Buffer.LineToFSP(Cx-1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx,Top);
Buffer.LineToFSP(Cx , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+1,Top);
Buffer.LineToFSP(Cx+1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+2,Top);
Buffer.LineToFSP(Cx+2 , Bottom);
end;
end;
Keep in mind that I use the default layers demo application. So this is just added code. I did not remove nor change anything in the demo code.
So I create a new layer (TBitmapLayer) and onPaint I do my drawing. In the end I want to save the contents of that layer as PNG. But it seems like the onPaint might draw somewhere else instead of the actual layer. Otherwise I do not understand why the saved image is empty.
So this time the resulted PNG is not corrupted, but it is empty...
The error is in the fact that the examples create TPositionedLayer layers which do not hold a bitmap. You can not type cast this layer type into a TBitmapLayer and expect it to create a bitmap image of the layer, as you do in this code:
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
I assume you do something similar to save to .png file, although you did not show that code.
The examples (with TPositionedLayer layers) use ImgView.Buffer for drawing on the screen. You can save that to a .png file like this:
SavePNGTransparentX(ImgView.Buffer, 'c:\tmp\imgs\buffer.png');
but I don't expect that to work satisfactorily for your separate layer images.
What is the reason you don't use TBitmapLayers as you have done before?
Edit after comments by user1137313
Inspired by the solution you found yourself (ref. your comment) I suggest the following which paints the layer to the extra bitmap only when needed for saving.
Starting from a menu item
procedure TMainForm.mnFileSaveClick(Sender: TObject);
begin
SaveLayerToPng(ImgView.Layers[ImgView.Layers.Count-1], 'c:\tmp\imgs\buffer.png');
end;
You possibly want to call SaveLayerToPng() in a loop if you save several layers at the same time, and also change the file name(s) as needed.
Then the SaveLayerToPng() procedure
procedure TMainForm.SaveLayerToPng(L: TCustomLayer; FileName: string);
var
bm32: TBitmap32;
begin
bm32:= TBitmap32.Create;
try
bm32.SetSizeFrom(ImgView.Buffer);
PaintSimpleDrawingHandler(L, bm32);
SavePNGTransparentX(bm32, FileName);
finally
bm32.Free;
end;
end;
It calls the existing PaintSimpleDrawingHandler(Sender: TObject; buffer: TBitmap32) procedure to paint to bm32 which it then passes on to `SavePNGTransparentX() for actual saving.
I used the paint handler of the Graphics32 example, but your PaintMy3Handler() can be used just as well.
The end result is same as your solution, just that the extra TBitmap32 is only painted when the file is to be saved.

Metafile clipping rectangle

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;

TPNGObject - Create a new blank image and draw translucent images on it

I am building an application that has "virtual windows". The output is TImage object.
1) The application loads window skin files into TPNGObject's:
2) Then application has to create a new blank TPNGObject, and resize the skin files to needed sizes and draw them on that blank image. Should look something like this:
3) And the final output on TImage:
The problem is that I do know how to create a completely blank off screen image. Of course I could simply render the skin files on to TImage each time, but it's easier and better to resize skin files and create the window once, instead.
I'm using the PNG Library by Gustavo Daud, version 1.564 (31st July, 2006).
The below uses CreatePNG procedure of 'pngfunctions.pas' of Martijn Sally, from an extension library (pngcomponents) to pngimage.
var
Bmp, Mask: TBitmap;
PNG: TPNGObject;
begin
Bmp := TBitmap.Create;
Bmp.PixelFormat := pf24bit;
Bmp.SetSize(64, 64);
Bmp.Canvas.Brush.Color := clBtnFace;
Bmp.Canvas.Font.Color := clRed;
Bmp.Canvas.Font.Size := 24;
Bmp.Canvas.TextOut(4, 10, 'text');
Mask := TBitmap.Create;
Mask.PixelFormat := pf24bit;
Mask.Canvas.Brush.Color := clBlack;
Mask.SetSize(64, 64);
Mask.Canvas.Font.Color := clWhite;
Mask.Canvas.Font.Size := 24;
Mask.Canvas.TextOut(4, 10, 'text');
PNG := TPNGObject.Create;
CreatePNG(Bmp, Mask, PNG, False);
PNG.Draw(Canvas, Rect(10, 10, 74, 74));
// finally, free etc...
Here's the output (black, white squares are TShapes):
My other answer is another alternative which I suggest. However your question still poses an issue: The PNG library must either have a bug which is preventing any canvas drawing from being visible (after using CreateBlank constructor with COLOR_RGBALPHA as color type) or we're all missing something.
It looks like the only workaround that I can see is (as you mention in your edit) use a Bitmap to do your drawing instead. Use the transparent properties of this bitmap (Transparent: Bool and TransparentColor: TColor) to set up the transparent area of your image, then when you need a transparent PNG, just copy that bitmap over to the new PNG object...
BMP.Width:= 100;
BMP.Height:= 100;
BMP.Transparent:= True;
BMP.TransparentColor:= clWhite;
BMP.Canvas.Brush.Style:= bsSolid;
BMP.Canvas.Brush.Color:= clWhite;
BMP.Canvas.FillRect(BMP.Canvas.ClipRect);
BMP.Canvas.Brush.Color:= clBlue;
BMP.Canvas.Ellipse(10, 10, 90, 90);
PNG.Assign(BMP);
And the white area of the image should be transparent. There are other ways of accomplishing the transparent area, but that's another subject.
Image:
Is this what you're trying to do?
I apologize to people that I messed their heads up.
It turns out CreateBlank works as wanted. The problem was that I was drawing PNG on PNG canvas (PNG.Canvas.Draw). Canvas doesn't really support transparency. To draw a translucent PNG on another PNG you will need a procedure/function that merges those both layers together. With some googling I ended up with this procedure:
procedure MergePNGLayer(Layer1, Layer2: TPNGObject; Const aLeft, aTop: Integer);
var
x, y: Integer;
SL1, SL2, SLBlended: pRGBLine;
aSL1, aSL2, aSLBlended: PByteArray;
blendCoeff: single;
blendedPNG, Lay2buff: TPNGObject;
begin
blendedPNG := TPNGObject.Create;
blendedPNG.Assign(Layer1);
Lay2buff:=TPNGObject.Create;
Lay2buff.Assign(Layer2);
SetPNGCanvasSize(Layer2, Layer1.Width, Layer1.Height, aLeft, aTop);
for y := 0 to Layer1.Height - 1 do
begin
SL1 := Layer1.Scanline[y];
SL2 := Layer2.Scanline[y];
aSL1 := Layer1.AlphaScanline[y];
aSL2 := Layer2.AlphaScanline[y];
SLBlended := blendedPNG.Scanline[y];
aSLBlended := blendedPNG.AlphaScanline[y];
for x := 0 to Layer1.Width - 1 do
begin
blendCoeff:=aSL1[x] * 100/255/100;
aSLBlended[x] := round(aSL2[x] + (aSL1[x]-aSL2[x]) * blendCoeff);
SLBlended[x].rgbtRed := round(SL2[x].rgbtRed + (SL1[x].rgbtRed-SL2[x].rgbtRed) * blendCoeff);
SLBlended[x].rgbtGreen := round(SL2[x].rgbtGreen + (SL1[x].rgbtGreen-SL2[x].rgbtGreen) * blendCoeff);
SLBlended[x].rgbtBlue := round(SL2[x].rgbtBlue + (SL1[x].rgbtBlue-SL2[x].rgbtBlue) * blendCoeff);
end;
end;
Layer1.Assign(blendedPNG);
Layer2.Assign(Lay2buff);
blendedPNG.Free;
Lay2buff.Free;
end;
Usage:
var
PNG1, PNG2: TPNGObject;
begin
PNG1 := TPNGObject.CreateBlank(COLOR_RGBALPHA, 16, 500, 500);
PNG2 := TPNGObject.Create;
PNG2.LoadFromFile('...*.png');
MergePNGLayer(PNG1, PNG2, 0, 0);
// PNG1 is the output
And again, I am really sorry to users that wanted to help, but couldn't due to not understanding me.
I don't have answer to this question but I figured out how to get same result with any PNG editor. I have created blank 1000x1000 PNG image and saved it in my application directory. Then I open this image in my program and resize image to needed sizes (smaller of course) and that's the trick.

Printing real dimensions of an image

Hi mates i want to print a picture i generated i use the following code
Printer.BeginDoc;
Printer.Canvas.Draw(0,0,img1.Picture.Bitmap);
Printer.EndDoc;
It works but the image it prints is very small how can i print the actual size of the image as it appears on the screen ?
Thanks very much.
You can call Canvas.StretchDraw() instead. However, be prepared for the results to be less than impressive. Trying to scale a raster image in this way will lead to very blocky results. Vector images are what you need in order to be able to scale to printer resolutions.
var
Scale: Integer;
...
Scale := Min(
Printer.PageWidth div Bitmap.Width,
Printer.PageHeight div Bitmap.Height
);
Printer.Canvas.StretchDraw(
Rect(0, 0, Bitmap.Width*Scale, Bitmap.Height*Scale),
Bitmap
);
The scaling I chose here will preserve the aspect ratio and make the image as large as possible when printed.
You should achieve better results if you resize the image to an intermediate bitmap (with a size suitable for the printer resolution) using one of the resamplers in JCL or Graphics32 and then you print the resized bitmap.
The following routine will try to get the same size in printer as in the screen:
uses
JclGraphics;
procedure PrintGraphic(source: TGraphic);
var
dest: TBitmap;
destWidth, destHeight,
printerPixelsPerInch_X, printerPixelsPerInch_Y,
printerLeftMargin, printerTopMargin: integer;
begin
printerPixelsPerInch_X := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
printerPixelsPerInch_Y := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
printerLeftMargin := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
printerTopMargin := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
dest := TBitmap.Create;
try
destWidth := source.Width * printerPixelsPerInch_X div Screen.PixelsPerInch;
destHeight := source.Height * printerPixelsPerInch_Y div Screen.PixelsPerInch;
Stretch(destWidth, destHeight, rfLanczos3, 0, source, dest);
Printer.BeginDoc;
try
Printer.Canvas.Draw(printerLeftMargin, printerTopMargin, dest);
Printer.EndDoc;
except
Printer.Abort;
raise;
end;
finally
dest.Free;
end;
end;
procedure TFormMain.Button1Click(Sender: TObject);
begin
if not PrinterSetupDialog.Execute then
exit;
PrintGraphic(Image1.Picture.Graphic);
end;
IIRC (I don't have Delphi in front of me to check right now), TPrinter has a PixelsPerInch or similar property that has to be set so printing is at the correct resolution. The default value does not match the screen, which is why the image gets printed so small. Most newbies to using TPrinterdon't know to set the property.

Resources