Delphi: How to print multiple images in one page using Printer? - delphi

I cannot seem to figure out how to print multiple images in one page using Printer,
I want to display images side by side like this:
But the problem is the images always display in full page like this:
I have this code:
procedure TForm1.Button1Click(Sender: TObject);
var
MyRect: TRect;
scale: Double;
Bitmap : TBitmap;
i: integer;
begin
try
Bitmap := TBitmap.Create;
Bitmap.Width := Image1.Picture.Width;
Bitmap.Height := Image1.Picture.Height;
Bitmap.Canvas.Draw(0,0,Image1.Picture.Graphic);
if PrintDialog1.Execute then
begin
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) / Screen.PixelsPerInch
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) / Screen.pixelsperinch;
Printer.BeginDoc;
MyRect := Rect(0,0, trunc(Bitmap.Width * scale), trunc(Bitmap.Height * scale));
Printer.Canvas.StretchDraw(MyRect, Bitmap);
Printer.EndDoc;
end;
finally
Bitmap.Free;
end;
end;
I want to the printer to printout images side by side, how can I accomplish that?
Can any one help me please?
Update:
procedure TForm1.Button1Click(Sender: TObject);
var
MyRect: TRect;
scale: Double;
Bitmap : TBitmap;
i, x, y, width, height, img_count: integer;
begin
Bitmap := TBitmap.Create;
x := 0;
y := 0;
img_count := 3;
try
begin
Bitmap.Width := Image1.Picture.Width;
Bitmap.Height := Image1.Picture.Height;
Bitmap.Canvas.Draw(0,0,Image1.Picture.Graphic);
if PrintDialog1.Execute then
begin
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) / Screen.PixelsPerInch
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) / Screen.pixelsperinch;
Printer.BeginDoc;
for i := 1 to img_count do
begin
width := trunc(Bitmap.Width * scale / img_count);
height := trunc(Bitmap.Height * scale / img_count);
MyRect := Rect(x, y, width, height);
Printer.Canvas.StretchDraw(MyRect, Bitmap);
x := x + width;
end;
Printer.EndDoc;
end;
end;
finally
Bitmap.Free;
end;
end;
Now it displays the images like sticking at each other, an I want them to display with a little margin between them:
This is when I add margins:
This is without margins:

You have to halfway understand your code, then it will all become obvious. Canvas and Rect are literally just that - and if you max your rectangle out by scale you'll never put two pictures side by side. Cut the values in half and use understand the parameters of functions - I'll use more variables to make it more obvious why your approach is very easy to solve:
var
x, y, width, height: Integer;
...
begin
...
Printer.BeginDoc;
x:= 0; // Start on top left
y:= 0;
width:= trunc( Bitmap1.Width* scale/ 2 ); // Half of the size
height:= trunc( Bitmap1.Height* scale/ 2 )
Printer.Canvas.StretchDraw( Rect( x, y, width, height ), Bitmap1 );
x:= width; // Continue after picture on the right side
width:= trunc( Bitmap2.Width* scale/ 2 ); // Again half of the size
height:= trunc( Bitmap2.Height* scale/ 2 )
Printer.Canvas.StretchDraw( Rect( x, y, width, height ), Bitmap2 );
Printer.EndDoc;
This example presumes Bitmap1 and Bitmap2 have similar dimensions.

Related

How do I draw with scanlines without loading an image first?

