PngImageList.pas 44 KB

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