[SOLVED] How to set DPI resolution when saving a file? - PNG/TIFF/JPEG

[toslan]

Hi. Anybody knows how to embed DPI resolution (or print dimensions as alternative) into the file using TBGRABitmap.SaveToFile method? I tried to save png, jpg and tif files. JPG is always saved with 96x96 dpi, TIFF - 72x72 dpi (at least Windows reports these values). PNG has no DPI information in the saved file.

[toslan]

I got solution for PNG writer. Based on this, but without changing and recompiling Lazarus libraries. Still need for TIFF and JPEG formats. Any idea?
If anybody interested this is small trick that saves DPI with png file:
1. make inherited PNG writer:

Code: Pascal  [Select][+][-]

1. interface
2. uses
3.   FPWritePNG,PNGcomn,FPImgCmn,FPWriteJPEG,
4. type
5.   TFPMyWriterPNG = class (TFPWriterPNG)
6. protected
7.   procedure WriteIDAT; override;
8. end;
9.  
10. implementation
11. procedure TFPMyWriterPNG.WriteIDAT;
12. var
13.   PPUX,PPUY: DWord; // Pixels per unit along X and Y axis
14.   chead : TChunkHeader;
15.   chCode:TChunkCode='pHYs';
16.   c : longword;
17.   dat:array[0..8] of Byte;
18. begin
19.   PPUX:=23622; // Put here pixels amount per Unit
20.   PPUY:=23622; // E.g. 11811 for 300 DPI, 23622 for 600 DPI etc.
21.   dat[8] := 1; // Unit of Length is 1m
22.   chead.CType := chCode;
23.   c := CalculateCRC (All1Bits,chCode,4);
24.   {$IFDEF ENDIAN_LITTLE}
25.   PDWORD(@dat[0])^ := swap(PPUX);
26.   PDWORD(@dat[4])^ := swap(PPUY);
27.   chead.CLength := swap (9);
28.   c := CalculateCRC (c, dat, 9);
29.   c := swap(c xor All1Bits);
30.   {$ELSE}
31.   PDWORD(@dat[0])^ := PPUX;
32.   PDWORD(@dat[4])^ := PPUY;
33.   chead.CLength:=9;
34.   c := CalculateCRC (c, dat, 9);
35.   c := c xor All1Bits;
36.   {$ENDIF}
37.   with TheStream do
38.     begin
39.     Write (chead, sizeof(chead));
40.     Write (dat, 9);
41.     Write (c, sizeof(c));
42.     end;
43.   inherited;
44. end;
45.  

2. Use this writer to save file:

Code: Pascal  [Select][+][-]

1. procedure TMainForm.SavePicture(Sender: TObject);
2.   var bm:TBGRABitmap;
3.     wrt:TFPMyWriterPNG;
4. begin
5.   bm:=TBGRABitmap.Create(CliendWidth,ClientHeight);
6. //.. make some painting on bitmap
7.   wrt:=TFPMyWriterPNG.create;
8.   wrt.UseAlpha := true;
9.   bm.SaveToFile('myfile.png',wrt);
10.   wrt.free;
11.   bm.Free;
12.   end;
13. end;
14.  

[wp]

Look at attached unit. It is based on the fpsimages unit of fpspreadsheet which extracts dpi from meta data and was rewritten here for patching the corresponding locations in the file with the new dpi data. Note that in some file formats records for dpi values are optional - my unit does not add such records, it works only when dpi values are already present.

Usage: Load the image into a memory stream, then call the corresponding SetDpi_XXX function where XXX is the file format. Provide the new dpix and dpiy as parameters. The function returns true if the file could be patched, false if the file format is defective or if the dpi record is missing. If SetDpi_XXX was successful write the stream back to file.

Code: Pascal  [Select][+][-]