I'm trying to do the following:
bmp := TBitmap.Create;
bmp.Width := FWidth;
bmp.Height := FHeight;
for y := 0 to FHeight - 1 do
begin
sl := bmp.ScanLine[y];
for x := 0 to FWidth - 1 do
begin
//draw to the scanline, one pixel at a time
end;
end;
//display the image
bmp.Free;
Unfortunately, what I end up with is an image that's completely white, except for the bottom line, which is colored appropriately. A bit of debugging shows that each time I access the ScanLine property, it's calling TBitmap.FreeImage, and going into the if (FHandle <> 0) and (FHandle <> FDIBHandle) then block, which resets the whole image, so only the changes to the last line actually take.
In every demo I've seen so far using TBitmap.ScanLine, they start out by loading an image. (Apparently this sets up various handles correctly so that this doesn't end up happening?) But I'm not trying to load an image and work on it; I'm trying to capture image data from a camera.
How can I set up the bitmap so that I can draw to the scanlines without having to load an image first?
You should set the PixelFormat explicitly before starting to draw. For instance,
procedure TForm1.FormPaint(Sender: TObject);
var
bm: TBitmap;
y: Integer;
sl: PRGBQuad;
x: Integer;
begin
bm := TBitmap.Create;
try
bm.SetSize(1024, 1024);
bm.PixelFormat := pf32bit;
for y := 0 to bm.Height - 1 do
begin
sl := bm.ScanLine[y];
for x := 0 to bm.Width - 1 do
begin
sl.rgbBlue := 255 * x div bm.Width;
sl.rgbRed := 255 * y div bm.Height;
sl.rgbGreen := 255 * x div bm.Width;
inc(sl);
end;
end;
Canvas.Draw(0, 0, bm);
finally
bm.Free;
end;
end;

Joining image - Delphi

