Recent

Author Topic: moving images between TImageList - preserving transparency - bug?  (Read 482 times)

MISV

  • Hero Member
  • *****
  • Posts: 629
Not quite sure where to post... So I also posted this in Mac/Cocoa forum: https://forum.lazarus.freepascal.org/index.php/topic,47031.0.html

...

I am basically trying to resize images in my TImageList.

Since that caused problems I simplified my problem to better narrow it down. Hence in this example all I am actually doing is moving images from one imagelist to another and then moving them back.... But I am losing transparency in the process. (One can see this visually by by e.g. have the imagelist connected to a toolbar or similar.)

Code: Pascal  [Select]
  1. procedure myMoveImages(const AImageList: TImageList);
  2. var
  3.   TmpIter: Integer;
  4.   TmpBitmapOldmask: TBitmap;
  5.   TmpBitmapOldImg: TBitmap;
  6.   TmpImageListCopyHolder: TImageList;
  7. begin
  8.   TmpImageListCopyHolder := TImageList.Create(nil);
  9.   TmpImageListCopyHolder.Width := AImageList.Width;
  10.   TmpImageListCopyHolder.Height := AImageList.Height;
  11.   TmpImageListCopyHolder.DrawingStyle := AImageList.DrawingStyle;
  12.   //--
  13.   TmpBitmapOldImg := myCreateBitmap(AImageList.Width, AImageList.Height, clNone, pf32bit);
  14.   TmpBitmapOldmask := myCreateBitmap(AImageList.Width, AImageList.Height, clNone, pf32bit);
  15.   //--
  16.   for TmpIter := 0 to -1 + AImageList.Count do
  17.   begin
  18.     TmpBitmapOldImg.Canvas.FillRect(TmpBitmapOldImg.Canvas.ClipRect);
  19.     TmpBitmapOldmask.Canvas.FillRect(TmpBitmapOldmask.Canvas.ClipRect);
  20.     AImageList.Draw(TmpBitmapOldImg.Canvas, 0, 0, TmpIter, dsTransparent, itImage, True);
  21.     AImageList.Draw(TmpBitmapOldMask.Canvas, 0, 0, TmpIter, dsNormal, itMask, True);
  22.     //TmpImageListCopyHolder.Add(TmpBitmapOldImg, TmpBitmapOldMask);
  23.     TmpImageListCopyHolder.AddMasked(TmpBitmapOldImg, TmpBitmapOldImg.TransparentColor);
  24.   end;
  25.   //--
  26.   AImageList.Clear;
  27.   for TmpIter := 0 to -1 + TmpImageListCopyHolder.Count do
  28.   begin
  29.     TmpBitmapOldImg.Canvas.FillRect(TmpBitmapOldImg.Canvas.ClipRect);
  30.     TmpBitmapOldmask.Canvas.FillRect(TmpBitmapOldmask.Canvas.ClipRect);
  31.     TmpImageListCopyHolder.Draw(TmpBitmapOldImg.Canvas, 0, 0, TmpIter, dsTransparent, itImage, True);
  32.     TmpImageListCopyHolder.Draw(TmpBitmapOldMask.Canvas, 0, 0, TmpIter, dsNormal, itMask, True);
  33.     AImageList.AddMasked(TmpBitmapOldImg, TmpBitmapOldImg.TransparentColor);
  34.     //AImageList.Add(TmpBitmapOldImg, TmpBitmapOldMask);
  35.   end;
  36.  
  37.  
  38. function myCreateBitmap(AWidth, AHeight: Integer; ABGColor: TColor; APixelFormat: TPixelFormat): TBitMap;
  39. var
  40.   BitMap: TBitMap;
  41.   TmpRect: TRect;
  42. begin
  43.    BitMap := TBitMap.Create;
  44.    with BitMap do
  45.      begin
  46.        PixelFormat := APixelFormat;
  47.        Width := AWidth;
  48.        Height := AHeight;
  49.        Canvas.Brush.Style := bsSolid;
  50.        if ABGColor = clNone then
  51.          ABGColor := Bitmap.TransparentColor
  52.        ;
  53.        Canvas.Brush.Color := ABGColor;
  54.        TmpRect.Top := 0;
  55.        TmpRect.Left := 0;
  56.        TmpRect.Right := Width;
  57.        TmpRect.Bottom := Height;
  58.        Canvas.FillRect(TmpRect);
  59.      end
  60.    ;
  61.    Result := BitMap;
  62. end;
  63.  