1. procedure TForm1.Button2Click(Sender: TObject);
2. const
3.   NEW_DPI_X = 100;
4.   NEW_DPI_Y = 100;
5. var
6.   imgStream: TMemoryStream;
7.   ext: String;
8.   fn: String;
9.   ok: Boolean;
10. begin
11.   ext := ExtractFileExt(FFileName);
12.   fn := ChangeFileExt(FFilename, '') + '_patched' + ext;
13.   imgStream := TMemoryStream.Create;
14.   try
15.     ok := false;
16.     imgStream.LoadFromFile(FFilename);
17.     ext := Lowercase(ext);
18.     if ext = '.bmp' then
19.       ok := SetDPI_BMP(imgStream, NEW_DPI_X, NEW_DPI_Y)
20.     else if (ext = '.tiff') or (ext = '.tif') then
21.       ok := SetDPI_TIF(imgStream, NEW_DPI_X, NEW_DPI_Y)
22.     else if (ext ='.jpg') or (ext='jpeg') then
23.       ok := SetDPI_JPG(imgStream, NEW_DPI_X, NEW_DPI_Y)
24.     else if (ext = '.png') then
25.       ok := SetDPI_PNG(imgStream, NEW_DPI_X, NEW_DPI_Y)
26.     else if (ext = '.pcx') then
27.       ok := SetDPI_PCX(imgStream, NEW_DPI_X, NEW_DPI_Y)
28.     else begin
29.       ShowMessage('Image type not supported');
30.       exit;
31.     end;
32.     if ok then begin
33.       imgStream.SaveToFile(fn);
34.       ShowMessage('Done.');
35.     end else
36.       ShowMessage('File coult not be patched.');
37.   finally
38.     imgStream.Free;
39.   end;
40. end;

[toslan]

Thahks a lot, wp.
I used your functions SetDpi_TIF and SetDpi_JPG in overridden InternalWrite method of Writers:

Code: Pascal  [Select][+][-]

1.   TFPMyWriterTiff = class(TFPWriterTiff)
2.   protected
3.     procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
4.   end;

Code: Pascal  [Select][+][-]

1. procedure TFPMyWriterTiff.InternalWrite(Str: TStream; Img: TFPCustomImage);
2. begin
3.   inherited;
4.   Str.Position:=0;
5.   SetDpi_TIF(Str, fResol, fResol);
6. end;

And then used them to save BGRA Bitmap in the file:

Code: Pascal  [Select][+][-]

1. procedure TMainForm.SavePicButClick(Sender: TObject);
2. var
3.   bm:TBGRABitmap;
4.   wrtif:TFPMyWriterTIFF;
5. begin
6.   bm:=TBGRABitmap.Create(ClientWidth,ClientHeight);
7. //.. make some painting on bitmap
8.   wrtif:=TFPMyWriterTIFF.create;
9.   bm.SaveToFile('TiffPicture.tif',wrtif);
10.   wrtif.free;
11.   bm.free;
12. end;

Same approach for JPEG. I left my method for PNG because it is shorter. Everything works fine, DPI stored in files.

[wp]

Hmm... If you want to intercept the tiff writer my functions are overkill. The FP-Image readers/writers have builtin meta-data support. Studying the tiff writer code I found that it writes the dpi value which it finds in the Extra property of the image:

Code: Pascal  [Select][+][-]

1. procedure TTiffIFD.ReadFPImgExtras(Src: TFPCustomImage);
2. begin
3.  ...
4.   ResolutionUnit:=StrToIntDef(Src.Extra[TiffResolutionUnit],2);
5.   if not (ResolutionUnit in [1..3]) then
6.     ResolutionUnit:=2;
7.   XResolution:=StrToTiffRationalDef(Src.Extra[TiffXResolution],TiffRational72);
8.   YResolution:=StrToTiffRationalDef(Src.Extra[TiffYResolution],TiffRational72);  
9. ...

This means that all you have to do is to change the TiffXResolution and TiffYResolution fields in the property Extra of the TFPCustomImage. Do this in your own writer's InternalWrite method at the beginning. Note that the values must be provided as strings and the resolutions must be fractions:

Code: Pascal  [Select][+][-]

1.     procedure TFPMyWriterTiff.InternalWrite(Str: TStream; Img: TFPCustomImage);
2.     begin
3.       Img.Extras[TiffXResolution] := '150/1';
4.       Img.Extras[TiffYResolution] := '150/1';
5.       Img.Extras[TiffResolutionUnit] := '2';   // 2 = inch
6.       inherited;
7.     end;

Please try this idea - I did not test it.

As far as I could see, however, not all writers respect the meta data provided by the Extra field.