How do I merge two images with Delphi . I thought of using CopyRect but could not implement it. How do I attach a JPG image with the bitmap rectangle-shaped . I need to center the image within the rectangle , how?
procedure TForm1.Button1Click(Sender: TObject);
var
bmp, bmp1: TBitmap;
jpg: TJpegImage;
scale: Double;
begin
if opendialog1.execute then
begin
jpg := TJpegImage.Create;
try
jpg.Loadfromfile(opendialog1.filename);
if jpg.Height > jpg.Width then
scale := 98 / jpg.Height
else
scale := 98 / jpg.Width;
bmp := TBitmap.Create;
try
{Create thumbnail bitmap, keep pictures aspect ratio}
bmp.Width := Round(jpg.Width * scale);
bmp.Height:= Round(jpg.Height * scale);
//BPM1
bmp1 := TBitmap.Create;
bmp1.SetSize(98, 98);
bmp1.Canvas.Brush.Color := RGB(243,243,243);
bmp1.Canvas.Pen.Style:= psClear;
bmp1.Canvas.Rectangle(0, 0, 98, 98);
bmp.Canvas.StretchDraw(bmp.Canvas.Cliprect, jpg);
{Draw thumbnail as control}
//Juntar os 2
self.Canvas.Draw(10, 10, bmp1);
self.Canvas.Draw(10, 10, bmp);
Logo.Picture.Assign(bmp);
{Convert back to JPEG and save to file}
jpg.Assign(bmp);
jpg.SaveToFile(
ChangeFileext(opendialog1.filename, '_thumb.JPG')
);
finally
bmp.free;
bmp1.free;
end;
finally
jpg.free;
end;
end;
end;
You should not be using bmp.Canvas.ClipRect as the destination rectangle for your StretchDraw() call. Specify the actual rectangle you want, which in this case is the full dimensions of bmp.
If you want a border all the way around the scaled image but keep the 98x98 dimensions of the final image, like your example JPG shows, then your scale needs to be based on a value less than 98px. For instance, to have a border at least 10x wide, reduce your scale by 20px (10px on each side). If you don't reduce your scale, the width and/or height of the scaled image will be exactly 98px, which is not what your example JPG shows.
When you go to draw bmp on top of bmp1, center bmp by subtracting its dimensions from bmp1's dimensions and dividing the result in half.
And do not draw on the Form's Canvas from outside of the Form's OnPaint event. If you want the Form to display an image, use the TImage component for that.
Try something more like this:
procedure TForm1.Button1Click(Sender: TObject);
var
bmp, bmp1: TBitmap;
jpg: TJPEGImage;
scale: Double;
begin
if OpenDialog1.Execute then
begin
jpg := TJPEGImage.Create;
try
jpg.LoadFromFile(OpenDialog1.FileName);
if jpg.Height > jpg.Width then
scale := 78 / jpg.Height
else
scale := 78 / jpg.Width;
bmp := TBitmap.Create;
try
{Create thumbnail bitmap, keep pictures aspect ratio}
bmp.SetSize(Round(jpg.Width * scale), Round(jpg.Height * scale));
bmp.Canvas.StretchDraw(Rect(0, 0, bmp.Width, bmp.Height), jpg);
//BPM1
bmp1 := TBitmap.Create;
try
bmp1.SetSize(98, 98);
bmp1.Canvas.Brush.Color := RGB(243, 243, 243);
bmp1.Canvas.Pen.Style := psClear;
bmp1.Canvas.Rectangle(0, 0, bmp1.Width, bmp1.Height);
bmp1.Canvas.Draw((bmp1.Width - bmp.Width) div 2, (bmp1.Height - bmp.Height) div 2, bmp);
{Draw thumbnail as control}
//Juntar os 2
Image1.Picture.Assign(bmp1);
finally
bmp1.free;
end;
Logo.Picture.Assign(bmp);
{Convert back to JPEG and save to file}
jpg.Assign(bmp);
jpg.SaveToFile(ChangeFileExt(OpenDialog1.FileName, '_thumb.JPG'));
finally
bmp.free;
end;
finally
jpg.free;
end;
end;
end;
I was stirring until I fulfilled what he wanted. The only thing I could not , was to change the image background , I would put in the empty spot RGB ( 0,0,0 ) , did the tests, but failed.
procedure TForm1.Button2Click(Sender: TObject);
var
bmp: TBitmap;
jpg: TJPEGImage;
scale: Double;
widthL, HeightL, pt1, pt2, pt3, pt4: integer;
verdd : boolean;
begin
if OpenDialog1.Execute then
begin
try
jpg := TJPEGImage.Create;
verdd := false;
try
//Dimensões
widthL := 98;
HeightL := 98;
jpg.LoadFromFile(OpenDialog1.FileName);
if (jpg.Height >= jpg.Width) AND (HeightL <= jpg.Height) then begin
scale := widthL / jpg.Height;
end else if (jpg.Height <= jpg.Width) AND (widthL <= jpg.Width) then begin
scale := HeightL / jpg.Width;
end else begin
verdd := true;
end;
bmp := TBitmap.Create;
try
{Create thumbnail bitmap, keep pictures aspect ratio}
bmp.SetSize( widthL,HeightL);
if not verdd then begin
pt1 := (widthL - Round(jpg.Width * scale)) div 2;
pt2 := (HeightL - Round(jpg.Height * scale)) div 2;
pt3 := Round(jpg.Width * scale) + pt1;
pt4 := Round(jpg.Height * scale) + pt2;
bmp.Canvas.StretchDraw(Rect(pt1, pt2, pt3, pt4), jpg);
end else begin
pt1 := (widthL - jpg.Width) div 2;
pt2 := (HeightL - jpg.Height) div 2;
pt3 := jpg.Width + pt1;
pt4 := jpg.Height + pt2;
bmp.Canvas.StretchDraw(Rect(pt1, pt2, pt3, pt4), jpg);
end;
Logo.Picture.Assign(bmp);
{Convert back to JPEG and save to file}
jpg.Assign(bmp);
jpg.SaveToFile(ChangeFileExt(OpenDialog1.FileName, '_thumb.JPG'));
finally
bmp.free;
end;
finally
jpg.free;
end;
except
showMessage('Erro ao carregar imagem'); ///////////////////////////////////
end;
end;
end;

How to save an imagelist as one bitmap like a tilesheet?