...

Instead of above I have also tried

1)
Code: Pascal  [Select]
  1.     myImageList1.Draw(TmpBitmapOldImg.Canvas, 0, 0, TmpIter, dsNormal, itImage, True);
  2.     myImageList1.Draw(TmpBitmapOldMask.Canvas, 0, 0, TmpIter, dsNormal, itMask, True);
  3.     myImageList2.Add(TmpBitmapOldImg, TmpBitmapOldMask);
  4.  


2)
used cdlDefault, clFuschia as color

3)
Tried everything could thing of with drawingstyle bkcolor etc.

...

Does anyone know why I loose transparency? I have tried everything I can think of. I also have the same code working on Windows/Delphi.
« Last Edit: October 11, 2019, 04:21:45 pm by MISV »

jamie

  • Hero Member
  • *****
  • Posts: 1980
Re: moving images between TImageList - preserving transparency - bug?
« Reply #1 on: October 11, 2019, 10:41:24 pm »
You may want to check the values of the CLIPRECT you are using. They don't populate the values like they do in Delphi..

 In Delphi the canvas.cliprect defaults to the size of the bitmap, here I've found it's some fixed sized unless you set it.

 it would be better if you simply created a rectangle of the size you need instead of using that one.

wp

  • Hero Member
  • *****
  • Posts: 6224
Re: moving images between TImageList - preserving transparency - bug?
« Reply #2 on: October 11, 2019, 11:02:58 pm »
I am basically trying to resize images in my TImageList.

If you use Laz 2.0+ then the ImageList has built-in resizing capabilities. Use this to draw an image (with some index) onto some canvas at any width W at position X and Y:

Code: Pascal  [Select]
  1.   ImageList1.Resolution[W].Draw(SomeCanvas, X, Y, SomeIndex); // REQUIRES Lazarus 2.0+  

Note that there is a significant loss in image quality when the destination size is larger than the original size. Scaling down, however, (i.e. reducing the image size) results in surprisingly high quality.
Lazarus trunk / fpc 3.0.4 / all 32-bit on Win-10

MISV

  • Hero Member
  • *****
  • Posts: 629
Re: moving images between TImageList - preserving transparency - bug?
« Reply #3 on: October 12, 2019, 12:46:06 am »
I am basically trying to resize images in my TImageList.

If you use Laz 2.0+ then the ImageList has built-in resizing capabilities. Use this to draw an image (with some index) onto some canvas at any width W at position X and Y:

Code: Pascal  [Select]
  1.   ImageList1.Resolution[W].Draw(SomeCanvas, X, Y, SomeIndex); // REQUIRES Lazarus 2.0+  

Note that there is a significant loss in image quality when the destination size is larger than the original size. Scaling down, however, (i.e. reducing the image size) results in surprisingly high quality.

I considered it, but

I have hundreds of icons 16x16 but no other size.
In addition I am keeping my code + forms Delphi + Lazarus compatible.
And finally I am using  resize rules suggested here zarko-gajic.iz.hr/resizing-delphis-timagelist-bitmaps-to-fit-high-dpi-scaling-size-for-menus-toolbars-trees-etc/
- i.e. DPI at 150% I am just centering my icons instead of resizing them.

But under all circumstances, I would like to understand why the above code does not work (and file a bug-report if it is a LCL issue)

MISV

  • Hero Member
  • *****
  • Posts: 629
Re: moving images between TImageList - preserving transparency - bug?
« Reply #4 on: October 12, 2019, 12:46:43 am »
You may want to check the values of the CLIPRECT you are using. They don't populate the values like they do in Delphi..

 In Delphi the canvas.cliprect defaults to the size of the bitmap, here I've found it's some fixed sized unless you set it.

 it would be better if you simply created a rectangle of the size you need instead of using that one.

Does not seem to make any difference, but will run more tests later tomorrow. I am open for all suggestions!
« Last Edit: October 12, 2019, 12:55:12 am by MISV »

MISV

  • Hero Member
  • *****
  • Posts: 629
Re: moving images between TImageList - preserving transparency - bug?
« Reply #5 on: October 12, 2019, 09:29:05 am »
There must be a clue to the background gets white. But I have tried all kinds of brush colors (clnone, cldefault and a mod where I set color to bitmap.TransparentColor after creating it) and imagelist bkcolor (clNone should be correct when using dsnormal)