[toslan]

I could not get this method working because in my case the picture is created by the program and initially there is no Extras at all. I checked Img.ExtraCount and got 0. RemoveExtra method exists but no AddExtra. So I would stick to SetDpi_TIF function unless you have another idea.
Thanks again.

[wp]

No, it is working. Just a typo: use "Extra" instead of "Extras" - sorry. And it's even simpler. Since TBGRABitmap inherits from TFPCustomImage it already has the "Extra" property. So, all you have to do is to set the resolution in the BGRABitmap before writing, and the ORIGINAL tiff writer will take care of the rest - no need for a special adapted writer.

Code: Pascal  [Select][+][-]

1. procedure TForm1.Button3Click(Sender: TObject);
2. var
3.   bm: TBGRABitmap;
4. begin
5.   bm := TBGRABitmap.Create(Image1.Picture.Bitmap);
6.   try
7.     bm.Extra['TiffXResolution'] := '300/1';
8.     bm.Extra['TiffYResolution'] := '300/1';
9.     bm.Extra['TiffResolutionUnit'] := '2';
10.     bm.SaveToFile('TiffPicture.tif');  
11.   finally
12.     bm.Free;
13.   end;
14. end;

If the source bitmap is a standard TBitmap instead of a TBGRABitmap convert it to a LazIntfImage which inherits from TFPCustomBitmap again, and you can do the same:

Code: Pascal  [Select][+][-]

1. uses
2.   IntfGraphics;
3. ...
4. var
5.   intImg: TLazIntfImage;
6. ...
7.   intfimg := image1.Picture.Bitmap.CreateIntfImage;
8.   try
9.     intfimg.Extra['TiffXResolution'] := '600/1';
10.     intfimg.Extra['TiffYResolution'] := '600/1';
11.     intfimg.Extra['TiffResolutionUnit'] := '2';
12.     intfimg.SaveToFile('TiffPicture1.tif');
13.   finally
14.     intfimg.Free;
15.   end;

Unfortunately, it seems to me that TIFF seems to be the only file format which supports the built-in metadata "Extra". So, you still have to handle the jpeg and png cases separately. The jpeg writer has an internal field FInfo in which fields for x and y resolution are available, but FInfo is private and cannot be reached by a derived writer. And the original png writer does not write the PHYS chunk at all (which contains the dpi values) - but your solution correctly implements it. An idea for improvement: extract the dpi from the "Extra" of the FPCustomImage to avoid hard-coding the dpi in the writer.

[toslan]

Indeed, it works. Yes I noticed the typo. But when I tried to get the whole list of Extras -

Code: Pascal  [Select][+][-]

1. writeln(Img.ExtraCount);
2. for m:=0 to Img.ExtraCount-1 do writeln(Img.ExtraKey[m]+' > '+Img.ExtraValue[m]);

I got 0 output. I still do not understand why. This is all my over curiosity. Anyway the last is the simplest variant and it is working.
As to PNG, I cannot extract DPI from the picture because as I said the picture is created by the program from scratch and it has no DPI initially. When I create file for printing I set dpi by users' choice and after that it has no meaning again.
Thanks a lot.

[wp]

This image probably does not have metadata. Try to read the attached image, and you'll get some.

Code: Pascal  [Select][+][-]

1. var
2.   img: TLazIntfImage;
3.   I: Integer;
4. begin
5.     img := TLazIntfImage.Create(0,0);
6.     try
7.       img.LoadFromFile(AFilename);
8.       Memo1.Lines.Clear;
9.       for i:=0 to img.ExtraCount-1 do begin
10.         Memo1.Lines.Add(img.ExtraKey[i] + '=' + img.ExtraValue[i]);
11.       end;
12.     finally
13.       img.Free;
14.     end;  

See the "TiffXXX" declarations in unit FPTiffCmn for a list of supported tag names.

Unfortunately metadata support by fcl-image is very rudimentary. If you need more you can have a look at my exif library at https://sourceforge.net/p/lazarus-ccr/svn/HEAD/tree/components/fpexif/

[toslan]

wp, this is interesting project but maybe too broad for my task. What do you think of including PNG format in it since eXIf chunk has been introduced?