I have an image list containing several bitmaps which I would like to save together as one single bitmap, but I need it saving just like how a spritesheet or tilesheet is drawn in 2d and rpg games etc.
Typically the tilesheet is drawn with several images across (in a row), so for example if I wanted a maximum of 6 images per row, it will only draw 6, with further images been drawn underneath in a new row.
I can save it in one single row like so:
var
CurrentFrame: Integer;
StripWidth: Integer;
Strip: TBitmap;
Bmp: TBitmap;
I: Integer;
begin
if SaveDialog.Execute then
begin
StripWidth := ImageList1.Width * ImageList1.Count - ImageList1.Width;
CurrentFrame := - ImageList1.Width;
Strip := TBitmap.Create;
try
Strip.SetSize(StripWidth, ImageList1.Height);
Bmp := TBitmap.Create;
try
for I := 0 to ImageList1.Count - 1 do
begin
CurrentFrame := CurrentFrame + ImageList1.Width;
ImageList1.GetImage(I, Bmp);
Strip.Canvas.Draw(CurrentFrame, 0, Bmp);
end;
finally
Bmp.Free;
end;
Strip.SaveToFile(SaveDialog.FileName);
finally
Strip.Free;
end;
end;
end;
So imagine the result for the above is:
The result I want is something like:
So the above would have considered in the procedure/ function a parameter to allow only 3 images per row as an example.
How do I export all images from an imagelist into one single bitmap, allowing only x amount if images to be drawn horizontally before creating a new row?
Thanks.
EDIT
Thanks to David's answer, I put together these procedures:
procedure DrawImageOnSheet(Images: TImageList; Sheet: TBitmap;
ImageIndex, X, Y: Integer);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Images.GetBitmap(ImageIndex, Bitmap);
Sheet.Canvas.Draw(X, Y, Bitmap);
finally
Bitmap.Free;
end;
end;
procedure SaveImageListAsSheet(Images: TImageList; FileName: string;
NumberOfColumns: Integer);
var
Sheet: TBitmap;
nImage: Integer;
nCol: Integer;
nRow: Integer;
nToDraw: Integer;
nRemaining: Integer;
ImageIndex: Integer;
X, Y: Integer;
I: Integer;
begin
Sheet := TBitmap.Create;
try
nImage := Images.Count;
nCol := NumberOfColumns;
nRow := (nImage + nCol - 1) div nCol;
Sheet.Height := nRow * Images.Height;
Sheet.Width := nCol * Images.Width;
nRemaining := nImage;
ImageIndex := 0;
Y := 0;
while nRemaining > 0 do
begin
nToDraw := Math.Min(nRemaining, nCol);
X := 0;
for I := 0 to nToDraw - 1 do
begin
DrawImageOnSheet(Images, Sheet, ImageIndex, X, Y);
Inc(ImageIndex);
Inc(X, Images.Width);
end;
Inc(Y, Images.Height);
Dec(nRemaining, nToDraw);
end;
Sheet.SaveToFile(FileName);
finally
Sheet.Free;
end;
end;
According to clarification from the comments, you are struggling with the counting of the images, the organisation of the rows/columns and so on. So, let's assume you already have this function which draws image ImageIndex to the output bitmap at a position of X, Y.
procedure Draw(ImageIndex, X, Y: Integer);
Let's also assume that the images have dimensions given by ImageWidth and ImageHeight. Finally, there are nImage images and you want to have nCol images per column.
So, first of all, how many rows do you need?
nRow := (nImage + nCol - 1) div nCol;
Now you can set the size of the output bitmap. Its width is nCol * ImageWidth and its height is nRow * ImageHeight.
Now to draw the images.
nRemaining := nImage;
ImageIndex := 0;
Y := 0;
while nRemaining > 0 do
begin
nToDraw := Math.Min(nRemaining, nCol);
X := 0;
for i := 0 to nToDraw - 1 do
begin
Draw(ImageIndex, X, Y);
inc(ImageIndex);
inc(X, ImageWidth);
end;
inc(Y, ImageHeight);
dec(nRemaining, nToDraw);
end;

.dat file loading routine