I think I have tried all combinations now (been running easily 50+ tests if not more)

On the other hand, if there is a bug here then... I have to try find out if generally in Lazarus or only Lazarus/LCLCocoa - might be the next thing I try. One should think though hat if there were a bug in LCL other things would long-ago have exposed it and so that seems almost unlikely (albeit LCL Cocoa is still undergoing a lot of development)




wp

  • Hero Member
  • *****
  • Posts: 6224
Re: moving images between TImageList - preserving transparency - bug?
« Reply #6 on: October 12, 2019, 12:18:11 pm »
I don't know if it really answers your question but the following code works correctly for me, in the sense that transparency is respected. (I did not check Delphi, though - it does not work on Delphi, though)

Code: Pascal  [Select]
  1. procedure CopyImages(ASourceImages, ADestImages: TImageList);
  2. var
  3.   srcBMP: TCustomBitmap;
  4.   destBMP: TCustomBitmap;
  5.   i: Integer;
  6. begin
  7.  
  8.   srcBMP := TBitmap.Create;
  9.   destBMP := TBitmap.Create;
  10.   try
  11.     srcBMP.PixelFormat := pf32Bit;
  12.     srcBMP.SetSize(ASourceImages.Width, ASourceImages.Height);
  13.     destBMP.PixelFormat := pf32Bit;
  14.     destBMP.SetSize(ADestImages.Width, ADestImages.Height);
  15.  
  16.     ADestImages.Clear;
  17.  
  18.     for i:=0 to ASourceImages.Count-1 do
  19.     begin
  20.       srcBMP.Canvas.Brush.Color := ASourceImages.BkColor;
  21.       srcBMP.Canvas.FillRect(0, 0, srcBMP.Width, srcBMP.Height);
  22.       ASourceImages.Draw(srcBMP.Canvas, 0, 0, i, ASourceImages.DrawingStyle, itImage);
  23.  
  24.       destBMP.Canvas.Brush.Color := ADestImages.BkColor;
  25.       destBMP.Canvas.FillRect(0, 0, destBMP.Width, destBMP.Height);
  26.       destBMP.Canvas.StretchDraw(Rect(0, 0, destBMP.Width, destBMP.Height), srcBMP);
  27.  
  28.       ADestImages.Add(destBMP, nil);
  29.     end;
  30.  
  31.   finally
  32.     srcBMP.Free;
  33.     destBMP.Free;
  34.   end;
  35. end;

See also attached demo.
« Last Edit: October 12, 2019, 01:14:21 pm by wp »
Lazarus trunk / fpc 3.0.4 / all 32-bit on Win-10

MISV

  • Hero Member
  • *****
  • Posts: 629
Re: moving images between TImageList - preserving transparency - bug?
« Reply #7 on: October 12, 2019, 01:05:55 pm »
I don't know if it really answers your question but the following code works correctly for me, in the sense that transparency is respected. (I did not check Delphi, though)

Code: Pascal  [Select]
  1. procedure CopyImages(ASourceImages, ADestImages: TImageList);
  2. var
  3.   srcBMP: TCustomBitmap;
  4.   destBMP: TCustomBitmap;
  5.   i: Integer;
  6. begin
  7.  
  8.   srcBMP := TBitmap.Create;
  9.   destBMP := TBitmap.Create;
  10.   try
  11.     srcBMP.PixelFormat := pf32Bit;
  12.     srcBMP.SetSize(ASourceImages.Width, ASourceImages.Height);
  13.     destBMP.PixelFormat := pf32Bit;
  14.     destBMP.SetSize(ADestImages.Width, ADestImages.Height);
  15.  
  16.     ADestImages.Clear;
  17.  
  18.     for i:=0 to ASourceImages.Count-1 do
  19.     begin
  20.       srcBMP.Canvas.Brush.Color := ASourceImages.BkColor;
  21.       srcBMP.Canvas.FillRect(0, 0, srcBMP.Width, srcBMP.Height);
  22.       ASourceImages.Draw(srcBMP.Canvas, 0, 0, i, ASourceImages.DrawingStyle, itImage);
  23.  
  24.       destBMP.Canvas.Brush.Color := ADestImages.BkColor;
  25.       destBMP.Canvas.FillRect(0, 0, destBMP.Width, destBMP.Height);
  26.       destBMP.Canvas.StretchDraw(Rect(0, 0, destBMP.Width, destBMP.Height), srcBMP);
  27.  
  28.       ADestImages.Add(destBMP, nil);
  29.     end;
  30.  
  31.   finally
  32.     srcBMP.Free;
  33.     destBMP.Free;
  34.   end;
  35. end;

