PngImageList.pas 45 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600
  1. unit PngImageList;
  2. {$IF RTLVersion < 15.0 }
  3. This unit only compiles with Delphi 7 and higher!
  4. {$IFEND}
  5. interface
  6. uses
  7. Windows, Classes, SysUtils, Controls, Graphics, ImgList,
  8. {$IF CompilerVersion >= 34.0 Delphi 10.4 }
  9. System.UITypes,
  10. {$IFEND}
  11. {$IFDEF WINSCP}
  12. System.UITypes,
  13. {$IFEND}
  14. PngImage, PngFunctions;
  15. {$IF CompilerVersion < 34.0 Delphi 10.4 }
  16. type
  17. TImageName = type string;
  18. {$IFEND}
  19. {$IFDEF WINSCP}
  20. type
  21. TImageIndex = System.UITypes.TImageIndex;
  22. {$IFEND}
  23. type
  24. INameMapping = interface
  25. ['{38EECDD8-7440-4EA2-BFD0-424E5BB2C1D5}']
  26. function GetName(Index: Integer): string;
  27. function IndexOfName(const AName: string): Integer;
  28. procedure ListNames(Target: TStrings);
  29. property Name[Index: Integer]: string read GetName;
  30. end;
  31. type
  32. TPngImageCollection = class;
  33. TPngImageCollectionItem = class;
  34. TPngImageCollectionItems = class;
  35. TPngImageList = class(TImageList, INameMapping)
  36. function INameMapping.GetName = GetImageName;
  37. function INameMapping.IndexOfName = FindIndexByName;
  38. procedure INameMapping.ListNames = ListImageNames;
  39. private
  40. FEnabledImages: Boolean;
  41. FImageNameAvailable: Boolean;
  42. FLocked: Integer;
  43. FOverlayIndex: array[TOverlay] of Integer;
  44. FPngImages: TPngImageCollectionItems;
  45. FPngOptions: TPngOptions;
  46. function ExtractOverlayIndex(Style: Cardinal): Integer;
  47. function GetHeight: Integer;
  48. function GetImageName(Index: Integer): string;
  49. function GetWidth: Integer;
  50. procedure SetHeight(const Value: Integer);
  51. procedure SetPngOptions(const Value: TPngOptions);
  52. procedure SetWidth(const Value: Integer);
  53. protected
  54. procedure AssignTo(Dest: TPersistent); override;
  55. procedure CopyPngs; virtual;
  56. procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean = True); override;
  57. procedure InternalInsertPng(Index: Integer; const Png: TPngImage; Background:
  58. TColor = clNone);
  59. procedure InternalAddPng(const Png: TPngImage; Background: TColor = clNone);
  60. function PngToIcon(const Png: TPngImage; Background: TColor = clNone): HICON;
  61. procedure ReadData(Stream: TStream); override;
  62. procedure SetEnabledImages(const Value: Boolean); virtual;
  63. procedure SetPngImages(const Value: TPngImageCollectionItems); virtual;
  64. procedure WriteData(Stream: TStream); override;
  65. public
  66. constructor Create(AOwner: TComponent); override;
  67. destructor Destroy; override;
  68. //Patched methods
  69. function Add(Image, Mask: TBitmap): Integer; virtual;
  70. function AddIcon(Image: TIcon): Integer; virtual;
  71. function AddPng(Image: TPngImage; Background: TColor = clNone): Integer;
  72. function AddImage(Value: TCustomImageList; Index: Integer): Integer; virtual;
  73. procedure AddImages(Value: TCustomImageList); virtual;
  74. function AddMasked(Image: TBitmap; MaskColor: TColor): Integer; virtual;
  75. {$IF CompilerVersion >= 34.0 Delphi 10.4 Sydney }
  76. function AddDisabledImage(Value: TCustomImageList; Index: Integer): Integer; virtual;
  77. procedure AddDisabledImages(Value: TCustomImageList); virtual;
  78. {$IFEND}
  79. procedure Assign(Source: TPersistent); override;
  80. procedure BeginUpdate;
  81. procedure Clear; virtual;
  82. procedure Delete(Index: Integer); virtual;
  83. procedure EndUpdate(Update: Boolean = True);
  84. function FindIndexByName(const AName: string): Integer;
  85. procedure Insert(Index: Integer; Image, Mask: TBitmap); virtual;
  86. procedure InsertIcon(Index: Integer; Image: TIcon); virtual;
  87. procedure InsertPng(Index: Integer; Image: TPngImage; Background: TColor = clNone);
  88. procedure InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor); virtual;
  89. procedure ListImageNames(Target: TStrings);
  90. procedure Move(CurIndex, NewIndex: Integer); virtual;
  91. function Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
  92. procedure Replace(Index: Integer; Image, Mask: TBitmap); virtual;
  93. procedure ReplaceIcon(Index: Integer; Image: TIcon); virtual;
  94. procedure ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor); virtual;
  95. {$IF CompilerVersion >= 34.0 Delphi 10.4 }
  96. function IsImageNameAvailable: Boolean; override;
  97. {$IFEND}
  98. function GetIndexByName(const AName: TImageName): TImageIndex; {$IF CompilerVersion >= 34.0 Delphi 10.4 }override;{$IFEND}
  99. function GetNameByIndex(AIndex: TImageIndex): TImageName; {$IF CompilerVersion >= 34.0 Delphi 10.4 }override;{$IFEND}
  100. property ImageName[Index: Integer]: string read GetImageName;
  101. published
  102. {$IF CompilerVersion >= 20.0 Delphi 2009 }
  103. property ColorDepth default cd32Bit;
  104. {$IFEND}
  105. property EnabledImages: Boolean read FEnabledImages write SetEnabledImages default True;
  106. property Height read GetHeight write SetHeight default 16;
  107. property ImageNameAvailable: Boolean read FImageNameAvailable write FImageNameAvailable default False;
  108. property PngImages: TPngImageCollectionItems read FPngImages write SetPngImages;
  109. property PngOptions: TPngOptions read FPngOptions write SetPngOptions default [pngBlendOnDisabled];
  110. property Width read GetWidth write SetWidth default 16;
  111. end;
  112. TPngImageCollection = class(TComponent)
  113. private
  114. FItems: TPngImageCollectionItems;
  115. public
  116. constructor Create(AOwner: TComponent); override;
  117. destructor Destroy; override;
  118. published
  119. property Items: TPngImageCollectionItems read FItems write FItems;
  120. end;
  121. TPngImageCollectionItems = class(TCollection)
  122. private
  123. FOwner: TPersistent;
  124. function GetItem(Index: Integer): TPngImageCollectionItem;
  125. procedure SetItem(Index: Integer; const Value: TPngImageCollectionItem);
  126. protected
  127. function GetOwner: TPersistent; override;
  128. procedure Update(Item: TCollectionItem); override;
  129. public
  130. constructor Create(AOwner: TPersistent);
  131. function Add(DontCreatePNG: Boolean = False): TPngImageCollectionItem; reintroduce;
  132. procedure Assign(Source: TPersistent); override;
  133. function Insert(Index: Integer; DontCreatePNG: Boolean = False): TPngImageCollectionItem; reintroduce;
  134. property Items[index: Integer]: TPngImageCollectionItem read GetItem write SetItem; default;
  135. end;
  136. TPngImageCollectionItem = class(TCollectionItem)
  137. private
  138. FBackground: TColor;
  139. FName: string;
  140. FPngImage: TPngImage;
  141. procedure SetBackground(const Value: TColor);
  142. procedure SetPngImage(const Value: TPngImage);
  143. protected
  144. procedure AssignTo(Dest: TPersistent); override;
  145. function GetDisplayName: string; override;
  146. public
  147. constructor Create(Collection: TCollection); overload; override;
  148. constructor Create(Collection: TCollection; DontCreatePNG: Boolean = False); reintroduce; overload;
  149. destructor Destroy; override;
  150. procedure Assign(Source: TPersistent); override;
  151. function Duplicate: TPngImage;
  152. published
  153. property Background: TColor read FBackground write SetBackground default clBtnFace;
  154. property Name: string read FName write FName;
  155. property PngImage: TPngImage read FPngImage write SetPngImage;
  156. end;
  157. procedure CopyImageFromImageList(Dest: TPngImage; ImageList: TCustomImageList; Index: Integer);
  158. implementation
  159. uses
  160. Math, Contnrs, CommCtrl, ComCtrls;
  161. var
  162. ImageListCount: Integer = 0;
  163. MethodPatches: TObjectList = nil;
  164. type
  165. TMethodPatch = class
  166. private
  167. Name: string;
  168. OldBody: packed array[0..4] of Byte;
  169. OldPointer: Pointer;
  170. NewPointer: Pointer;
  171. public
  172. constructor Create;
  173. destructor Destroy; override;
  174. procedure BeginInvokeOldMethod;
  175. procedure FinishInvokeOldMethod;
  176. function PatchBack: Boolean;
  177. end;
  178. { Global }
  179. function FindMethodPatch(const Name: string): TMethodPatch;
  180. var
  181. I: Integer;
  182. begin
  183. Result := nil;
  184. for I := 0 to MethodPatches.Count - 1 do begin
  185. if TMethodPatch(MethodPatches[I]).Name = Name then begin
  186. Result := TMethodPatch(MethodPatches[I]);
  187. Break;
  188. end;
  189. end;
  190. end;
  191. {$IF RTLVersion > 18.0 }
  192. {$POINTERMATH ON}
  193. {$IFEND}
  194. function PatchPtr(OldPtr, NewPtr: Pointer; const Name: string; Patch: TMethodPatch): Boolean;
  195. var
  196. Access: Cardinal;
  197. memSize: Integer;
  198. opCode: PByte;
  199. operand: PInteger;
  200. begin
  201. Result := False;
  202. Patch.Name := Name;
  203. if OldPtr <> NewPtr then begin
  204. Patch.OldPointer := OldPtr;
  205. Patch.NewPointer := NewPtr;
  206. opCode := OldPtr;
  207. operand := OldPtr;
  208. Inc(PByte(operand));
  209. memSize := SizeOf(Patch.OldBody);
  210. Move(opCode^, Patch.OldBody[0], memSize);
  211. if VirtualProtect(OldPtr, 16, PAGE_EXECUTE_READWRITE, @Access) then begin
  212. opCode^ := $E9; // Near jump
  213. {$IF RTLVersion > 18.0 }
  214. operand^ := PByte(NewPtr) - PByte(OldPtr) - 5;
  215. {$ELSE}
  216. operand^ := PChar(NewPtr) - PChar(OldPtr) - 5;
  217. {$IFEND}
  218. VirtualProtect(OldPtr, 16, Access, @Access);
  219. // {$IF not (defined(CPU386) or defined(CPUX86) or defined(CPUX64)) }
  220. // FlushInstructionCache(GetCurrentProcess, OldPtr, memSize);
  221. // {$IFEND}
  222. Result := True;
  223. end;
  224. end;
  225. if not Result then
  226. Patch.OldPointer := nil;
  227. end;
  228. {$IF RTLVersion > 18.0 }
  229. {$POINTERMATH OFF}
  230. {$IFEND}
  231. procedure ApplyMethodPatches;
  232. type
  233. TPointerCombo = record
  234. OldPtr: Pointer;
  235. NewPtr: Pointer;
  236. Name: string;
  237. end;
  238. function Combo(const OldPtr, NewPtr: Pointer; const Name: string): TPointerCombo;
  239. begin
  240. Result.OldPtr := OldPtr;
  241. Result.NewPtr := NewPtr;
  242. Result.Name := Name;
  243. end;
  244. const
  245. EmptyCombo: TPointerCombo = (OldPtr: nil; NewPtr: nil; Name: '');
  246. var
  247. Pointers: array of TPointerCombo;
  248. Patch: TMethodPatch;
  249. I: Integer;
  250. begin
  251. if ImageListCount = 0 then begin
  252. {$IF CompilerVersion >= 34.0 Delphi 10.4 Sydney }
  253. SetLength(Pointers, 17);
  254. {$ELSE}
  255. SetLength(Pointers, 15);
  256. {$IFEND}
  257. Pointers[0] := Combo(@TCustomImageList.Add, @TPngImageList.Add, 'Add');
  258. Pointers[1] := Combo(@TCustomImageList.AddIcon, @TPngImageList.AddIcon, 'AddIcon');
  259. Pointers[2] := Combo(@TCustomImageList.AddImage, @TPngImageList.AddImage, 'AddImage');
  260. Pointers[3] := Combo(@TCustomImageList.AddImages, @TPngImageList.AddImages, 'AddImages');
  261. Pointers[4] := Combo(@TCustomImageList.AddMasked, @TPngImageList.AddMasked, 'AddMasked');
  262. Pointers[5] := Combo(@TCustomImageList.Clear, @TPngImageList.Clear, 'Clear');
  263. Pointers[6] := Combo(@TCustomImageList.Delete, @TPngImageList.Delete, 'Delete');
  264. Pointers[7] := Combo(@TCustomImageList.Insert, @TPngImageList.Insert, 'Insert');
  265. Pointers[8] := Combo(@TCustomImageList.InsertIcon, @TPngImageList.InsertIcon, 'InsertIcon');
  266. Pointers[9] := Combo(@TCustomImageList.InsertMasked, @TPngImageList.InsertMasked, 'InsertMasked');
  267. Pointers[10] := Combo(@TCustomImageList.Move, @TPngImageList.Move, 'Move');
  268. Pointers[11] := Combo(@TCustomImageList.Replace, @TPngImageList.Replace, 'Replace');
  269. Pointers[12] := Combo(@TCustomImageList.ReplaceIcon, @TPngImageList.ReplaceIcon, 'ReplaceIcon');
  270. Pointers[13] := Combo(@TCustomImageList.ReplaceMasked, @TPngImageList.ReplaceMasked, 'ReplaceMasked');
  271. Pointers[14] := Combo(@TCustomImageList.Overlay, @TPngImageList.Overlay, 'Overlay');
  272. {$IF CompilerVersion >= 34.0 Delphi 10.4 Sydney }
  273. Pointers[15] := Combo(@TCustomImageList.AddDisabledImage, @TPngImageList.AddDisabledImage, 'AddDisabledImage');
  274. Pointers[16] := Combo(@TCustomImageList.AddDisabledImages, @TPngImageList.AddDisabledImages, 'AddDisabledImages');
  275. {$IFEND}
  276. MethodPatches := TObjectList.Create;
  277. for I := Low(Pointers) to High(Pointers) do begin
  278. if Pointers[I].OldPtr <> nil then begin
  279. Patch := TMethodPatch.Create;
  280. if PatchPtr(Pointers[I].OldPtr, Pointers[I].NewPtr, Pointers[I].Name, Patch) then
  281. begin
  282. MethodPatches.Add(Patch)
  283. end
  284. else
  285. begin
  286. Patch.Free;
  287. end;
  288. end;
  289. end;
  290. end;
  291. end;
  292. procedure RevertPatchedMethods;
  293. begin
  294. if ImageListCount = 0 then
  295. begin
  296. FreeAndNil(MethodPatches);
  297. end;
  298. end;
  299. procedure CopyImageFromImageList(Dest: TPngImage; ImageList: TCustomImageList; Index: Integer);
  300. var
  301. Icon: TIcon;
  302. IconInfo: TIconInfo;
  303. ColorBitmap, MaskBitmap: TBitmap;
  304. X, Y: Integer;
  305. AlphaLine: pngimage.PByteArray;
  306. Png: TPngImageCollectionItem;
  307. begin
  308. if ImageList is TPngImageList then begin
  309. //This is easy, just copy the PNG object from the imagelist to the PNG object
  310. //from the button
  311. Png := TPNGImageList(ImageList).PngImages[Index];
  312. if Png <> nil then
  313. Dest.Assign(Png.PngImage);
  314. end
  315. else begin
  316. Icon := TIcon.Create;
  317. ColorBitmap := TBitmap.Create;
  318. MaskBitmap := TBitmap.Create;
  319. try
  320. //Try to copy an icon to a PNG object, including transparency
  321. ImageList.GetIcon(Index, Icon);
  322. if GetIconInfo(Icon.Handle, IconInfo) then begin
  323. //First, pump the colors into the PNG object
  324. ColorBitmap.Handle := IconInfo.hbmColor;
  325. ColorBitmap.PixelFormat := pf24bit;
  326. Dest.Assign(ColorBitmap);
  327. //Finally, copy the transparency
  328. Dest.CreateAlpha;
  329. MaskBitmap.Handle := IconInfo.hbmMask;
  330. for Y := 0 to Dest.Height - 1 do begin
  331. AlphaLine := Dest.AlphaScanline[Y];
  332. for X := 0 to Dest.Width - 1 do
  333. AlphaLine^[X] := Integer(GetPixel(MaskBitmap.Canvas.Handle, X, Y) = COLORREF(clBlack)) * $FF;
  334. end;
  335. end;
  336. finally
  337. MaskBitmap.Free;
  338. ColorBitmap.Free;
  339. Icon.Free;
  340. end;
  341. end;
  342. end;
  343. { TMethodPatch }
  344. constructor TMethodPatch.Create;
  345. begin
  346. inherited Create;
  347. OldPointer := nil;
  348. end;
  349. destructor TMethodPatch.Destroy;
  350. begin
  351. if OldPointer <> nil then
  352. begin
  353. PatchBack;
  354. end;
  355. inherited Destroy;
  356. end;
  357. procedure TMethodPatch.BeginInvokeOldMethod;
  358. begin
  359. PatchBack;
  360. end;
  361. procedure TMethodPatch.FinishInvokeOldMethod;
  362. begin
  363. PatchPtr(OldPointer, NewPointer, Name, Self);
  364. end;
  365. function TMethodPatch.PatchBack: Boolean;
  366. var
  367. Access: Cardinal;
  368. begin
  369. Result := False;
  370. if VirtualProtect(OldPointer, 16, PAGE_EXECUTE_READWRITE, @Access) then begin
  371. Move(OldBody[0], OldPointer^, SizeOf(OldBody));
  372. VirtualProtect(OldPointer, 16, Access, @Access);
  373. Result := True;
  374. end;
  375. end;
  376. constructor TPngImageList.Create(AOwner: TComponent);
  377. var
  378. I: Integer;
  379. begin
  380. for I := Low(FOverlayIndex) to High(FOverlayIndex) do begin
  381. FOverlayIndex[I] := -1;
  382. end;
  383. inherited Create(AOwner);
  384. {$IF CompilerVersion >= 33.0 Delphi 10.3 Rio }
  385. StoreBitmap := False;
  386. {$IFEND}
  387. FImageNameAvailable := False;
  388. {$IF CompilerVersion >= 20.0 Delphi 2009 }
  389. ColorDepth := cd32Bit;
  390. {$IFEND}
  391. if ImageListCount = 0 then
  392. ApplyMethodPatches;
  393. Inc(ImageListCount);
  394. FEnabledImages := True;
  395. FPngOptions := [pngBlendOnDisabled];
  396. FPngImages := TPngImageCollectionItems.Create(Self);
  397. FLocked := 0;
  398. end;
  399. destructor TPngImageList.Destroy;
  400. begin
  401. FPngImages.Free;
  402. Dec(ImageListCount);
  403. if ImageListCount = 0 then
  404. RevertPatchedMethods;
  405. inherited Destroy;
  406. end;
  407. //--- Patched methods ---
  408. function TPngImageList.Add(Image, Mask: TBitmap): Integer;
  409. var
  410. Patch: TMethodPatch;
  411. Png: TPngImage;
  412. begin
  413. if TObject(Self) is TPngImageList then begin
  414. Png := TPngImage.Create;
  415. try
  416. CreatePNG(Image, Mask, Png);
  417. result := AddPng(Png);
  418. finally
  419. Png.Free;
  420. end;
  421. end
  422. else begin
  423. Patch := FindMethodPatch('Add');
  424. if Patch <> nil then begin
  425. Patch.BeginInvokeOldMethod;
  426. try
  427. Result := TCustomImageList(Self).Add(Image, Mask);
  428. finally
  429. Patch.FinishInvokeOldMethod;
  430. end;
  431. end
  432. else
  433. Result := -1;
  434. end;
  435. end;
  436. function TPngImageList.AddIcon(Image: TIcon): Integer;
  437. var
  438. Patch: TMethodPatch;
  439. Png: TPngImage;
  440. begin
  441. if TObject(Self) is TPngImageList then begin
  442. Png := TPngImage.Create;
  443. try
  444. ConvertToPNG(Image, Png);
  445. result := AddPng(Png);
  446. finally
  447. Png.Free;
  448. end;
  449. end
  450. else begin
  451. Patch := FindMethodPatch('AddIcon');
  452. if Patch <> nil then begin
  453. Patch.BeginInvokeOldMethod;
  454. try
  455. Result := TCustomImageList(Self).AddIcon(Image);
  456. finally
  457. Patch.FinishInvokeOldMethod;
  458. end;
  459. end
  460. else
  461. Result := -1;
  462. end;
  463. end;
  464. function TPngImageList.AddPng(Image: TPngImage; Background: TColor = clNone):
  465. Integer;
  466. var
  467. Item: TPngImageCollectionItem;
  468. begin
  469. Result := -1;
  470. if Image = nil then Exit;
  471. BeginUpdate;
  472. try
  473. Item := FPngImages.Add(True);
  474. Item.PngImage := Image;
  475. Item.Background := Background;
  476. Result := Item.Index;
  477. InternalAddPng(Item.PngImage, Item.Background);
  478. Change;
  479. finally
  480. EndUpdate(false);
  481. end;
  482. end;
  483. function TPngImageList.AddImage(Value: TCustomImageList; Index: Integer): Integer;
  484. var
  485. Patch: TMethodPatch;
  486. Png: TPngImage;
  487. begin
  488. if TObject(Self) is TPngImageList then begin
  489. Png := TPngImage.Create;
  490. try
  491. CopyImageFromImageList(Png, Value, Index);
  492. if RTLVersion < 31.00 then begin
  493. result := AddPng(Png);
  494. end
  495. else begin
  496. { Since Berlin AddImage returns the new size of the list, while before it returned the index of the added image.
  497. Although this behaviour seems somewhat strange, it actually matches the documentation. }
  498. AddPng(Png);
  499. result := FPngImages.Count;
  500. end;
  501. finally
  502. Png.Free;
  503. end;
  504. end
  505. else begin
  506. Patch := FindMethodPatch('AddImage');
  507. if Patch <> nil then begin
  508. Patch.BeginInvokeOldMethod;
  509. try
  510. Result := TCustomImageList(Self).AddImage(Value, Index);
  511. finally
  512. Patch.FinishInvokeOldMethod;
  513. end;
  514. end
  515. else
  516. Result := -1;
  517. end;
  518. end;
  519. procedure TPngImageList.AddImages(Value: TCustomImageList);
  520. var
  521. Patch: TMethodPatch;
  522. I: Integer;
  523. Png: TPngImage;
  524. begin
  525. if TObject(Self) is TPngImageList then begin
  526. BeginUpdate;
  527. try
  528. //Copy every image from Value into this imagelist.
  529. Png := TPngImage.Create;
  530. try
  531. for I := 0 to Value.Count - 1 do begin
  532. CopyImageFromImageList(Png, Value, I);
  533. AddPng(Png);
  534. end;
  535. finally
  536. Png.Free;
  537. end;
  538. finally
  539. EndUpdate;
  540. end;
  541. end
  542. else begin
  543. Patch := FindMethodPatch('AddImages');
  544. if Patch <> nil then begin
  545. Patch.BeginInvokeOldMethod;
  546. try
  547. TCustomImageList(Self).AddImages(Value);
  548. finally
  549. Patch.FinishInvokeOldMethod;
  550. end;
  551. end;
  552. end;
  553. end;
  554. {$IF CompilerVersion >= 34.0 Delphi 10.4 Sydney }
  555. function TPngImageList.AddDisabledImage(Value: TCustomImageList; Index: Integer): Integer;
  556. var
  557. Patch: TMethodPatch;
  558. Png: TPngImage;
  559. begin
  560. if TObject(Self) is TPngImageList then begin
  561. Png := TPngImage.Create;
  562. try
  563. CopyImageFromImageList(Png, Value, Index);
  564. MakeDisabledImage(Png, PngOptions);
  565. AddPng(Png);
  566. result := FPngImages.Count;
  567. finally
  568. Png.Free;
  569. end;
  570. end
  571. else begin
  572. Patch := FindMethodPatch('AddDisabledImage');
  573. if Patch <> nil then begin
  574. Patch.BeginInvokeOldMethod;
  575. try
  576. Result := TCustomImageList(Self).AddDisabledImage(Value, Index);
  577. finally
  578. Patch.FinishInvokeOldMethod;
  579. end;
  580. end
  581. else
  582. Result := -1;
  583. end;
  584. end;
  585. procedure TPngImageList.AddDisabledImages(Value: TCustomImageList);
  586. var
  587. Patch: TMethodPatch;
  588. I: Integer;
  589. Png: TPngImage;
  590. begin
  591. if TObject(Self) is TPngImageList then begin
  592. BeginUpdate;
  593. try
  594. //Copy every image from Value into this imagelist.
  595. Png := TPngImage.Create;
  596. try
  597. for I := 0 to Value.Count - 1 do begin
  598. CopyImageFromImageList(Png, Value, I);
  599. MakeDisabledImage(Png, PngOptions);
  600. AddPng(Png);
  601. end;
  602. finally
  603. Png.Free;
  604. end;
  605. finally
  606. EndUpdate;
  607. end;
  608. end
  609. else begin
  610. Patch := FindMethodPatch('AddDisabledImages');
  611. if Patch <> nil then begin
  612. Patch.BeginInvokeOldMethod;
  613. try
  614. TCustomImageList(Self).AddDisabledImages(Value);
  615. finally
  616. Patch.FinishInvokeOldMethod;
  617. end;
  618. end;
  619. end;
  620. end;
  621. {$IFEND}
  622. function TPngImageList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  623. var
  624. Patch: TMethodPatch;
  625. Png: TPngImage;
  626. begin
  627. if TObject(Self) is TPngImageList then begin
  628. Png := TPngImage.Create;
  629. try
  630. CreatePNGMasked(Image, MaskColor, Png);
  631. result := AddPng(Png);
  632. finally
  633. Png.Free;
  634. end;
  635. end
  636. else begin
  637. Patch := FindMethodPatch('AddMasked');
  638. if Patch <> nil then begin
  639. Patch.BeginInvokeOldMethod;
  640. try
  641. Result := TCustomImageList(Self).AddMasked(Image, MaskColor);
  642. finally
  643. Patch.FinishInvokeOldMethod;
  644. end;
  645. end
  646. else
  647. Result := -1;
  648. end;
  649. end;
  650. procedure TPngImageList.Assign(Source: TPersistent);
  651. var
  652. pngSource: TPngImageList;
  653. begin
  654. if Source is TPngImageList then begin
  655. pngSource := TPngImageList(Source);
  656. BeginUpdate;
  657. try
  658. PngImages := pngSource.PngImages;
  659. EnabledImages := pngSource.EnabledImages;
  660. PngOptions := pngSource.PngOptions;
  661. finally
  662. EndUpdate(true);
  663. end;
  664. end;
  665. {$IF CompilerVersion >= 20.0 Delphi 2009 }
  666. if Source is TCustomImageList then begin
  667. ColorDepth := TCustomImageList(Source).ColorDepth;
  668. end;
  669. {$IFEND}
  670. inherited;
  671. end;
  672. procedure TPngImageList.AssignTo(Dest: TPersistent);
  673. var
  674. pngDest: TPngImageList;
  675. begin
  676. inherited;
  677. if Dest is TPngImageList then begin
  678. pngDest := TPngImageList(Dest);
  679. pngDest.PngImages := PngImages;
  680. pngDest.EnabledImages := EnabledImages;
  681. pngDest.PngOptions := PngOptions;
  682. end;
  683. end;
  684. procedure TPngImageList.BeginUpdate;
  685. begin
  686. Inc(FLocked);
  687. end;
  688. procedure TPngImageList.Clear;
  689. var
  690. Patch: TMethodPatch;
  691. begin
  692. if TObject(Self) is TPngImageList then begin
  693. //Clear the PngImages collection and the internal imagelist.
  694. BeginUpdate;
  695. try
  696. FPngImages.Clear;
  697. ImageList_Remove(Handle, -1);
  698. Change;
  699. finally
  700. EndUpdate(False);
  701. end;
  702. end
  703. else begin
  704. Patch := FindMethodPatch('Clear');
  705. if Patch <> nil then begin
  706. Patch.BeginInvokeOldMethod;
  707. try
  708. TCustomImageList(Self).Clear;
  709. finally
  710. Patch.FinishInvokeOldMethod;
  711. end;
  712. end;
  713. end;
  714. end;
  715. procedure TPngImageList.CopyPngs;
  716. var
  717. I: Integer;
  718. Png: TPngImage;
  719. Icon: HIcon;
  720. item: TPngImageCollectionItem;
  721. begin
  722. //Are we adding a bunch of images?
  723. if FLocked > 0 then
  724. Exit;
  725. //Copy PNG images to the imagelist. These images will not be stored in the DFM.
  726. ImageList_Remove(Handle, -1);
  727. Handle := ImageList_Create(Width, Height, ILC_COLOR32 or (Integer(Masked) *
  728. ILC_MASK), 0, AllocBy);
  729. Png := TPngImage.Create;
  730. try
  731. for I := 0 to FPngImages.Count - 1 do begin
  732. item := FPngImages.Items[I];
  733. if (item.PngImage = nil) or item.PngImage.Empty then
  734. Continue;
  735. if FEnabledImages or (FPngOptions = []) then begin
  736. Icon := PngToIcon(item.PngImage, item.Background);
  737. end
  738. else begin
  739. //Basically the same as in the DrawPNG function
  740. Png.Assign(item.PngImage);
  741. MakeDisabledImage(Png, PngOptions);
  742. Icon := PngToIcon(Png);
  743. end;
  744. ImageList_AddIcon(Handle, Icon);
  745. DestroyIcon(Icon);
  746. end;
  747. finally
  748. Png.Free;
  749. end;
  750. end;
  751. procedure TPngImageList.Delete(Index: Integer);
  752. var
  753. Patch: TMethodPatch;
  754. begin
  755. if TObject(Self) is TPngImageList then begin
  756. //Delete an image from the PngImages collection and from the internal imagelist.
  757. if (Index >= 0) and (Index < Count) then begin
  758. BeginUpdate;
  759. try
  760. FPngImages.Delete(Index);
  761. ImageList_Remove(Handle, Index);
  762. Change;
  763. finally
  764. EndUpdate(False);
  765. end;
  766. end;
  767. end
  768. else begin
  769. Patch := FindMethodPatch('Delete');
  770. if Patch <> nil then begin
  771. Patch.BeginInvokeOldMethod;
  772. try
  773. TCustomImageList(Self).Delete(Index);
  774. finally
  775. Patch.FinishInvokeOldMethod;
  776. end;
  777. end;
  778. end;
  779. end;
  780. //--- End of patched methods ---
  781. procedure TPngImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);
  782. var
  783. PaintRect: TRect;
  784. Options: TPngOptions;
  785. IndexOfOverlay: Integer;
  786. Png: TPngImageCollectionItem;
  787. begin
  788. //Draw a PNG directly to the Canvas. This is the preferred method to call,
  789. //because this omits the API calls that use a fixed background.
  790. PaintRect := Bounds(X, Y, Width, Height);
  791. if Enabled then
  792. Options := []
  793. else
  794. Options := FPngOptions;
  795. Png := FPngImages.Items[Index];
  796. if Png <> nil then begin
  797. DrawPNG(Png.PngImage, Canvas, PaintRect, Options);
  798. IndexOfOverlay := ExtractOverlayIndex(Style);
  799. if (IndexOfOverlay >= 0) and (IndexOfOverlay < Count) then begin
  800. Png := PngImages.Items[IndexOfOverlay];
  801. if Png <> nil then begin
  802. DrawPNG(Png.PngImage, Canvas, PaintRect, Options);
  803. end;
  804. end;
  805. end;
  806. end;
  807. procedure TPngImageList.EndUpdate(Update: Boolean);
  808. begin
  809. Dec(FLocked);
  810. if Update and (FLocked = 0) then
  811. CopyPngs;
  812. end;
  813. function TPngImageList.ExtractOverlayIndex(Style: Cardinal): Integer;
  814. var
  815. idx: Cardinal;
  816. begin
  817. Result := -1;
  818. idx := Style and ILD_OVERLAYMASK;
  819. if idx > 0 then begin
  820. idx := idx shr 8;
  821. if (idx > 0) then begin
  822. Dec(idx);
  823. {$WARN COMPARISON_TRUE OFF }
  824. if (idx >= Low(FOverlayIndex)) and (idx <= High(FOverlayIndex)) then begin
  825. Result := FOverlayIndex[idx];
  826. end;
  827. {$WARN COMPARISON_TRUE DEFAULT }
  828. end;
  829. end;
  830. end;
  831. function TPngImageList.FindIndexByName(const AName: string): Integer;
  832. var
  833. I: Integer;
  834. begin
  835. Result := -1;
  836. for I := 0 to PngImages.Count - 1 do begin
  837. if SameText(PngImages[I].Name, AName) then begin
  838. Result := I;
  839. Break;
  840. end;
  841. end;
  842. end;
  843. function TPngImageList.GetHeight: Integer;
  844. begin
  845. Result := inherited Height;
  846. end;
  847. function TPngImageList.GetImageName(Index: Integer): string;
  848. var
  849. item: TPngImageCollectionItem;
  850. begin
  851. Result := '';
  852. item := PngImages[Index];
  853. if item <> nil then
  854. Result := item.Name;
  855. end;
  856. {$IF CompilerVersion >= 34.0 Delphi 10.4 }
  857. function TPngImageList.IsImageNameAvailable: Boolean;
  858. begin
  859. Result := FImageNameAvailable;
  860. end;
  861. {$IFEND}
  862. function TPngImageList.GetIndexByName(const AName: TImageName): TImageIndex;
  863. begin
  864. Result := FindIndexByName(AName);
  865. end;
  866. function TPngImageList.GetNameByIndex(AIndex: TImageIndex): TImageName;
  867. begin
  868. Result := ImageName[AIndex];
  869. end;
  870. function TPngImageList.GetWidth: Integer;
  871. begin
  872. Result := inherited Width;
  873. end;
  874. procedure TPngImageList.Insert(Index: Integer; Image, Mask: TBitmap);
  875. var
  876. Patch: TMethodPatch;
  877. Png: TPngImage;
  878. begin
  879. if TObject(Self) is TPngImageList then begin
  880. //Insert a new PNG based on the image and its mask.
  881. if Image <> nil then begin
  882. Png := TPngImage.Create;
  883. try
  884. CreatePNG(Image, Mask, Png);
  885. InsertPng(Index, Png);
  886. finally
  887. Png.Free;
  888. end;
  889. end;
  890. end
  891. else begin
  892. Patch := FindMethodPatch('Insert');
  893. if Patch <> nil then begin
  894. Patch.BeginInvokeOldMethod;
  895. try
  896. TCustomImageList(Self).Insert(Index, Image, Mask);
  897. finally
  898. Patch.FinishInvokeOldMethod;
  899. end;
  900. end;
  901. end;
  902. end;
  903. procedure TPngImageList.InsertIcon(Index: Integer; Image: TIcon);
  904. var
  905. Patch: TMethodPatch;
  906. Png: TPngImage;
  907. begin
  908. if TObject(Self) is TPngImageList then begin
  909. //Insert a new PNG based on the image.
  910. if Image <> nil then begin
  911. Png := TPngImage.Create;
  912. try
  913. ConvertToPNG(Image, Png);
  914. InsertPng(Index, Png);
  915. finally
  916. Png.Free;
  917. end;
  918. end;
  919. end
  920. else begin
  921. Patch := FindMethodPatch('InsertIcon');
  922. if Patch <> nil then begin
  923. Patch.BeginInvokeOldMethod;
  924. try
  925. TCustomImageList(Self).InsertIcon(Index, Image);
  926. finally
  927. Patch.FinishInvokeOldMethod;
  928. end;
  929. end;
  930. end;
  931. end;
  932. procedure TPngImageList.InsertPng(Index: Integer; Image: TPngImage; Background:
  933. TColor = clNone);
  934. var
  935. Item: TPngImageCollectionItem;
  936. begin
  937. if Image <> nil then begin
  938. BeginUpdate;
  939. try
  940. Item := PngImages.Insert(Index, True);
  941. Item.PngImage := Image;
  942. Item.Background := Background;
  943. InternalInsertPng(Index, Item.PngImage, Item.Background);
  944. Change;
  945. finally
  946. EndUpdate(False);
  947. end;
  948. end;
  949. end;
  950. procedure TPngImageList.InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
  951. var
  952. Patch: TMethodPatch;
  953. Png: TPngImage;
  954. begin
  955. if TObject(Self) is TPngImageList then begin
  956. //Insert a new PNG based on the image and a colored mask.
  957. if Image <> nil then begin
  958. Png := TPngImage.Create;
  959. try
  960. CreatePNGMasked(Image, MaskColor, Png);
  961. InsertPng(Index, Png);
  962. finally
  963. Png.Free;
  964. end;
  965. end;
  966. end
  967. else begin
  968. Patch := FindMethodPatch('InsertMasked');
  969. if Patch <> nil then begin
  970. Patch.BeginInvokeOldMethod;
  971. try
  972. TCustomImageList(Self).InsertMasked(Index, Image, MaskColor);
  973. finally
  974. Patch.FinishInvokeOldMethod;
  975. end;
  976. end;
  977. end;
  978. end;
  979. procedure TPngImageList.InternalInsertPng(Index: Integer; const Png: TPngImage;
  980. Background: TColor);
  981. var
  982. I: Integer;
  983. Icon: HICON;
  984. TempList: TPngImageList;
  985. begin
  986. TempList := TPngImageList(TComponentClass(ClassType).Create(nil));
  987. try
  988. TempList.Assign(Self);
  989. ImageList_RemoveAll(Handle);
  990. for I := 0 to Index - 1 do begin
  991. Icon := ImageList_GetIcon(TempList.Handle, I, ILD_NORMAL);
  992. ImageList_AddIcon(Handle, Icon);
  993. DestroyIcon(Icon);
  994. end;
  995. Icon := PngToIcon(Png, Background);
  996. ImageList_AddIcon(Handle, Icon);
  997. DestroyIcon(Icon);
  998. for I := Index to TempList.Count - 1 do begin
  999. Icon := ImageList_GetIcon(TempList.Handle, I, ILD_NORMAL);
  1000. ImageList_AddIcon(Handle, Icon);
  1001. DestroyIcon(Icon);
  1002. end;
  1003. finally
  1004. TempList.Free;
  1005. end;
  1006. end;
  1007. procedure TPngImageList.InternalAddPng(const Png: TPngImage; Background: TColor
  1008. = clNone);
  1009. var
  1010. Icon: HICON;
  1011. begin
  1012. Icon := PngToIcon(Png, Background);
  1013. try
  1014. ImageList_AddIcon(Handle, Icon);
  1015. finally
  1016. DestroyIcon(Icon);
  1017. end;
  1018. end;
  1019. procedure TPngImageList.ListImageNames(Target: TStrings);
  1020. var
  1021. I: Integer;
  1022. begin
  1023. for I := 0 to PngImages.Count - 1 do begin
  1024. Target.Add(PngImages[I].Name);
  1025. end;
  1026. end;
  1027. procedure TPngImageList.Move(CurIndex, NewIndex: Integer);
  1028. var
  1029. Patch: TMethodPatch;
  1030. begin
  1031. if TObject(Self) is TPngImageList then begin
  1032. //Move an image from one position to another. Don't try doing so in the internal
  1033. //imagelist, just recreate it, since this method won't be called very often.
  1034. BeginUpdate;
  1035. try
  1036. ImageList_Remove(Handle, CurIndex);
  1037. InternalInsertPng(NewIndex, FPngImages[CurIndex].PngImage,
  1038. FPngImages[CurIndex].Background);
  1039. FPngImages[CurIndex].Index := NewIndex;
  1040. Change;
  1041. finally
  1042. EndUpdate(False);
  1043. end;
  1044. end
  1045. else begin
  1046. Patch := FindMethodPatch('Move');
  1047. if Patch <> nil then begin
  1048. Patch.BeginInvokeOldMethod;
  1049. try
  1050. TCustomImageList(Self).Move(CurIndex, NewIndex);
  1051. finally
  1052. Patch.FinishInvokeOldMethod;
  1053. end;
  1054. end;
  1055. end;
  1056. end;
  1057. function TPngImageList.Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
  1058. begin
  1059. Result := (ImageIndex >= 0) and (ImageIndex < Count);
  1060. FOverlayIndex[Overlay] := ImageIndex;
  1061. end;
  1062. function TPngImageList.PngToIcon(const Png: TPngImage; Background: TColor): HICON;
  1063. const
  1064. MaxRGBQuads = MaxInt div SizeOf(TRGBQuad) - 1;
  1065. type
  1066. TRGBQuadArray = array[0..MaxRGBQuads] of TRGBQuad;
  1067. PRGBQuadArray = ^TRGBQuadArray;
  1068. TBitmapInfo4 = packed record
  1069. bmiHeader: TBitmapV4Header;
  1070. bmiColors: array[0..0] of TRGBQuad;
  1071. end;
  1072. function PngToIcon32(Png: TPngImage): HIcon;
  1073. var
  1074. ImageBits: PRGBQuadArray;
  1075. BitmapInfo: TBitmapInfo4;
  1076. IconInfo: TIconInfo;
  1077. AlphaBitmap: HBitmap;
  1078. MaskBitmap: TBitmap;
  1079. X, Y: Integer;
  1080. AlphaLine: PByteArray;
  1081. HasAlpha, HasBitmask: Boolean;
  1082. Color, TransparencyColor: TColor;
  1083. begin
  1084. //Convert a PNG object to an alpha-blended icon resource
  1085. ImageBits := nil;
  1086. //Allocate a DIB for the color data and alpha channel
  1087. with BitmapInfo.bmiHeader do begin
  1088. bV4Size := SizeOf(BitmapInfo.bmiHeader);
  1089. bV4Width := Png.Width;
  1090. bV4Height := Png.Height;
  1091. bV4Planes := 1;
  1092. bV4BitCount := 32;
  1093. bV4V4Compression := BI_BITFIELDS;
  1094. bV4SizeImage := 0;
  1095. bV4XPelsPerMeter := 0;
  1096. bV4YPelsPerMeter := 0;
  1097. bV4ClrUsed := 0;
  1098. bV4ClrImportant := 0;
  1099. bV4RedMask := $00FF0000;
  1100. bV4GreenMask := $0000FF00;
  1101. bV4BlueMask := $000000FF;
  1102. bV4AlphaMask := $FF000000;
  1103. end;
  1104. AlphaBitmap := CreateDIBSection(0, PBitmapInfo(@BitmapInfo)^,
  1105. DIB_RGB_COLORS, Pointer(ImageBits), 0, 0);
  1106. try
  1107. //Spin through and fill it with a wash of color and alpha.
  1108. AlphaLine := nil;
  1109. HasAlpha := Png.Header.ColorType in [COLOR_GRAYSCALEALPHA,
  1110. COLOR_RGBALPHA];
  1111. HasBitmask := Png.TransparencyMode = ptmBit;
  1112. TransparencyColor := Png.TransparentColor;
  1113. for Y := 0 to Png.Height - 1 do begin
  1114. if HasAlpha then
  1115. AlphaLine := Png.AlphaScanline[Png.Height - Y - 1];
  1116. for X := 0 to Png.Width - 1 do begin
  1117. Color := Png.Pixels[X, Png.Height - Y - 1];
  1118. ImageBits^[Y * Png.Width + X].rgbRed := Color and $FF;
  1119. ImageBits^[Y * Png.Width + X].rgbGreen := Color shr 8 and $FF;
  1120. ImageBits^[Y * Png.Width + X].rgbBlue := Color shr 16 and $FF;
  1121. if HasAlpha then
  1122. ImageBits^[Y * Png.Width + X].rgbReserved := AlphaLine^[X]
  1123. else if HasBitmask then
  1124. ImageBits^[Y * Png.Width + X].rgbReserved := Integer(Color <>
  1125. TransparencyColor) * 255;
  1126. end;
  1127. end;
  1128. //Create an empty mask
  1129. MaskBitmap := TBitmap.Create;
  1130. try
  1131. MaskBitmap.Width := Png.Width;
  1132. MaskBitmap.Height := Png.Height;
  1133. MaskBitmap.PixelFormat := pf1bit;
  1134. MaskBitmap.Canvas.Brush.Color := clBlack;
  1135. MaskBitmap.Canvas.FillRect(Rect(0, 0, MaskBitmap.Width,
  1136. MaskBitmap.Height));
  1137. //Create the alpha blended icon
  1138. IconInfo.fIcon := True;
  1139. IconInfo.hbmColor := AlphaBitmap;
  1140. IconInfo.hbmMask := MaskBitmap.Handle;
  1141. Result := CreateIconIndirect(IconInfo);
  1142. finally
  1143. MaskBitmap.Free;
  1144. end;
  1145. finally
  1146. DeleteObject(AlphaBitmap);
  1147. end;
  1148. end;
  1149. function PngToIcon24(Png: TPngImage; Background: TColor): HIcon;
  1150. var
  1151. ColorBitmap, MaskBitmap: TBitmap;
  1152. X, Y: Integer;
  1153. AlphaLine: PByteArray;
  1154. IconInfo: TIconInfo;
  1155. TransparencyColor: TColor;
  1156. begin
  1157. ColorBitmap := TBitmap.Create;
  1158. MaskBitmap := TBitmap.Create;
  1159. try
  1160. ColorBitmap.Width := Png.Width;
  1161. ColorBitmap.Height := Png.Height;
  1162. ColorBitmap.PixelFormat := pf32bit;
  1163. MaskBitmap.Width := Png.Width;
  1164. MaskBitmap.Height := Png.Height;
  1165. MaskBitmap.PixelFormat := pf32bit;
  1166. //Draw the color bitmap
  1167. ColorBitmap.Canvas.Brush.Color := Background;
  1168. ColorBitmap.Canvas.FillRect(Rect(0, 0, Png.Width, Png.Height));
  1169. Png.Draw(ColorBitmap.Canvas, Rect(0, 0, Png.Width, Png.Height));
  1170. //Create the mask bitmap
  1171. if Png.Header.ColorType in [COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA] then
  1172. for Y := 0 to Png.Height - 1 do begin
  1173. AlphaLine := Png.AlphaScanline[Y];
  1174. for X := 0 to Png.Width - 1 do
  1175. if AlphaLine^[X] = 0 then
  1176. SetPixelV(MaskBitmap.Canvas.Handle, X, Y, clWhite)
  1177. else
  1178. SetPixelV(MaskBitmap.Canvas.Handle, X, Y, clBlack);
  1179. end
  1180. else if Png.TransparencyMode = ptmBit then begin
  1181. TransparencyColor := Png.TransparentColor;
  1182. for Y := 0 to Png.Height - 1 do
  1183. for X := 0 to Png.Width - 1 do
  1184. if Png.Pixels[X, Y] = TransparencyColor then
  1185. SetPixelV(MaskBitmap.Canvas.Handle, X, Y, clWhite)
  1186. else
  1187. SetPixelV(MaskBitmap.Canvas.Handle, X, Y, clBlack);
  1188. end;
  1189. //Create the icon
  1190. IconInfo.fIcon := True;
  1191. IconInfo.hbmColor := ColorBitmap.Handle;
  1192. IconInfo.hbmMask := MaskBitmap.Handle;
  1193. Result := CreateIconIndirect(IconInfo);
  1194. finally
  1195. ColorBitmap.Free;
  1196. MaskBitmap.Free;
  1197. end;
  1198. end;
  1199. begin
  1200. if GetComCtlVersion >= ComCtlVersionIE6 then begin
  1201. //Windows XP or later, using the modern method: convert every PNG to
  1202. //an icon resource with alpha channel
  1203. Result := PngToIcon32(Png);
  1204. end
  1205. else begin
  1206. //No Windows XP, using the legacy method: copy every PNG to a normal
  1207. //bitmap using a fixed background color
  1208. Result := PngToIcon24(Png, Background);
  1209. end;
  1210. end;
  1211. procedure TPngImageList.ReadData(Stream: TStream);
  1212. begin
  1213. if not (csReading in ComponentState) then
  1214. inherited;
  1215. //Make sure nothing gets read from the DFM
  1216. end;
  1217. procedure TPngImageList.Replace(Index: Integer; Image, Mask: TBitmap);
  1218. var
  1219. Item: TPngImageCollectionItem;
  1220. Patch: TMethodPatch;
  1221. Icon: HICON;
  1222. begin
  1223. if TObject(Self) is TPngImageList then begin
  1224. //Replace an existing PNG based with a new image and its mask.
  1225. if Image <> nil then begin
  1226. BeginUpdate;
  1227. try
  1228. Item := FPngImages[Index];
  1229. CreatePNG(Image, Mask, Item.PngImage);
  1230. Icon := PngToIcon(Item.PngImage, Item.Background);
  1231. ImageList_ReplaceIcon(Handle, Index, Icon);
  1232. DestroyIcon(Icon);
  1233. Change;
  1234. finally
  1235. EndUpdate(False);
  1236. end;
  1237. end;
  1238. end
  1239. else begin
  1240. Patch := FindMethodPatch('Replace');
  1241. if Patch <> nil then begin
  1242. Patch.BeginInvokeOldMethod;
  1243. try
  1244. TCustomImageList(Self).Replace(Index, Image, Mask);
  1245. finally
  1246. Patch.FinishInvokeOldMethod;
  1247. end;
  1248. end;
  1249. end;
  1250. end;
  1251. procedure TPngImageList.ReplaceIcon(Index: Integer; Image: TIcon);
  1252. var
  1253. Item: TPngImageCollectionItem;
  1254. Patch: TMethodPatch;
  1255. Icon: HICON;
  1256. begin
  1257. if TObject(Self) is TPngImageList then begin
  1258. //Replace an existing PNG based with a new image.
  1259. if Image <> nil then begin
  1260. BeginUpdate;
  1261. try
  1262. Item := FPngImages[Index];
  1263. ConvertToPNG(Image, Item.PngImage);
  1264. Icon := PngToIcon(Item.PngImage, Item.Background);
  1265. ImageList_ReplaceIcon(Handle, Index, Icon);
  1266. DestroyIcon(Icon);
  1267. Change;
  1268. finally
  1269. EndUpdate(False);
  1270. end;
  1271. end
  1272. end
  1273. else begin
  1274. Patch := FindMethodPatch('ReplaceIcon');
  1275. if Patch <> nil then begin
  1276. Patch.BeginInvokeOldMethod;
  1277. try
  1278. TCustomImageList(Self).ReplaceIcon(Index, Image);
  1279. finally
  1280. Patch.FinishInvokeOldMethod;
  1281. end;
  1282. end;
  1283. end;
  1284. end;
  1285. procedure TPngImageList.ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor);
  1286. var
  1287. Item: TPngImageCollectionItem;
  1288. Patch: TMethodPatch;
  1289. Icon: HICON;
  1290. begin
  1291. if TObject(Self) is TPngImageList then begin
  1292. //Replace an existing PNG based with a new image and a colored mask.
  1293. if NewImage <> nil then begin
  1294. BeginUpdate;
  1295. try
  1296. Item := FPngImages[Index];
  1297. CreatePNGMasked(NewImage, MaskColor, Item.PngImage);
  1298. Icon := PngToIcon(Item.PngImage, Item.Background);
  1299. ImageList_ReplaceIcon(Handle, Index, Icon);
  1300. DestroyIcon(Icon);
  1301. Change;
  1302. finally
  1303. EndUpdate(False);
  1304. end;
  1305. end
  1306. end
  1307. else begin
  1308. Patch := FindMethodPatch('ReplaceMasked');
  1309. if Patch <> nil then begin
  1310. Patch.BeginInvokeOldMethod;
  1311. try
  1312. TCustomImageList(Self).ReplaceMasked(Index, NewImage, MaskColor);
  1313. finally
  1314. Patch.FinishInvokeOldMethod;
  1315. end;
  1316. end;
  1317. end;
  1318. end;
  1319. procedure TPngImageList.SetEnabledImages(const Value: Boolean);
  1320. begin
  1321. if FEnabledImages xor Value then begin
  1322. FEnabledImages := Value;
  1323. CopyPngs;
  1324. end;
  1325. end;
  1326. procedure TPngImageList.SetHeight(const Value: Integer);
  1327. begin
  1328. if inherited Height <> Value then begin
  1329. inherited Height := Value;
  1330. Clear;
  1331. end;
  1332. end;
  1333. procedure TPngImageList.SetPngImages(const Value: TPngImageCollectionItems);
  1334. begin
  1335. if FPngImages <> Value then begin
  1336. FPngImages.Assign(Value);
  1337. Change;
  1338. end;
  1339. end;
  1340. procedure TPngImageList.SetPngOptions(const Value: TPngOptions);
  1341. begin
  1342. if FPngOptions <> Value then begin
  1343. FPngOptions := Value;
  1344. CopyPngs;
  1345. end;
  1346. end;
  1347. procedure TPngImageList.SetWidth(const Value: Integer);
  1348. begin
  1349. if inherited Width <> Value then begin
  1350. inherited Width := Value;
  1351. Clear;
  1352. end;
  1353. end;
  1354. procedure TPngImageList.WriteData(Stream: TStream);
  1355. begin
  1356. if not (csWriting in ComponentState) then
  1357. inherited;
  1358. //Make sure nothing gets written to the DFM
  1359. end;
  1360. { TPngImageCollection }
  1361. constructor TPngImageCollection.Create(AOwner: TComponent);
  1362. begin
  1363. inherited Create(AOwner);
  1364. FItems := TPngImageCollectionItems.Create(Self);
  1365. end;
  1366. destructor TPngImageCollection.Destroy;
  1367. begin
  1368. FItems.Free;
  1369. inherited Destroy;
  1370. end;
  1371. { TPngImageCollectionItems }
  1372. constructor TPngImageCollectionItems.Create(AOwner: TPersistent);
  1373. begin
  1374. inherited Create(TPngImageCollectionItem);
  1375. FOwner := AOwner;
  1376. end;
  1377. function TPngImageCollectionItems.Add(DontCreatePNG: Boolean = False): TPngImageCollectionItem;
  1378. begin
  1379. {$WARN SYMBOL_DEPRECATED OFF}
  1380. Result := TPngImageCollectionItem.Create(Self, DontCreatePNG);
  1381. Added(TCollectionItem(Result));
  1382. end;
  1383. procedure TPngImageCollectionItems.Assign(Source: TPersistent);
  1384. begin
  1385. inherited Assign(Source);
  1386. Update(nil);
  1387. end;
  1388. function TPngImageCollectionItems.GetItem(Index: Integer): TPngImageCollectionItem;
  1389. begin
  1390. if (Index >= 0) and (Index < Count) then
  1391. Result := TPngImageCollectionItem(inherited Items[Index])
  1392. else
  1393. Result := nil;
  1394. end;
  1395. function TPngImageCollectionItems.GetOwner: TPersistent;
  1396. begin
  1397. Result := FOwner;
  1398. end;
  1399. function TPngImageCollectionItems.Insert(Index: Integer; DontCreatePNG: Boolean = False): TPngImageCollectionItem;
  1400. begin
  1401. Result := Add(DontCreatePNG);
  1402. Result.Index := Index;
  1403. end;
  1404. procedure TPngImageCollectionItems.SetItem(Index: Integer; const Value: TPngImageCollectionItem);
  1405. begin
  1406. if (Index >= 0) and (Index < Count) then
  1407. inherited Items[Index] := Value;
  1408. end;
  1409. procedure TPngImageCollectionItems.Update(Item: TCollectionItem);
  1410. begin
  1411. inherited Update(Item);
  1412. if FOwner is TPngImageList then
  1413. TPngImageList(FOwner).CopyPngs;
  1414. end;
  1415. constructor TPngImageCollectionItem.Create(Collection: TCollection);
  1416. begin
  1417. inherited Create(Collection);
  1418. FPngImage := TPngImage.Create;
  1419. FName := Format('PngImage%d', [Index]);
  1420. FBackground := clBtnFace;
  1421. end;
  1422. constructor TPngImageCollectionItem.Create(Collection: TCollection; DontCreatePNG: Boolean = False);
  1423. begin
  1424. inherited Create(Collection);
  1425. if DontCreatePng then
  1426. FPngImage := nil
  1427. else
  1428. FPngImage := TPngImage.Create;
  1429. FName := Format('PngImage%d', [Index]);
  1430. FBackground := clBtnFace;
  1431. end;
  1432. destructor TPngImageCollectionItem.Destroy;
  1433. begin
  1434. FPngImage.Free;
  1435. inherited Destroy;
  1436. end;
  1437. procedure TPngImageCollectionItem.Assign(Source: TPersistent);
  1438. begin
  1439. if Source is TPngImageCollectionItem then begin
  1440. PngImage.Assign(TPngImageCollectionItem(Source).PngImage);
  1441. Background := TPngImageCollectionItem(Source).Background;
  1442. Name := TPngImageCollectionItem(Source).Name;
  1443. end
  1444. else
  1445. inherited Assign(Source);
  1446. end;
  1447. { TPngImageCollectionItem }
  1448. procedure TPngImageCollectionItem.AssignTo(Dest: TPersistent);
  1449. begin
  1450. inherited AssignTo(Dest);
  1451. if (Dest is TPngImageCollectionItem) then
  1452. TPngImageCollectionItem(Dest).PngImage := PngImage;
  1453. end;
  1454. function TPngImageCollectionItem.Duplicate: TPngImage;
  1455. begin
  1456. Result := TPngImage.Create;
  1457. Result.Assign(FPngImage);
  1458. end;
  1459. function TPngImageCollectionItem.GetDisplayName: string;
  1460. begin
  1461. if Length(FName) = 0 then
  1462. Result := inherited GetDisplayName
  1463. else
  1464. Result := FName;
  1465. end;
  1466. procedure TPngImageCollectionItem.SetBackground(const Value: TColor);
  1467. begin
  1468. if FBackground <> Value then begin
  1469. FBackground := Value;
  1470. Changed(False);
  1471. end;
  1472. end;
  1473. procedure TPngImageCollectionItem.SetPngImage(const Value: TPngImage);
  1474. begin
  1475. if FPngImage = nil then
  1476. FPngImage := TPngImage.Create;
  1477. FPngImage.Assign(Value);
  1478. Changed(False);
  1479. end;
  1480. initialization
  1481. finalization
  1482. MethodPatches.Free;
  1483. end.