Okay so i have an old 8-bit game that loads six .dat files for different size lightmaps.
Something along the lines of this:
const
MAX_LIGHT_COUNT = 5;
LFiles : array[0..MAX_LIGHT_COUNT] of string = (
'.\L00.dat',
'.\L01.dat',
'.\L02.dat',
'.\L03.dat',
'.\L04.dat',
'.\L05.dat'
);
type
TLights = record
Width : Integer;
Height : Integer;
PDark : PByte;
end;
var
LightArr: array[0..MAX_LIGHT_COUNT] of TLights;
Procedure InitializeLight();
var
PreviousSize: Integer;
i: Integer;
fHandle: Integer;
Width, Height: Integer;
begin
PreviousSize := 0;
for i := 0 to MAX_LIGHT_COUNT do
begin
if FileExists(LFiles[i]) then
begin
fHandle := FileOpen(LFiles[i], fmOpenRead or fmShareDenyNone);
FileRead(fHandle, Width, SizeOf(Integer));
FileRead(fHandle, Height, SizeOf(Integer));
LightArr[i].Width := Width;
LightArr[i].Height := Height;
LightArr[i].PDark := AllocMem(Width * Height + 8);
if PreviousSize < Width * Height then
FileRead(fHandle, LightArr[i].PDark^, Width * Height);
PreviousSize := Width * Height;
FileClose(fHandle);
end;
end;
end;
Now i need to create an editor for some new .dat files. I had a go basically reversing whats there and using FillChar to populate the array which just ended in a square instead of the lightmaps cirlce look which makes sense, think i am missing something very important with manipulating X, Y.
Something along the lines of:
PDark := #LightArr[i].PDark;
for Y := 0 to Height - 1 do
begin
for X := 0 to Width - 1 do
begin
// Do something with PDark
end;
end;
Which would then give me that circle look.
Download: LFiles.rar if necessary.
EDIT: Sorry Jerry if it come across that way, i wasn't expecting people to write the code for me just wanted to make sure i was going in the right direction and maybe get a little help and some other stuff to try out.
NOTE: In case people get confused the attached download isn't Source files its the .dat files the game loads. Uploaded in case people wanted to see what my binary files look like compared to theirs. Basically to compare output see if on right track ect.. I dunno lol.
This is what i tried but its missing some kind of manipulation code for the circle:
for i := 0 to MAX_LIGHT_COUNT do
begin
if FileExists(LFiles[i]) then
fHandle := FileOpen(LFiles[i], fmOpenWrite or fmShareDenyNone)
else fHandle := FileCreate(LFiles[i]);
if fHandle > 0 then
begin
Width := 196;
Height := 176;
FileWrite(fHandle, Width, SizeOf(Integer));
FileWrite(fHandle, Height, SizeOf(Integer));
LightArr[i].Width := Width;
LightArr[i].Height := Height;
LightArr[i].Fog := AllocMem(Width * Height + 8);
FillChar(LightArr[i].Fog^, LightArr[i].Width * LightArr[i].Height + 8, Width * Height);
FileWrite(fHandle, LightArr[i].Fog^, Width * Height);
FileClose(fHandle);
end;
end;
Thanks for reading.

Change orientation of a shape

I would like to know if there is a way to change the orientation of a TShape thus instead of a square , i would like to rotate it to look like a diamond..
If not a way with TShape, how could this be done?
A Delphi TShape is nothing more than drawing a bunch of vector graphics.
You can "rotate" the X/Y coordinates themselves with a 2-D transformation matrix. Computer Graphics 101:
http://www.cs.uic.edu/~jbell/CourseNotes/ComputerGraphics/2DTransforms.html
http://www.willamette.edu/~gorr/classes/GeneralGraphics/Transforms/transforms2d.htm
A TShape itself cannot be rotated. But you can use a TPaintBox to draw your own graphics anyway you wish, it is just a matter of mathematically plotting the points to draw between. For example:
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
Points: array[0..3] of TPoint;
W, H: Integer;
begin
W := PaintBox1.Width;
H := PaintBox1.Height;
Points[0].X := W div 2;
Points[0].Y := 0;
Points[1].X := W;
Points[1].Y := H div 2;
Points[2].X := Points[0].X;
Points[2].Y := H;
Points[3].X := 0;
Points[3].Y := Points[1].Y;
PaintBox1.Canvas.Brush.Color := clBtnFace;
PaintBox1.Canvas.FillRect(Rect(0, 0, W, H));
PaintBox1.Canvas.Brush.Color := clBlue;
PaintBox1.Canvas.Pen.Color := clBlack;
PaintBox1.Canvas.Pen.Width := 1;
PaintBox1.Canvas.Polygon(Points);
end;

Resources