Add stretched image to ImageList in Delphi - delphi

I have a table contains Image in a Picture field and I am going to put them into an ImageList.
Here is the code:
ImageList.Clear;
ItemsDts.First;
ImageBitmap:= TBitmap.Create;
try
while not ItemsDts.Eof do
begin
if not ItemsDtsPicture.IsNull then
begin
ItemsDtsPicture.SaveToFile(TempFileBitmap);
ImageBitmap.LoadFromFile(TempFileBitmap);
ImageList.Add(ImageBitmap, nil);
end;
ItemsDts.Next;
end;
finally
ImageBitmap.Free;
end;
But I have some problem for images with difference size from ImageList size.
Update:
My problem is that when adding Image larger than ImageList size (32 * 32), for example 100 * 150 It does not appear correctly in a component connected to ImageList (for example in a ListView).
It seems newly added image is not stretched but is Croped. I want new image to be stretched as in ImageList Editor.

I don't know if ImageList provides a property to automatically stretch the image. Unless someone finds some built-in, you can always stretch the image yourself before adding it to the ImageList. And while you're at it, stop using the file-on-disk: use a TMemoryStream instead. Something like this:
var StretchedBMP: TBitmap;
MS: TMemoryStream;
ImageList.Clear;
ItemsDts.First;
StretchedBMP := TBitmap.Create;
try
// Prepare the stretched bmp's size
StretchedBMP.Width := ImageList.Width;
StretchedBMP.Height := ImageList.Height;
// Prepare the memory stream
MS := TMemoryStream.Create;
try
ImageBitmap:= TBitmap.Create;
try
while not ItemsDts.Eof do
begin
if not ItemsDtsPicture.IsNull then
begin
MS.Size := 0;
ItemsDtsPicture.SaveToStream(MS);
MS.Position := 0;
ImageBitmap.LoadFromStream(MS);
// Stretch the image
StretchedBMP.Canvas.StretchDraw(Rect(0, 0, StretchedBmp.Width-1, StretchedBmp.Height-1), ImageBitmap);
ImageList.Add(StretchedBmp, nil);
end;
ItemsDts.Next;
end;
finally MS.Free;
end;
finally StretchedBMP.Free;
end;
finally
ImageBitmap.Free;
end;
PS: I edited your code in the browser's window. I can't guarantee it compiles, but if it doesn't, it should be easy to fix.

Related

Clear timage.canvas in delphi 7

How to clear timage canvas to avoid duplicate image when changing input size? Why nil command doesn't work?
This is my code
begin
image1.Canvas := nil;
image1.Canvas.Pen.Color := clRed;
image1.Canvas.Brush.Color := clBlue;
image1.canvas.rectangle(10,10,vwpj,vwlb);
end;
You can't assign Nil or any value to Canvas, Canvas is a property for read only, so you need to remove the first line and then draw on the TImage canvas:
Image1.Canvas.Pen.Color := clRed;
Image1.Canvas.Brush.Color := clBlue;
Image1.canvas.rectangle(0,0,Image1.Height,Image1.Width);
Edit:
You have to set the image to default every time you draw on it's canvas:
Procedure:
Procedure TForm1.Default(Image: TImage);
begin
Image.Canvas.Pen.Color := clBtnFace;
Image.Canvas.Brush.Color := clBtnFace;
Image.Canvas.FillRect(Rect(0,0,Image.Height,Image.Width));
end;
Then call it as:
procedure TForm1.Button1Click(Sender: TObject);
begin
Default(Image1);
Image1.Canvas.Pen.Color := clRed;
Image1.Canvas.Brush.Color := clBlue;
Image1.canvas.rectangle(0,0,Image1.Height,Image1.Width);
end;
From what you have written and tried to explain in your many previous edits.
This is a possible solution to your problem.
Requirements:
Add four TEdit components to your form.
Add one TButton.
And one TImage.
Code:
var
Xorigin,Yorigin,vwpj,vwlb:integer;
....
begin
vwpj := strtoint(vwpjEdit.text);
vwlb := strtoint(vwlbEdit.text);
Xorigin := strtoint(XoriginEdit.Text);
Yorigin := strtoint(YoriginEdit.Text);
// You have to wipe the canvas with a base color,
image1.Canvas.Brush.Color := clwhite;
image1.Canvas.FillRect(rect(0,0,image1.Width,image1.height));
image1.Canvas.Pen.Color := clRed;
image1.Canvas.Brush.Color := clBlue;
image1.Canvas.rectangle(Xorigin,Yorigin,vwlb,vwpj);
end;
Explanation: I understand that you want to draw a rectangle on the Canvas property of a TImage. With the condition of each time you resize the rectangle you want to clear the Canvas (you implied this by assigning nil to canvas which is wrong considering that Canvas is a read only property).
Now the above code does this by filling the canvas with a base color (I chose clwhite) by using the Fillrect() method.
From this you need to understand that there is no such thing as clearing the image, either you delete it (using the free command as you say) and it will be gone and if you want to draw on it again you will need to create it.
the second option is that you fill it with a background color (the base clwhite I chose) or as a third option, resize the image as well.
All what maters is that as long as that image is still there the canvas and what you have drawn on it will remain.
Results of the code above

