Lazarus

Programming => Packages and Libraries => RichMemo => Topic started by: rick2691 on March 10, 2022, 11:17:05 am

Title: Image Resizing
Post by: rick2691 on March 10, 2022, 11:17:05 am
skalogryz,

I have always had a problem with image resizing. What gets generated from a file has the correct picture.width and picture.height, yet what gets produced in the document still shows the same data, but it is larger than its data.

This means that it has been expanded visually, and the picture has lost intelligence (jaggy). In the past it was a smaller expansion than it is now. Now, it is about twice the data dimensions.

Previously I had done a resize, and since it was slight, it was only an ugly result ... but I could let go. Now, with it being bigger, the resize result is beyond ugly.

Here is the curious part ... If I do a mechanical copy/paste, from a graphics app into richmemo, it imports with correct data and real size. Moreover, the metrics have been converted by Windows into a richedit format (a number block). Perhaps all of this is happening because of Windows 11.

But I can't find anything that is making richmemo double the sizing when an import is coded. However, I suspect that it is the old resizing problem, which is currently being exaggerated.

Rick
Title: Re: Image Resizing
Post by: skalogryz on March 10, 2022, 06:48:10 pm
windows specific problems.
if open the file in Wordpad, is it looking as expected or doubled as well?

is there a file sample?
Title: Re: Image Resizing
Post by: rick2691 on March 10, 2022, 08:09:51 pm
Read from file, it is big in WordPad, but it has high resolution.
Read from file, in RichMemo it is big, but a jaggy low resolution.

Copy paste from Graphics app to Wordpad, it is the same size and high resolution.
Copy paste from Graphics app to RichMemo, it is half size and high resolution.

When I print RichMemo to paper it has the same sizing and resolution as the screen.

Formerly it was a third bigger, now it is twice bigger.

Rick
Title: Re: Image Resizing
Post by: rick2691 on March 11, 2022, 09:11:43 pm
This is the code I am using, which you and others developed for me some years back.