See also attached demo.

Does not help. I will run a final experiment and then report as bug for Lazarus/LCL-Cocoa on Mac
« Last Edit: October 12, 2019, 01:13:28 pm by MISV »

wp

  • Hero Member
  • *****
  • Posts: 6224
Re: moving images between TImageList - preserving transparency - bug?
« Reply #8 on: October 12, 2019, 01:16:47 pm »
Does the scaled image list work on Mac? If yes, study the code in ImgList.
Lazarus trunk / fpc 3.0.4 / all 32-bit on Win-10

MISV

  • Hero Member
  • *****
  • Posts: 629
Re: moving images between TImageList - preserving transparency - bug?
« Reply #9 on: October 12, 2019, 01:38:03 pm »
Your project does not work. I think there is a bug in LCL Cocoa

Thank you everyone for your help. Now I know it is a LCL Cocoa issue and will report it as such.

May I use your demo project? And post that?
« Last Edit: October 12, 2019, 01:42:27 pm by MISV »

Mr.Madguy

  • Sr. Member
  • ****
  • Posts: 455
Re: moving images between TImageList - preserving transparency - bug?
« Reply #10 on: October 12, 2019, 01:48:21 pm »
If your images lose transparency, then something wrong happens with mask bitmap. Make sure you don't override source mask bitmap via setting some dest transparency properties.

This code works for me:
Code: Pascal  [Select]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls;
  9.  
  10. type
  11.  
  12.   { TForm1 }
  13.  
  14.   TForm1 = class(TForm)
  15.     procedure FormCreate(Sender: TObject);
  16.     procedure FormDestroy(Sender: TObject);
  17.     procedure FormPaint(Sender: TObject);
  18.   private
  19.  
  20.   public
  21.     Src, Dest:TBitmap;
  22.   end;
  23.  
  24. var
  25.   Form1: TForm1;
  26.  
  27. implementation
  28.  
  29. {$R *.lfm}
  30.  
  31. { TForm1 }
  32.  
  33. const
  34.   MyWidth = 100;
  35.   MyHeight = 100;
  36.  
  37. procedure TForm1.FormCreate(Sender: TObject);
  38.   var SrcMask, DestMask:TBitmap;
  39. begin
  40.   Src := TBitmap.Create;
  41.   Src.LoadFromFile('C:\Users\Systems\Downloads\Icon.bmp');
  42.   Src.TransparentColor := clBlue;
  43.   Src.Transparent := True;
  44.   Dest := TBitmap.Create;
  45.   SrcMask := TBitmap.Create;
  46.   DestMask := TBitmap.Create;
  47.   Dest.Width := MyWidth;
  48.   Dest.Height := MyHeight;
  49.   Dest.Transparent := True;
  50.   DestMask.Width := MyWidth;
  51.   DestMask.Height := MyHeight;
  52.   SrcMask.Handle := Src.MaskHandle;
  53.   Dest.Canvas.StretchDraw(TRect.Create(0, 0, MyWidth, MyHeight), Src);
  54.   DestMask.Canvas.StretchDraw(TRect.Create(0, 0, MyWidth, MyHeight), SrcMask);
  55.   SrcMask.ReleaseHandle;
  56.   SrcMask.Free;
  57.   Dest.MaskHandle := DestMask.ReleaseHandle;
  58.   DestMask.Free;
  59. end;
  60.  
  61. procedure TForm1.FormDestroy(Sender: TObject);
  62. begin
  63.   Src.Free;
  64.   Dest.Free;
  65. end;
  66.  
  67. procedure TForm1.FormPaint(Sender: TObject);
  68. begin
  69.   Canvas.Draw(0, 0,{Src} Dest);
  70. end;
  71.  
  72. end.
  73.  
DynamicData 3.0 is released!
Since now development is frozen - only optimization passes will be made at some point.
Lack of multiple inheritance turns it into abomination.

wp

  • Hero Member
  • *****
  • Posts: 6224
Re: moving images between TImageList - preserving transparency - bug?
« Reply #11 on: October 12, 2019, 02:08:55 pm »
May I use your demo project? And post that?
Certainly.
Lazarus trunk / fpc 3.0.4 / all 32-bit on Win-10