Loading images to TImageList and Reading them?

I am trying to load jpg into an imagelist by converting the .jpg to a bmp and then saving it to imagelist1.
From top to bottom of the code snip.
The Selectdir works and fileexists parts work. This is used to load in all the Images in a folder.All images are named like so 0.jpg / 1.jpg ect..
I then load the jpg to a tpicture. Set the bmp width /height and load the bmp with same image as jpg , i then add the bmp to the imagelist. And when its done it should show the first image 0.jpg
Two issues, first if i did it like so it would only show a small area (top left) of the bmp
but it was the correct image. I assume this is due to the option crop. which i cant seem to figure out how to make it select center during runtime?
Second, If i put
Imagelist1.width := currentimage.width;
Imagelist1.height := currentimage.height;
Then it shows last image. like Imagelist1.GetBitmap() did not work?
so i assume a fix for either one would be great!
cheers
squills
procedure TForm1.Load1Click(Sender: TObject);
var
openDialog : TOpenDialog;
dir :string;
MyPicture :TPicture;
currentimage :Tbitmap;
image : integer;
clTrans : TColor;
begin
Image := 0 ;
//lets user select a dir
SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate, sdPrompt],SELDIRHELP);
myPicture :=Tpicture.Create;
currentimage := TBitmap.Create;
//keeps adding images as long as the file path exsist.
//thus comic pages should be renumbed to 0-XX
while FileExists(Dir+'\'+inttostr(image)+'.jpg') do
begin
try
MyPicture.LoadFromFile(Dir+'\'+inttostr(image)+'.jpg'); //load image to jpg holder
currentimage.Width := mypicture.Width; //set width same as jpg
currentimage.Height:= mypicture.Height; //set height same as jpg
currentimage.Canvas.Draw(0, 0, myPicture.Graphic); //draw jpg on bmp
clTrans:=currentimage.TransparentColor; //unknown if needed?
//Imagelist1.Width := currentimage.Width;
//imagelist1.Height := currentimage.Height;
Imagelist1.Addmasked(Currentimage,clTrans); //add to imagelist
finally
image := image +1; //add one so it adds next page
end;
end;
ImageList1.GetBitmap(0,zImage1.Bitmap);
mypicture.Free;
currentimage.Free;
end;
You're adding a lot of unnecessary overhead by using the TImage every time.
Try something like this (untested, because I don't have a folder full of images named this way - it compiles, though <g>). You'll need to add Jpeg to your implementation uses clause if it's not already there, of course.
procedure TForm2.Button1Click(Sender: TObject);
var
DirName: string;
begin
DirName := 'D:\Images';
if SelectDirectory('Select Image Path',
'D:\TempFiles',
DirName,
[sdNewUI],
Self) then
LoadImages(DirName);
end;
procedure TForm2.LoadImages(const Dir: string);
var
i: Integer;
CurFileName: string;
JpgIn: TJPEGImage;
BmpOut: TBitmap;
begin
i := 1;
while True do
begin
CurFileName := Format('%s%d.jpg',
[IncludeTrailingPathDelimiter(Dir), i]);
if not FileExists(CurFileName) then
Break;
JpgIn := TJPEGImage.Create;
try
JpgIn.LoadFromFile(CurFileName);
// If you haven't initialized your ImageList width and height, it
// defaults to 16 x 16; we can set it here, if all the images are
// the same dimensions.
if (ImageList1.Count = 0) then
ImageList1.SetSize(JpgIn.Width, JpgIn.Height);
BmpOut := TBitmap.Create;
try
BmpOut.Assign(JpgIn);
ImageList1.Add(BmpOut, nil);
finally
BmpOut.Free;
end;
finally
JpgIn.Free;
end;
Inc(i);
end;
if ImageList1.Count > 0 then
begin
BmpOut := TBitmap.Create;
try
ImageList1.GetBitmap(0, BmpOut);
Image1.Picture.Assign(BmpOut);
finally
BmpOut.Free;
end;
end;
end;

Delphi - Loading JPEG and printing outputs as a black square?

Having some trouble with printing JPEG images via Delphi TCanvas.
Anywhere between 30-50% of the time the JPEG will print out as a black
square rather than as it should. Have tried changing many settings to see
if there was a particular condition under which it would fail to print but
as of the time of writing nothing has worked and the condition still exists - I am not able to tell when the printout may have a black JPEG or when it will print correctly.
Here is the code I am using to print the JPEG to the Canvas.
Screen.Cursor := crHourGlass;
try
// initialize image
//>>imgImage := TImage.Create(Self);
imgImage := TImage.Create(Application);
// load image from file
imgImage.Picture.LoadFromFile(sFileNameAndPath);
// set width and height to that of loaded image
////imgImage.Autosize := true;
////Printer.Orientation := poPortrait;
// Header
Printer.Canvas.Font.Height := MulDiv(GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY), 12, 72);
Printer.Canvas.Font.Name := 'Courier New';
// Determine height and width of 1 printer-character
iDeltaW := Printer.Canvas.TextWidth('X');
iDeltaH := Printer.Canvas.TextHeight('X');
// ------------------------------
// Method #1 - columns and lines
// ------------------------------
// what column to printing from
iFromLeftMargin := iLeft * iDeltaW;
// what line to print from
iFromTopOfPage := iTop * iDeltaH;
// ------------------------------
// Method #2 - pixels
// ------------------------------
iPPW := Printer.PageWidth;
iPPH := Printer.PageHeight;
iIPW := imgImage.Picture.Width;
ePXW := iPPW / iInvImageWidth;
ePXH := iPPH / iInvImageHeight;
//~//iFromLeftMargin := Ceil(iLeft * pxW);
//~//iFromTopOfPage := Ceil(iTop * pxH);
iFromLeftMargin := Ceil(iLeft * ePXW);
iFromTopOfPage := Ceil(iTop * ePXH);
// Set printed bitmap width
iPrintedImageWidth := MulDiv(iPPW, iIPW, iInvImageWidth);
// Set printed bitmap height to maintain aspect ratio
iPrintedImageHeight := imgImage.Picture.Height * iPrintedImageWidth DIV
imgImage.Picture.Width; // maintain aspect ratio of bitmap
Bitmap := TBitmap.Create;
try
Bitmap.Width := imgImage.Picture.Width;
Bitmap.Height := imgImage.Picture.Height;
Bitmap.PixelFormat := pf24bit;
Bitmap.IgnorePalette := False;
// Convert JPEG (GIF, or whatever) to BMP
Bitmap.Canvas.Draw(0, 0, imgImage.Picture.Graphic);
// Print Image
PrintBitmap(Printer.Canvas,
Rect(iFromLeftMargin, iFromTopOfPage,
iFromLeftMargin + iPrintedImageWidth,
iFromTopOfPage + iPrintedImageHeight),
Bitmap);
finally
// free bitmap memory
Bitmap.Free;
end;
// free image memory
imgImage.Free;
finally
Screen.Cursor := crDefault;
end;
If anyone had any ideas it would be much appreciated!
Regards,
James
EDIT: code for the PrintBitmap method below. I have taken the advice of saving the bitmap to disk to view it as it is being generated and the it is never saved as a black square even when the printed output is a black square. I hope this indicated the problem is in the PrintBitmap code below.
procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap);
var
BitmapHeader: pBitmapInfo;
BitmapImage: POINTER;
HeaderSize: DWORD;
ImageSize: DWORD;
begin
GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
GetMem(BitmapHeader, HeaderSize);
GetMem(BitmapImage, ImageSize);
try
GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
StretchDIBits(Canvas.Handle,
DestRect.Left, DestRect.Top, // Destination Origin
DestRect.Right - DestRect.Left, // Destination Width
DestRect.Bottom - DestRect.Top, // Destination Height
0, 0, // Source Origin
Bitmap.Width, Bitmap.Height, // Source Width & Height
BitmapImage,
TBitmapInfo(BitmapHeader^),
DIB_RGB_COLORS,
SRCCOPY);
finally
FreeMem(BitmapHeader);
FreeMem(BitmapImage);
end;
end; {PrintBitmap}
Unfortunately this code was written by someone who no longer works at my company and I am only trying to fix an existing issue.
It's hard to tell with the snippet you posted. You should post some self sufficient working code (compilable and runnable).
There is no local var declaration for instance, no Begindoc/EndDoc.
Now, after adding the local declarations, there is a bunch of compiler warnings for Uninitialized Variables like iTop or iLeft. If those are left with random garbage, it could be that you don't draw where you think you do.
You also assume that you always have a pf24bit format which is not guaranteed at all. As you don't specify if the same JPG can print OK or fail randomly, or if it is with different JPGs that you have problems, format conversion problems cannot be excluded.
I would also suggest that you install one of the free available Image Debug Visualizers, place a break point before PrintBitmap and see if the local Bitmap is correct before printing.
Then let us see what is in the PrintBitmap procedure... Did you try to directly draw on the Printer Canvas?
Update:
The PrintBitmap code seems legit except that it does not check for any return code:
if not GetDIB(...) then
raise [...];
if GDI_ERROR = StretchDIBits(...) then
RaiseLastOSError;
The problem might come from the Printer/Driver.
Did you try with another printer or with another driver?
Also, make sure your printer is ready...

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