Code: Pascal  [Select][+][-]
  1. //================================================================== begin: DIB Codes start
  2.  
  3. { TOleRichEdit }   // DIB: device-independant bitmap
  4.                    // The information to be included in RTF from a Windows
  5.                    // device-independent bitmap is the concatenation of the
  6.                    // BITMAPINFO structure followed by the actual pixel data.
  7.  
  8. function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
  9. begin
  10.   Dec(Alignment);
  11.   Result:= ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
  12.   Result:= Result div 8;
  13. end;
  14.  
  15. procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  16.   Colors: Integer);
  17. var
  18.   DS: TDIBSection;
  19.   Bytes: Integer;
  20. begin
  21.   DS.dsbmih.biSize := 0;
  22.   Bytes:= GetObject(Bitmap, SizeOf(DS), @DS);
  23.   if Bytes=0 then {InvalidBitmap}
  24.   else if (Bytes>=(sizeof(DS.dsbm) + sizeof(DS.dsbmih)))
  25.           and (DS.dsbmih.biSize>=DWORD(sizeof(DS.dsbmih)))
  26.           then BI:= DS.dsbmih
  27.           else begin
  28.                FillChar(BI, sizeof(BI), 0);
  29.                with BI, DS.dsbm do
  30.                     begin
  31.                       biSize:= SizeOf(BI);
  32.                       biWidth:= bmWidth;
  33.                       biHeight:= bmHeight;
  34.                     end;
  35.                end;
  36.   case Colors of
  37.        2: BI.biBitCount:= 1;
  38.        3..16: begin
  39.               BI.biBitCount:= 4;
  40.               BI.biClrUsed:= Colors;
  41.               end;
  42.        17..256: begin
  43.                 BI.biBitCount:= 8;
  44.                 BI.biClrUsed:= Colors;
  45.                 end;
  46.        else
  47.        BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
  48.        end;
  49.   BI.biPlanes:= 1;
  50.   if BI.biClrImportant>BI.biClrUsed then
  51.      BI.biClrImportant:= BI.biClrUsed;
  52.   if BI.biSizeImage=0 then
  53.      BI.biSizeImage:= BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
  54. end;
  55.  
  56. procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
  57.   var ImageSize: DWORD; Colors: Integer);
  58. var
  59.   BI: TBitmapInfoHeader;
  60. begin
  61.   InitializeBitmapInfoHeader(Bitmap, BI, Colors);
  62.   if BI.biBitCount>8 then
  63.      begin
  64.      InfoHeaderSize:= SizeOf(TBitmapInfoHeader);
  65.      if (BI.biCompression and BI_BITFIELDS)<>0 then Inc(InfoHeaderSize, 12);
  66.      end
  67.      else
  68.      if BI.biClrUsed=0
  69.         then InfoHeaderSize:= SizeOf(TBitmapInfoHeader)
  70.              + SizeOf(TRGBQuad) * (1 shl BI.biBitCount)
  71.         else InfoHeaderSize := SizeOf(TBitmapInfoHeader)
  72.              + SizeOf(TRGBQuad) * BI.biClrUsed;
  73.   ImageSize:= BI.biSizeImage;
  74. end;
  75.  
  76. procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
  77.   var ImageSize: DWORD);
  78. begin
  79.   InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
  80. end;
  81.  
  82. function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  83.   var BitmapInfo; var Bits; Colors: Integer): Boolean;
  84. var
  85.   OldPal: HPALETTE;
  86.   DC: HDC;
  87. begin
  88.   InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
  89.   OldPal:= 0;
  90.   DC:= CreateCompatibleDC(0);
  91.   try
  92.     if Palette<>0 then
  93.        begin
  94.        OldPal:= SelectPalette(DC, Palette, False);
  95.        RealizePalette(DC);
  96.        end;
  97.     Result:= GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
  98.                        TBitmapInfo(BitmapInfo), DIB_RGB_COLORS)
  99.                        <>0;
  100.   finally
  101.     if OldPal<>0 then SelectPalette(DC, OldPal, False);
  102.     DeleteDC(DC);
  103.   end;
  104. end;
  105.  
  106. function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
  107. begin
  108.   Result:= InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
  109. end;
  110.  
  111. function BitmapToRTF(pict: TBitmap): string;  // employs the above
  112. var
  113.     bi,bb,rtf: string;
  114.     bis,bbs: Cardinal;
  115.     achar: ShortString;
  116.     hexpict: string;
  117.     I: Integer;
  118. begin
  119.     GetDIBSizes(pict.Handle,bis,bbs);
  120.     SetLength(bi,bis);
  121.     SetLength(bb,bbs);
  122.     GetDIB(pict.Handle,pict.Palette,PChar(bi)^,PChar(bb)^);
  123.     rtf:= '{\rtf1{\pict\dibitmap ';  // ** initiate rtf code **
  124.     SetLength(hexpict,(Length(bb) + Length(bi)) * 2);
  125.     I:= 2;
  126.     for bis:= 1 to Length(bi) do
  127.         begin
  128.         achar:= Format('%x',[Integer(bi[bis])]);
  129.         if Length(achar) = 1 then achar:= '0' + achar;
  130.         hexpict[I-1]:= achar[1];
  131.         hexpict[I]:= achar[2];
  132.         Inc(I,2);
  133.         end;
  134.     for bbs:= 1 to Length(bb) do
  135.         begin
  136.         achar:= Format('%x',[Integer(bb[bbs])]);
  137.         if Length(achar) = 1 then
  138.         achar:= '0' + achar;
  139.         hexpict[I-1]:= achar[1];
  140.         hexpict[I]:= achar[2];
  141.         Inc(I,2);
  142.         end;
  143.     rtf:= rtf + hexpict + ' }}'; // ** complete rtf code **
  144.  
  145.     Result:= rtf;  // ** report rtf code **
  146. end;
  147.  
  148. //=================================================================== End: DIB codes  
  149.  

These are the codes that I use for implementing the above codes:

Code: Pascal  [Select][+][-]
  1. procedure LoadBitmapFromClipboard(Bitmap: TBitmap);
  2. begin
  3.   //if Clipboard.HasFormat(PredefinedClipboardFormat(pcfDelphiBitmap)) then
  4.     //Bitmap.LoadFromClipboardFormat(PredefinedClipboardFormat(pcfDelphiBitmap));
  5.   if Clipboard.HasFormat(PredefinedClipboardFormat(pcfBitmap)) then
  6.      Bitmap.LoadFromClipboardFormat(PredefinedClipboardFormat(pcfBitmap));
  7. end;
  8.  
  9. procedure SaveBitmapToClipboard(Bitmap: TPicture);  // TBitmap);
  10. begin
  11.   Clipboard.Assign(Bitmap);
  12. end;
  13.  
  14. procedure TCmdForm.MnuDiskImageClick(Sender: TObject);
  15. var
  16.   pic: TPicture;
  17.   SS: TStringStream;  // TStringStream;  // TMemoryStream;
  18.   sz: TSize;
  19.   picw, pich: longint;
  20. begin
  21.   pic:= TPicture.Create;
  22.   LoadBitmapFromClipboard(pic.bitmap);
  23.   try SS:= TStringStream.Create(BitmapToRTF(pic.bitmap)); // build RTF mask
  24.          //SS:= BitmapToRTF(pic.bitmap)
  25.          PutRTFSelection(PageMemo, SS);     // TStringStream
  26.          finally
  27.          pic.Free;  // release pic image-data
  28.          SS.Free; // release RTF mask-data
  29.          end;
  30. end;
  31.  
  32. procedure TCmdForm.MnuDiskImageClick(Sender: TObject);
  33. var
  34.   pic: TPicture;
  35.   SS: TStringStream;  // TStringStream;  // TMemoryStream;
  36.   sz: TSize;
  37.   picw, pich: longint;
  38.   //CF: TClipboardFormat;
  39.  
  40. begin
  41.   if PageMemoOn and (not PagePassive) then
  42.   begin
  43.  
  44.   OpenDialog1.Title:= 'Select Image-File';
  45.   OpenDialog1.Filter:= 'JPG (*.jpg)|*.jpg|PNG (*.png)|*.png|TIF (*.tif)|*.tif|BMP (*.bmp)|*.bmp';
  46.   OpenDialog1.FileName:= '';
  47.   if OpenDialog1.Execute then
  48.      begin
  49.      pic:= TPicture.Create;
  50.      try pic.LoadFromFile(OpenDialog1.FileName);  // load image file
  51.          except on e:Exception do
  52.                 begin
  53.                 pic.Free;
  54.                 ShowMessage('Unknown Image Format: '+OpenDialog1.FileName+#13#10+e.Message);
  55.                 Exit;  // conclude procedure
  56.                 end;
  57.          end;
  58.      pich:= pic.height;  // has correct sizing
  59.      picw:= pic.width;   // w600 h776
  60.  
  61. //showmessage('1 PicH='+inttostr(pich)+'  PicW'+inttostr(picw)+
  62. //            '  Beg='+inttostr(PageMemo.SelStart)+'  Run='+inttostr(PageMemo.SelLength));  // pich=776 ** good **
  63.  
  64.      try SS:= TStringStream.Create(BitmapToRTF(pic.bitmap)); // build RTF mask
  65.          //SS:= BitmapToRTF(pic.bitmap)
  66.          PutRTFSelection(PageMemo, SS);     // TStringStream
  67.          finally
  68.          pic.Free;  // release pic image-data
  69.          SS.Free; // release RTF mask-data
  70.  
  71.          {
  72.          PointSize     = 72.0;
  73.          RtfSizeToInch = 2.54 * 1000.0;
  74.          SizeFactor    = 1 / PointSize * RtfSizeToInch; // pt to 0.01 mlmete
  75.          RevSizeFactor = 1 / SizeFactor;
  76.          }
  77.  
  78.          // something wrong with RTF image insert method
  79.          // the image must be reduced in size
  80.          // this is a work-around:
  81.  
  82.          PageMemo.SelStart:= PageMemo.SelStart-1; // modified selection
  83.          PageMemo.SelLength:= 1;  // modified length
  84.          GetOleObjectSize(PageMemo, PageMemo.SelStart, sz);
  85.  
  86. //showmessage('2 PicH='+inttostr(sz.cy)+'  PicW'+inttostr(sz.cx)+
  87. //            '  Beg='+inttostr(PageMemo.SelStart)+'  Run='+inttostr(PageMemo.SelLength));  // pich=582
  88.  
  89.          IMGresize:= 1.00;  // 0.484693878; // (sz.cy / pich);
  90.          sz.cx:=trunc(sz.cx * IMGresize); // width
  91.          sz.cy:=trunc(sz.cy * IMGresize); // height
  92.          SetOleObjectSize(Pagememo, PageMemo.SelStart, sz);
  93.  
  94. //showmessage('3 PicH='+inttostr(sz.cy)+'  PicW'+inttostr(sz.cx)+
  95.  //           '  Beg='+inttostr(PageMemo.SelStart)+'  Run='+inttostr(PageMemo.SelLength));
  96.          end;
  97.      end;
  98.   end else showmessage('Main editor frame must be active.');
  99. end;
  100.  

Rick
Title: Re: Image Resizing
Post by: rick2691 on March 13, 2022, 01:41:02 pm
I have found a number of Delphi examples to import an image.

Their coding has been identical to ours, but two functions that we have do not have to be coded. They internal to their resource unit.

GetDIBSizes(pict.Handle, bis, bbs);
GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);

Perhaps the problem is there. However, none of them are complaining about an oversized display and low resolution. I can only assume that their resource unit handles the import differently.

Also, I am only calling it an oversized display because a manual copy/paste comes in a half-size smaller. It's the image resolution that can't be managed.

Rick
TinyPortal © 2005-2018