wp

  • Hero Member
  • *****
  • Posts: 6224
Re: moving images between TImageList - preserving transparency - bug?
« Reply #12 on: October 12, 2019, 02:28:56 pm »
Your project does not work.

Could you try this modification? It is based on IntfGraphics (well -- it won't help you with Delphi...):
Code: Pascal  [Select]
  1. uses
  2.   ImgList, IntfGraphics, LazCanvas;
  3.  
  4. // adapted from
  5. // https://wiki.freepascal.org/Developing_with_Graphics#Using_the_non-native_StretchDraw_from_LazCanvas
  6. procedure StretchDrawBitmapToBitmap(SourceBitmap, DestBitmap: TBitmap;
  7.   DestWidth, DestHeight: integer);
  8. var
  9.   DestIntfImage, SourceIntfImage: TLazIntfImage;
  10.   DestCanvas: TLazCanvas;
  11. begin
  12.   // Prepare the destination
  13.   DestIntfImage := TLazIntfImage.Create(0, 0);
  14.   try
  15.     DestIntfImage.LoadFromBitmap(DestBitmap.Handle, 0);
  16.     DestCanvas := TLazCanvas.Create(DestIntfImage);
  17.     try
  18.       //Prepare the source
  19.       SourceIntfImage := TLazIntfImage.Create(0, 0);
  20.       try
  21.         SourceIntfImage.LoadFromBitmap(SourceBitmap.Handle, 0);
  22.         // Execute the stretch draw via TFPSharpInterpolation
  23.         DestCanvas.Interpolation := TFPSharpInterpolation.Create;
  24.         try
  25.           DestCanvas.StretchDraw(0, 0, DestWidth, DestHeight, SourceIntfImage);
  26.           // Reload the image into the TBitmap
  27.           DestBitmap.LoadFromIntfImage(DestIntfImage);
  28.         finally
  29.           destCanvas.Interpolation.Free;
  30.         end;
  31.       finally
  32.         SourceIntfImage.Free;
  33.       end;
  34.     finally
  35.       DestCanvas.Free;
  36.     end;
  37.   finally
  38.     DestIntfImage.Free;
  39.   end;
  40. end;
  41.  
  42. procedure CopyImages(ASourceImages, ADestImages: TImageList);
  43. var
  44.   srcBMP: TBitmap;
  45.   destBMP: TBitmap;
  46.   i: Integer;
  47. begin
  48.   srcBMP := TBitmap.Create;
  49.   destBMP := TBitmap.Create;
  50.   try
  51.     srcBMP.PixelFormat := pf32Bit;
  52.     srcBMP.SetSize(ASourceImages.Width, ASourceImages.Height);
  53.     destBMP.PixelFormat := pf32Bit;
  54.     destBMP.SetSize(ADestImages.Width, ADestImages.Height);
  55.  
  56.     ADestImages.Clear;
  57.  
  58.     for i:=0 to ASourceImages.Count-1 do
  59.     begin
  60.       ASourceImages.GetBitmap(i, srcBMP);
  61.       StretchDrawBitmapToBitmap(srcBMP, destBMP, destBMP.Width, destBMP.Height);
  62.       ADestImages.Add(destBMP, nil);
  63.     end;
  64.  
  65.   finally
  66.     srcBMP.Free;
  67.     destBMP.Free;
  68.   end;
  69. end;
  70.  
Lazarus trunk / fpc 3.0.4 / all 32-bit on Win-10

MISV

  • Hero Member
  • *****
  • Posts: 629
Re: moving images between TImageList - preserving transparency - bug?
« Reply #13 on: October 12, 2019, 10:22:54 pm »
Quote
Could you try this modification? It is based on IntfGraphics (well -- it won't help you with Delphi...):

That works! Thank you. I will now either or both:

1) Add a special codepath for Lazarus/LCLCocoa
2) Or submit a good bug report and hope it gets fixed

From skimming the changes - it would appears most likely cause for the orignal issue is a bug in the standard draw/stretchdraw in tbitmap.canvas ?

MISV

  • Hero Member
  • *****
  • Posts: 629
Re: moving images between TImageList - preserving transparency - bug?
« Reply #14 on: October 13, 2019, 12:32:46 am »
Actually... This does not fix the problem in the original code I posted

Maybe there's also an issue on Mac/Cocoa in the way I use the imagelist there...