ImagingComponents.pas 44 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327
  1. {
  2. Vampyre Imaging Library
  3. by Marek Mauder
  4. http://imaginglib.sourceforge.net
  5. The contents of this file are used with permission, subject to the Mozilla
  6. Public License Version 1.1 (the "License"); you may not use this file except
  7. in compliance with the License. You may obtain a copy of the License at
  8. http://www.mozilla.org/MPL/MPL-1.1.html
  9. Software distributed under the License is distributed on an "AS IS" basis,
  10. WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  11. the specific language governing rights and limitations under the License.
  12. Alternatively, the contents of this file may be used under the terms of the
  13. GNU Lesser General Public License (the "LGPL License"), in which case the
  14. provisions of the LGPL License are applicable instead of those above.
  15. If you wish to allow use of your version of this file only under the terms
  16. of the LGPL License and not to allow others to use your version of this file
  17. under the MPL, indicate your decision by deleting the provisions above and
  18. replace them with the notice and other provisions required by the LGPL
  19. License. If you do not delete the provisions above, a recipient may use
  20. your version of this file under either the MPL or the LGPL License.
  21. For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  22. }
  23. { This unit contains VCL/LCL TGraphic descendant which uses Imaging library
  24. for saving and loading.}
  25. unit ImagingComponents;
  26. {$I ImagingOptions.inc}
  27. interface
  28. {$IF Defined(FPC) and Defined(LCL)}
  29. {$DEFINE COMPONENT_SET_LCL}
  30. {$ELSEIF Defined(DELPHI)}
  31. {$DEFINE COMPONENT_SET_VCL}
  32. {$IFEND}
  33. {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
  34. // If no component sets should be used just include empty unit.
  35. //DOC-IGNORE-BEGIN
  36. implementation
  37. //DOC-IGNORE-END
  38. {$ELSE}
  39. uses
  40. SysUtils, Types, Classes,
  41. {$IFDEF MSWINDOWS}
  42. Windows,
  43. {$ENDIF}
  44. {$IFDEF COMPONENT_SET_VCL}
  45. Graphics,
  46. {$ENDIF}
  47. {$IFDEF COMPONENT_SET_LCL}
  48. InterfaceBase,
  49. GraphType,
  50. Graphics,
  51. LCLType,
  52. LCLIntf,
  53. {$ENDIF}
  54. ImagingTypes, Imaging, ImagingClasses;
  55. type
  56. { Graphic class which uses Imaging to load images.
  57. It has standard TBitmap class as ancestor and it can
  58. Assign also to/from TImageData structres and TBaseImage
  59. classes. For saving is uses inherited TBitmap methods.
  60. This class is automatically registered to TPicture for all
  61. file extensions supported by Imaging (useful only for loading).
  62. If you just want to load images in various formats you can use this
  63. class or simply use TPicture.LoadFromXXX which will create this class
  64. automatically. For TGraphic class that saves with Imaging look
  65. at TImagingGraphicForSave class.}
  66. TImagingGraphic = class(TBitmap)
  67. protected
  68. procedure ReadDataFromStream(Stream: TStream); virtual;
  69. procedure AssignTo(Dest: TPersistent); override;
  70. public
  71. constructor Create; override;
  72. { Loads new image from the stream. It can load all image
  73. file formats supported by Imaging (and enabled of course)
  74. even though it is called by descendant class capable of
  75. saving only one file format.}
  76. procedure LoadFromStream(Stream: TStream); override;
  77. { Copies the image contained in Source to this graphic object.
  78. Supports also TBaseImage descendants from ImagingClasses unit. }
  79. procedure Assign(Source: TPersistent); override;
  80. { Copies the image contained in TBaseImage to this graphic object.}
  81. procedure AssignFromImage(Image: TBaseImage);
  82. { Copies the current image to TBaseImage object.}
  83. procedure AssignToImage(Image: TBaseImage);
  84. { Copies the image contained in TImageData structure to this graphic object.}
  85. procedure AssignFromImageData(const ImageData: TImageData);
  86. { Copies the current image to TImageData structure.}
  87. procedure AssignToImageData(var ImageData: TImageData);
  88. {$IFDEF FPC}
  89. class function IsStreamFormatSupported(Stream: TStream): boolean; override;
  90. {$ENDIF}
  91. end;
  92. TImagingGraphicClass = class of TImagingGraphic;
  93. { Base class for file format specific TGraphic classes that use
  94. Imaging for saving. Each descendant class can load all file formats
  95. supported by Imaging but save only one format (TImagingBitmap
  96. for *.bmp, TImagingJpeg for *.jpg). Format specific classes also
  97. allow easy access to Imaging options that affect saving of files
  98. (they are properties here).}
  99. TImagingGraphicForSave = class(TImagingGraphic)
  100. protected
  101. FDefaultFileExt: string;
  102. FSavingFormat: TImageFormat;
  103. procedure WriteDataToStream(Stream: TStream); virtual;
  104. public
  105. constructor Create; override;
  106. { Saves the current image to the stream. It is saved in the
  107. file format according to the DefaultFileExt property.
  108. So each descendant class can save some other file format.}
  109. procedure SaveToStream(Stream: TStream); override;
  110. { Returns TImageFileFormat descendant for this graphic class.}
  111. class function GetFileFormat: TImageFileFormat; virtual; abstract;
  112. {$IFDEF COMPONENT_SET_LCL}
  113. { Returns file extensions of this graphic class.}
  114. class function GetFileExtensions: string; override;
  115. { Returns default MIME type of this graphic class.}
  116. function GetMimeType: string; override;
  117. {$ENDIF}
  118. { Default (the most common) file extension of this graphic class.}
  119. property DefaultFileExt: string read FDefaultFileExt;
  120. end;
  121. TImagingGraphicForSaveClass = class of TImagingGraphicForSave;
  122. {$IFNDEF DONT_LINK_BITMAP}
  123. { TImagingGraphic descendant for loading/saving Windows bitmaps.
  124. VCL/LCL both have native support for bitmaps so you might
  125. want to disable this class (although you can save bitmaps with
  126. RLE compression with this class).}
  127. TImagingBitmap = class(TImagingGraphicForSave)
  128. protected
  129. FUseRLE: Boolean;
  130. public
  131. constructor Create; override;
  132. procedure SaveToStream(Stream: TStream); override;
  133. class function GetFileFormat: TImageFileFormat; override;
  134. { See ImagingBitmapRLE option for details.}
  135. property UseRLE: Boolean read FUseRLE write FUseRLE;
  136. end;
  137. {$ENDIF}
  138. {$IFNDEF DONT_LINK_JPEG}
  139. { TImagingGraphic descendant for loading/saving JPEG images.}
  140. TImagingJpeg = class(TImagingGraphicForSave)
  141. protected
  142. FQuality: LongInt;
  143. FProgressive: Boolean;
  144. public
  145. constructor Create; override;
  146. procedure SaveToStream(Stream: TStream); override;
  147. class function GetFileFormat: TImageFileFormat; override;
  148. {$IFDEF COMPONENT_SET_LCL}
  149. function GetMimeType: string; override;
  150. {$ENDIF}
  151. { See ImagingJpegQuality option for details.}
  152. property Quality: LongInt read FQuality write FQuality;
  153. { See ImagingJpegProgressive option for details.}
  154. property Progressive: Boolean read FProgressive write FProgressive;
  155. end;
  156. {$ENDIF}
  157. {$IFNDEF DONT_LINK_PNG}
  158. { TImagingGraphic descendant for loading/saving PNG images.}
  159. TImagingPNG = class(TImagingGraphicForSave)
  160. protected
  161. FPreFilter: LongInt;
  162. FCompressLevel: LongInt;
  163. public
  164. constructor Create; override;
  165. procedure SaveToStream(Stream: TStream); override;
  166. class function GetFileFormat: TImageFileFormat; override;
  167. { See ImagingPNGPreFilter option for details.}
  168. property PreFilter: LongInt read FPreFilter write FPreFilter;
  169. { See ImagingPNGCompressLevel option for details.}
  170. property CompressLevel: LongInt read FCompressLevel write FCompressLevel;
  171. end;
  172. {$ENDIF}
  173. {$IFNDEF DONT_LINK_GIF}
  174. { TImagingGraphic descendant for loading/saving GIF images.}
  175. TImagingGIF = class(TImagingGraphicForSave)
  176. public
  177. class function GetFileFormat: TImageFileFormat; override;
  178. end;
  179. {$ENDIF}
  180. {$IFNDEF DONT_LINK_TARGA}
  181. { TImagingGraphic descendant for loading/saving Targa images.}
  182. TImagingTarga = class(TImagingGraphicForSave)
  183. protected
  184. FUseRLE: Boolean;
  185. public
  186. constructor Create; override;
  187. procedure SaveToStream(Stream: TStream); override;
  188. class function GetFileFormat: TImageFileFormat; override;
  189. { See ImagingTargaRLE option for details.}
  190. property UseRLE: Boolean read FUseRLE write FUseRLE;
  191. end;
  192. {$ENDIF}
  193. {$IFNDEF DONT_LINK_DDS}
  194. { Compresssion type used when saving DDS files by TImagingDds.}
  195. TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5);
  196. { TImagingGraphic descendant for loading/saving DDS images.}
  197. TImagingDDS = class(TImagingGraphicForSave)
  198. protected
  199. FCompression: TDDSCompresion;
  200. public
  201. constructor Create; override;
  202. procedure SaveToStream(Stream: TStream); override;
  203. class function GetFileFormat: TImageFileFormat; override;
  204. { You can choose compression type used when saving DDS file.
  205. dcNone means that file will be saved in the current bitmaps pixel format.}
  206. property Compression: TDDSCompresion read FCompression write FCompression;
  207. end;
  208. {$ENDIF}
  209. {$IFNDEF DONT_LINK_MNG}
  210. { TImagingGraphic descendant for loading/saving MNG images.}
  211. TImagingMNG = class(TImagingGraphicForSave)
  212. protected
  213. FLossyCompression: Boolean;
  214. FLossyAlpha: Boolean;
  215. FPreFilter: LongInt;
  216. FCompressLevel: LongInt;
  217. FQuality: LongInt;
  218. FProgressive: Boolean;
  219. public
  220. constructor Create; override;
  221. procedure SaveToStream(Stream: TStream); override;
  222. class function GetFileFormat: TImageFileFormat; override;
  223. {$IFDEF COMPONENT_SET_LCL}
  224. function GetMimeType: string; override;
  225. {$ENDIF}
  226. { See ImagingMNGLossyCompression option for details.}
  227. property LossyCompression: Boolean read FLossyCompression write FLossyCompression;
  228. { See ImagingMNGLossyAlpha option for details.}
  229. property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha;
  230. { See ImagingMNGPreFilter option for details.}
  231. property PreFilter: LongInt read FPreFilter write FPreFilter;
  232. { See ImagingMNGCompressLevel option for details.}
  233. property CompressLevel: LongInt read FCompressLevel write FCompressLevel;
  234. { See ImagingMNGQuality option for details.}
  235. property Quality: LongInt read FQuality write FQuality;
  236. { See ImagingMNGProgressive option for details.}
  237. property Progressive: Boolean read FProgressive write FProgressive;
  238. end;
  239. {$ENDIF}
  240. {$IFNDEF DONT_LINK_JNG}
  241. { TImagingGraphic descendant for loading/saving JNG images.}
  242. TImagingJNG = class(TImagingGraphicForSave)
  243. protected
  244. FLossyAlpha: Boolean;
  245. FAlphaPreFilter: LongInt;
  246. FAlphaCompressLevel: LongInt;
  247. FQuality: LongInt;
  248. FProgressive: Boolean;
  249. public
  250. constructor Create; override;
  251. procedure SaveToStream(Stream: TStream); override;
  252. class function GetFileFormat: TImageFileFormat; override;
  253. { See ImagingJNGLossyAlpha option for details.}
  254. property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha;
  255. { See ImagingJNGPreFilter option for details.}
  256. property AlphaPreFilter: LongInt read FAlphaPreFilter write FAlphaPreFilter;
  257. { See ImagingJNGCompressLevel option for details.}
  258. property AlphaCompressLevel: LongInt read FAlphaCompressLevel write FAlphaCompressLevel;
  259. { See ImagingJNGQuality option for details.}
  260. property Quality: LongInt read FQuality write FQuality;
  261. { See ImagingJNGProgressive option for details.}
  262. property Progressive: Boolean read FProgressive write FProgressive;
  263. end;
  264. {$ENDIF}
  265. { Returns bitmap pixel format with the closest match with given data format.}
  266. function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat;
  267. { Returns data format with closest match with given bitmap pixel format.}
  268. function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat;
  269. { Converts TImageData structure to VCL/CLX/LCL bitmap.}
  270. procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap);
  271. { Converts VCL/CLX/LCL bitmap to TImageData structure.}
  272. procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData);
  273. { Converts TBaseImage instance to VCL/CLX/LCL bitmap.}
  274. procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap);
  275. { Converts VCL/CLX/LCL bitmap to TBaseImage. Image must exist before
  276. procedure is called. It overwrites its current image data.
  277. When Image is TMultiImage only the current image level is overwritten.}
  278. procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage);
  279. { Displays image stored in TImageData structure onto TCanvas. This procedure
  280. draws image without converting from Imaging format to TBitmap.
  281. Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
  282. when you want displaying images that change frequently (because converting to
  283. TBitmap by ConvertImageDataToBitmap is generally slow). Dest and Src
  284. rectangles represent coordinates in the form (X1, Y1, X2, Y2).}
  285. procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
  286. { Displays image onto TCanvas at position [DstX, DstY]. This procedure
  287. draws image without converting from Imaging format to TBitmap.
  288. Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
  289. when you want displaying images that change frequently (because converting to
  290. TBitmap by ConvertImageDataToBitmap is generally slow).}
  291. procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage); overload;
  292. { Displays image onto TCanvas to rectangle DstRect. This procedure
  293. draws image without converting from Imaging format to TBitmap.
  294. Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
  295. when you want displaying images that change frequently (because converting to
  296. TBitmap by ConvertImageDataToBitmap is generally slow).}
  297. procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage); overload;
  298. { Displays part of the image specified by SrcRect onto TCanvas to rectangle DstRect.
  299. This procedure draws image without converting from Imaging format to TBitmap.
  300. Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
  301. when you want displaying images that change frequently (because converting to
  302. TBitmap by ConvertImageDataToBitmap is generally slow).}
  303. procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect); overload;
  304. {$IFDEF MSWINDOWS}
  305. { Displays image stored in TImageData structure onto Windows device context.
  306. Behaviour is the same as of DisplayImageData.}
  307. procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
  308. {$ENDIF}
  309. procedure RegisterTypes;
  310. implementation
  311. uses
  312. {$IF Defined(LCL)}
  313. {$IF Defined(LCLGTK2)}
  314. GLib2, GDK2, GTK2, GTK2Def, GTK2Proc,
  315. {$IFEND}
  316. {$IFEND}
  317. {$IFNDEF DONT_LINK_BITMAP}
  318. ImagingBitmap,
  319. {$ENDIF}
  320. {$IFNDEF DONT_LINK_JPEG}
  321. ImagingJpeg,
  322. {$ENDIF}
  323. {$IFNDEF DONT_LINK_GIF}
  324. ImagingGif,
  325. {$ENDIF}
  326. {$IFNDEF DONT_LINK_TARGA}
  327. ImagingTarga,
  328. {$ENDIF}
  329. {$IFNDEF DONT_LINK_DDS}
  330. ImagingDds,
  331. {$ENDIF}
  332. {$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
  333. ImagingNetworkGraphics,
  334. {$IFEND}
  335. ImagingFormats, ImagingUtility;
  336. resourcestring
  337. SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s';
  338. SBadFormatBitmapToData = 'Cannot find compatible data format for bitmap %p';
  339. SBadFormatDisplay = 'Unsupported image format passed';
  340. SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set';
  341. SImagingGraphicName = 'Imaging Graphic AllInOne';
  342. var
  343. RegisteredFormats: TList;
  344. RegisteredGraphicsClasses: Boolean = False;
  345. { Registers types to VCL/LCL.
  346. In some cases (base+ext package installed in Lazarus) RegisterTypes can be
  347. called twice so must keep track of which formats were already registered. }
  348. procedure RegisterTypes;
  349. var
  350. I: LongInt;
  351. procedure RegisterFileFormatAllInOne(Format: TImageFileFormat);
  352. var
  353. I: LongInt;
  354. begin
  355. if RegisteredFormats.IndexOf(Format) >= 0 then
  356. Exit;
  357. for I := 0 to Format.Extensions.Count - 1 do
  358. begin
  359. TPicture.RegisterFileFormat(Format.Extensions[I], SImagingGraphicName,
  360. TImagingGraphic);
  361. end;
  362. RegisteredFormats.Add(Format);
  363. end;
  364. procedure RegisterFileFormat(AClass: TImagingGraphicForSaveClass);
  365. var
  366. I: LongInt;
  367. begin
  368. for I := 0 to AClass.GetFileFormat.Extensions.Count - 1 do
  369. TPicture.RegisterFileFormat(AClass.GetFileFormat.Extensions[I],
  370. AClass.GetFileFormat.Name, AClass);
  371. end;
  372. begin
  373. for I := Imaging.GetFileFormatCount - 1 downto 0 do
  374. RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I));
  375. Classes.RegisterClass(TImagingGraphic);
  376. if RegisteredGraphicsClasses then
  377. Exit;
  378. {$IFNDEF DONT_LINK_TARGA}
  379. RegisterFileFormat(TImagingTarga);
  380. Classes.RegisterClass(TImagingTarga);
  381. {$ENDIF}
  382. {$IFNDEF DONT_LINK_DDS}
  383. RegisterFileFormat(TImagingDDS);
  384. Classes.RegisterClass(TImagingDDS);
  385. {$ENDIF}
  386. {$IFNDEF DONT_LINK_JNG}
  387. RegisterFileFormat(TImagingJNG);
  388. Classes.RegisterClass(TImagingJNG);
  389. {$ENDIF}
  390. {$IFNDEF DONT_LINK_MNG}
  391. RegisterFileFormat(TImagingMNG);
  392. Classes.RegisterClass(TImagingMNG);
  393. {$ENDIF}
  394. {$IFNDEF DONT_LINK_GIF}
  395. RegisterFileFormat(TImagingGIF);
  396. Classes.RegisterClass(TImagingGIF);
  397. {$ENDIF}
  398. {$IFNDEF DONT_LINK_PNG}
  399. {$IFDEF COMPONENT_SET_LCL}
  400. // Unregister Lazarus´ default PNG loader which crashes on some PNG files
  401. TPicture.UnregisterGraphicClass(TPortableNetworkGraphic);
  402. {$ENDIF}
  403. RegisterFileFormat(TImagingPNG);
  404. Classes.RegisterClass(TImagingPNG);
  405. {$ENDIF}
  406. {$IFNDEF DONT_LINK_JPEG}
  407. RegisterFileFormat(TImagingJpeg);
  408. Classes.RegisterClass(TImagingJpeg);
  409. {$ENDIF}
  410. {$IFNDEF DONT_LINK_BITMAP}
  411. RegisterFileFormat(TImagingBitmap);
  412. Classes.RegisterClass(TImagingBitmap);
  413. {$ENDIF}
  414. RegisteredGraphicsClasses := True;
  415. end;
  416. { Unregisters types from VCL/LCL.}
  417. procedure UnRegisterTypes;
  418. begin
  419. {$IFNDEF DONT_LINK_BITMAP}
  420. TPicture.UnregisterGraphicClass(TImagingBitmap);
  421. Classes.UnRegisterClass(TImagingBitmap);
  422. {$ENDIF}
  423. {$IFNDEF DONT_LINK_JPEG}
  424. TPicture.UnregisterGraphicClass(TImagingJpeg);
  425. Classes.UnRegisterClass(TImagingJpeg);
  426. {$ENDIF}
  427. {$IFNDEF DONT_LINK_PNG}
  428. TPicture.UnregisterGraphicClass(TImagingPNG);
  429. Classes.UnRegisterClass(TImagingPNG);
  430. {$ENDIF}
  431. {$IFNDEF DONT_LINK_GIF}
  432. TPicture.UnregisterGraphicClass(TImagingGIF);
  433. Classes.UnRegisterClass(TImagingGIF);
  434. {$ENDIF}
  435. {$IFNDEF DONT_LINK_TARGA}
  436. TPicture.UnregisterGraphicClass(TImagingTarga);
  437. Classes.UnRegisterClass(TImagingTarga);
  438. {$ENDIF}
  439. {$IFNDEF DONT_LINK_DDS}
  440. TPicture.UnregisterGraphicClass(TImagingDDS);
  441. Classes.UnRegisterClass(TImagingDDS);
  442. {$ENDIF}
  443. TPicture.UnregisterGraphicClass(TImagingGraphic);
  444. Classes.UnRegisterClass(TImagingGraphic);
  445. end;
  446. function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat;
  447. begin
  448. case Format of
  449. {$IFDEF COMPONENT_SET_VCL}
  450. ifIndex8: Result := pf8bit;
  451. ifR5G6B5: Result := pf16bit;
  452. ifR8G8B8: Result := pf24bit;
  453. {$ENDIF}
  454. ifA8R8G8B8,
  455. ifX8R8G8B8: Result := pf32bit;
  456. else
  457. Result := pfCustom;
  458. end;
  459. end;
  460. function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat;
  461. begin
  462. case Format of
  463. pf8bit: Result := ifIndex8;
  464. pf15bit: Result := ifA1R5G5B5;
  465. pf16bit: Result := ifR5G6B5;
  466. pf24bit: Result := ifR8G8B8;
  467. pf32bit: Result := ifA8R8G8B8;
  468. else
  469. Result := ifUnknown;
  470. end;
  471. end;
  472. procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap);
  473. var
  474. PF: TPixelFormat;
  475. Info: TImageFormatInfo;
  476. WorkData: TImageData;
  477. {$IFDEF COMPONENT_SET_VCL}
  478. I, LineBytes: LongInt;
  479. LogPalette: TMaxLogPalette;
  480. {$ENDIF}
  481. {$IFDEF COMPONENT_SET_LCL}
  482. RawImage: TRawImage;
  483. ImgHandle, ImgMaskHandle: HBitmap;
  484. {$ENDIF}
  485. begin
  486. PF := DataFormatToPixelFormat(Data.Format);
  487. GetImageFormatInfo(Data.Format, Info);
  488. if (PF = pf8bit) and PaletteHasAlpha(Data.Palette, Info.PaletteEntries) then
  489. begin
  490. // Some indexed images may have valid alpha data, dont lose it!
  491. // (e.g. transparent 8bit PNG or GIF images)
  492. PF := pfCustom;
  493. end;
  494. if PF = pfCustom then
  495. begin
  496. // Convert from formats not supported by Graphics unit
  497. Imaging.InitImage(WorkData);
  498. Imaging.CloneImage(Data, WorkData);
  499. if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then
  500. Imaging.ConvertImage(WorkData, ifA8R8G8B8)
  501. else
  502. begin
  503. {$IFDEF COMPONENT_SET_VCL}
  504. if Info.IsIndexed or Info.HasGrayChannel then
  505. Imaging.ConvertImage(WorkData, ifIndex8)
  506. else if Info.UsePixelFormat then
  507. Imaging.ConvertImage(WorkData, ifR5G6B5)
  508. else
  509. Imaging.ConvertImage(WorkData, ifR8G8B8);
  510. {$ELSE}
  511. Imaging.ConvertImage(WorkData, ifA8R8G8B8);
  512. {$ENDIF}
  513. end;
  514. PF := DataFormatToPixelFormat(WorkData.Format);
  515. GetImageFormatInfo(WorkData.Format, Info);
  516. end
  517. else
  518. WorkData := Data;
  519. if PF = pfCustom then
  520. RaiseImaging(SBadFormatDataToBitmap, [ImageToStr(WorkData)]);
  521. {$IFDEF COMPONENT_SET_VCL}
  522. Bitmap.Width := WorkData.Width;
  523. Bitmap.Height := WorkData.Height;
  524. Bitmap.PixelFormat := PF;
  525. if (PF = pf8bit) and (WorkData.Palette <> nil) then
  526. begin
  527. // Copy palette, this must be done before copying bits
  528. FillChar(LogPalette, SizeOf(LogPalette), 0);
  529. LogPalette.palVersion := $300;
  530. LogPalette.palNumEntries := Info.PaletteEntries;
  531. for I := 0 to Info.PaletteEntries - 1 do
  532. with LogPalette do
  533. begin
  534. palPalEntry[I].peRed := WorkData.Palette[I].R;
  535. palPalEntry[I].peGreen := WorkData.Palette[I].G;
  536. palPalEntry[I].peBlue := WorkData.Palette[I].B;
  537. end;
  538. Bitmap.Palette := CreatePalette(PLogPalette(@LogPalette)^);
  539. end;
  540. // Copy scanlines
  541. LineBytes := WorkData.Width * Info.BytesPerPixel;
  542. for I := 0 to WorkData.Height - 1 do
  543. Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes);
  544. // Delphi 2009 and newer support alpha transparency for TBitmap
  545. {$IF Defined(DELPHI) and (CompilerVersion >= 20.0)}
  546. if Bitmap.PixelFormat = pf32bit then
  547. Bitmap.AlphaFormat := afDefined;
  548. {$IFEND}
  549. {$ENDIF}
  550. {$IFDEF COMPONENT_SET_LCL}
  551. // Create 32bit raw image from image data
  552. FillChar(RawImage, SizeOf(RawImage), 0);
  553. with RawImage.Description do
  554. begin
  555. Width := WorkData.Width;
  556. Height := WorkData.Height;
  557. BitsPerPixel := 32;
  558. Format := ricfRGBA;
  559. LineEnd := rileDWordBoundary;
  560. BitOrder := riboBitsInOrder;
  561. ByteOrder := riboLSBFirst;
  562. LineOrder := riloTopToBottom;
  563. AlphaPrec := 8;
  564. RedPrec := 8;
  565. GreenPrec := 8;
  566. BluePrec := 8;
  567. AlphaShift := 24;
  568. RedShift := 16;
  569. GreenShift := 8;
  570. BlueShift := 0;
  571. Depth := 32; // Must be 32 for alpha blending (and for working in MacOSX Carbon)
  572. end;
  573. RawImage.Data := WorkData.Bits;
  574. RawImage.DataSize := WorkData.Size;
  575. // Create bitmap from raw image
  576. if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle) then
  577. begin
  578. Bitmap.Handle := ImgHandle;
  579. Bitmap.MaskHandle := ImgMaskHandle;
  580. end;
  581. {$ENDIF}
  582. if WorkData.Bits <> Data.Bits then
  583. Imaging.FreeImage(WorkData);
  584. end;
  585. procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData);
  586. var
  587. I, LineBytes: LongInt;
  588. Format: TImageFormat;
  589. Info: TImageFormatInfo;
  590. {$IFDEF COMPONENT_SET_VCL}
  591. Colors: Word;
  592. LogPalette: TMaxLogPalette;
  593. {$ENDIF}
  594. {$IFDEF COMPONENT_SET_LCL}
  595. RawImage: TRawImage;
  596. LineLazBytes: LongInt;
  597. {$ENDIF}
  598. begin
  599. {$IFDEF COMPONENT_SET_LCL}
  600. // In the current Lazarus 0.9.10 Bitmap.PixelFormat property is useless.
  601. // We cannot change bitmap's format by changing it (it will just release
  602. // old image but not convert it to new format) nor we can determine bitmaps's
  603. // current format (it is usually set to pfDevice). So bitmap's format is obtained
  604. // trough RawImage api and cannot be changed to mirror some Imaging format
  605. // (so formats with no coresponding Imaging format cannot be saved now).
  606. if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then
  607. case RawImage.Description.BitsPerPixel of
  608. 8: Format := ifIndex8;
  609. 16:
  610. if RawImage.Description.Depth = 15 then
  611. Format := ifA1R5G5B5
  612. else
  613. Format := ifR5G6B5;
  614. 24: Format := ifR8G8B8;
  615. 32: Format := ifA8R8G8B8;
  616. 48: Format := ifR16G16B16;
  617. 64: Format := ifA16R16G16B16;
  618. else
  619. Format := ifUnknown;
  620. end;
  621. {$ELSE}
  622. Format := PixelFormatToDataFormat(Bitmap.PixelFormat);
  623. if Format = ifUnknown then
  624. begin
  625. // Convert from formats not supported by Imaging (1/4 bit)
  626. if Bitmap.PixelFormat < pf8bit then
  627. Bitmap.PixelFormat := pf8bit
  628. else
  629. Bitmap.PixelFormat := pf32bit;
  630. Format := PixelFormatToDataFormat(Bitmap.PixelFormat);
  631. end;
  632. {$ENDIF}
  633. if Format = ifUnknown then
  634. RaiseImaging(SBadFormatBitmapToData, []);
  635. Imaging.NewImage(Bitmap.Width, Bitmap.Height, Format, Data);
  636. GetImageFormatInfo(Data.Format, Info);
  637. LineBytes := Data.Width * Info.BytesPerPixel;
  638. {$IFDEF COMPONENT_SET_VCL}
  639. if (Format = ifIndex8) and (GetObject(Bitmap.Palette, SizeOf(Colors),
  640. @Colors) <> 0) then
  641. begin
  642. // Copy palette
  643. GetPaletteEntries(Bitmap.Palette, 0, Colors, LogPalette.palPalEntry);
  644. if Colors > Info.PaletteEntries then
  645. Colors := Info.PaletteEntries;
  646. for I := 0 to Colors - 1 do
  647. with LogPalette do
  648. begin
  649. Data.Palette[I].A := $FF;
  650. Data.Palette[I].R := palPalEntry[I].peRed;
  651. Data.Palette[I].G := palPalEntry[I].peGreen;
  652. Data.Palette[I].B := palPalEntry[I].peBlue;
  653. end;
  654. end;
  655. // Copy scanlines
  656. for I := 0 to Data.Height - 1 do
  657. Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes);
  658. {$ENDIF}
  659. {$IFDEF COMPONENT_SET_LCL}
  660. // Get raw image from bitmap (mask handle must be 0 or expect violations)
  661. if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then
  662. begin
  663. LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel,
  664. RawImage.Description.LineEnd);
  665. // Copy scanlines
  666. for I := 0 to Data.Height - 1 do
  667. begin
  668. Move(PByteArray(RawImage.Data)[I * LineLazBytes],
  669. PByteArray(Data.Bits)[I * LineBytes], LineBytes);
  670. end;
  671. // May need to swap RB order, depends on widget set
  672. if RawImage.Description.BlueShift > RawImage.Description.RedShift then
  673. SwapChannels(Data, ChannelRed, ChannelBlue);
  674. RawImage.FreeData;
  675. end;
  676. {$ENDIF}
  677. end;
  678. procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap);
  679. begin
  680. ConvertDataToBitmap(Image.ImageDataPointer^, Bitmap);
  681. end;
  682. procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage);
  683. begin
  684. ConvertBitmapToData(Bitmap, Image.ImageDataPointer^);
  685. end;
  686. {$IFDEF MSWINDOWS}
  687. procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
  688. var
  689. OldMode: Integer;
  690. BitmapInfo: Windows.TBitmapInfo;
  691. Bmp: TBitmap;
  692. begin
  693. if TestImage(ImageData) then
  694. begin
  695. Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay);
  696. OldMode := Windows.SetStretchBltMode(DC, COLORONCOLOR);
  697. FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
  698. with BitmapInfo.bmiHeader do
  699. begin
  700. biSize := SizeOf(TBitmapInfoHeader);
  701. biPlanes := 1;
  702. biBitCount := 32;
  703. biCompression := BI_RGB;
  704. biWidth := ImageData.Width;
  705. biHeight := -ImageData.Height;
  706. biSizeImage := ImageData.Size;
  707. biXPelsPerMeter := 0;
  708. biYPelsPerMeter := 0;
  709. biClrUsed := 0;
  710. biClrImportant := 0;
  711. end;
  712. try
  713. with SrcRect, ImageData do
  714. if Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top,
  715. DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left,
  716. Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then
  717. begin
  718. // StretchDIBits may fail on some ocassions (error 487, http://support.microsoft.com/kb/269585).
  719. // This fallback is slow but works every time. Thanks to Sergey Galezdinov for the fix.
  720. Bmp := TBitmap.Create;
  721. try
  722. ConvertDataToBitmap(ImageData, Bmp);
  723. StretchBlt(DC, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top,
  724. Bmp.Canvas.Handle, 0, 0, Width, Height, SRCCOPY);
  725. finally
  726. Bmp.Free;
  727. end;
  728. end;
  729. finally
  730. Windows.SetStretchBltMode(DC, OldMode);
  731. end;
  732. end;
  733. end;
  734. {$ENDIF}
  735. procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
  736. {$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32
  737. begin
  738. DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect);
  739. end;
  740. {$ELSEIF Defined(LCLGTK2)}
  741. procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
  742. SrcWidth, SrcHeight: Integer; ImageData: TImageData);
  743. var
  744. P: TPoint;
  745. begin
  746. P := TGtkDeviceContext(Dest).Offset;
  747. Inc(DstX, P.X);
  748. Inc(DstY, P.Y);
  749. gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC,
  750. DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
  751. @PUInt32Array(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
  752. end;
  753. var
  754. DisplayImage: TImageData;
  755. NewWidth, NewHeight: Integer;
  756. SrcBounds, DstBounds, DstClip: TRect;
  757. begin
  758. if TestImage(ImageData) then
  759. begin
  760. Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay);
  761. InitImage(DisplayImage);
  762. SrcBounds := RectToBounds(SrcRect);
  763. DstBounds := RectToBounds(DstRect);
  764. WidgetSet.GetClipBox(DstCanvas.Handle, @DstClip);
  765. ClipStretchBounds(SrcBounds.Left, SrcBounds.Top, SrcBounds.Right, SrcBounds.Bottom,
  766. DstBounds.Left, DstBounds.Top, DstBounds.Right, DstBounds.Bottom, ImageData.Width,
  767. ImageData.Height, DstClip);
  768. NewWidth := DstBounds.Right;
  769. NewHeight := DstBounds.Bottom;
  770. if (NewWidth > 0) and (NewHeight > 0) then
  771. begin
  772. if (SrcBounds.Right = NewWidth) and (SrcBounds.Bottom = NewHeight) then
  773. try
  774. CloneImage(ImageData, DisplayImage);
  775. // Swap R-B channels for GTK display compatability!
  776. SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
  777. GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top,
  778. SrcBounds.Left, SrcBounds.Top, NewWidth, NewHeight, DisplayImage);
  779. finally
  780. FreeImage(DisplayImage);
  781. end
  782. else
  783. try
  784. // Create new image with desired dimensions
  785. NewImage(NewWidth, NewHeight, ImageData.Format, DisplayImage);
  786. // Stretch pixels from old image to new one TResizeFilter = (rfNearest, rfBilinear, rfBicubic);
  787. StretchRect(ImageData, SrcBounds.Left, SrcBounds.Top, SrcBounds.Right,
  788. SrcBounds.Bottom, DisplayImage, 0, 0, NewWidth, NewHeight, rfNearest);
  789. // Swap R-B channels for GTK display compatability!
  790. SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
  791. GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, 0, 0,
  792. NewWidth, NewHeight, DisplayImage);
  793. finally
  794. FreeImage(DisplayImage);
  795. end
  796. end;
  797. end;
  798. end;
  799. {$ELSE}
  800. begin
  801. raise Exception.Create(SUnsupportedLCLWidgetSet);
  802. end;
  803. {$IFEND}
  804. procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage);
  805. begin
  806. DisplayImageData(DstCanvas, BoundsToRect(DstX, DstY, Image.Width, Image.Height),
  807. Image.ImageDataPointer^, Image.BoundsRect);
  808. end;
  809. procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage);
  810. begin
  811. DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, Image.BoundsRect);
  812. end;
  813. procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect);
  814. begin
  815. DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, SrcRect);
  816. end;
  817. { TImagingGraphic class implementation }
  818. constructor TImagingGraphic.Create;
  819. begin
  820. inherited Create;
  821. PixelFormat := pf24Bit;
  822. end;
  823. procedure TImagingGraphic.LoadFromStream(Stream: TStream);
  824. begin
  825. ReadDataFromStream(Stream);
  826. end;
  827. procedure TImagingGraphic.ReadDataFromStream(Stream: TStream);
  828. var
  829. Image: TSingleImage;
  830. begin
  831. Image := TSingleImage.Create;
  832. try
  833. Image.LoadFromStream(Stream);
  834. Assign(Image);
  835. finally
  836. Image.Free;
  837. end;
  838. end;
  839. procedure TImagingGraphic.AssignTo(Dest: TPersistent);
  840. var
  841. Arr: TDynImageDataArray;
  842. begin
  843. if Dest is TSingleImage then
  844. begin
  845. AssignToImage(TSingleImage(Dest))
  846. end
  847. else if Dest is TMultiImage then
  848. begin
  849. SetLength(Arr, 1);
  850. AssignToImageData(Arr[0]);
  851. TMultiImage(Dest).CreateFromArray(Arr);
  852. Imaging.FreeImagesInArray(Arr);
  853. end
  854. else
  855. inherited AssignTo(Dest);
  856. end;
  857. {$IFDEF FPC}
  858. class function TImagingGraphic.IsStreamFormatSupported(Stream: TStream): Boolean;
  859. begin
  860. Result := DetermineStreamFormat(Stream) <> '';
  861. end;
  862. {$ENDIF}
  863. procedure TImagingGraphic.Assign(Source: TPersistent);
  864. begin
  865. if Source is TBaseImage then
  866. AssignFromImage(TBaseImage(Source))
  867. else
  868. inherited Assign(Source);
  869. end;
  870. procedure TImagingGraphic.AssignFromImage(Image: TBaseImage);
  871. begin
  872. if (Image <> nil) and Image.Valid then
  873. AssignFromImageData(Image.ImageDataPointer^);
  874. end;
  875. procedure TImagingGraphic.AssignToImage(Image: TBaseImage);
  876. begin
  877. if (Image <> nil) and (Image.ImageDataPointer <> nil) then
  878. AssignToImageData(Image.ImageDataPointer^);
  879. end;
  880. procedure TImagingGraphic.AssignFromImageData(const ImageData: TImageData);
  881. begin
  882. if Imaging.TestImage(ImageData) then
  883. ConvertDataToBitmap(ImageData, Self);
  884. end;
  885. procedure TImagingGraphic.AssignToImageData(var ImageData: TImageData);
  886. begin
  887. Imaging.FreeImage(ImageData);
  888. ConvertBitmapToData(Self, ImageData);
  889. end;
  890. { TImagingGraphicForSave class implementation }
  891. constructor TImagingGraphicForSave.Create;
  892. begin
  893. inherited Create;
  894. FDefaultFileExt := GetFileFormat.Extensions[0];
  895. FSavingFormat := ifUnknown;
  896. GetFileFormat.CheckOptionsValidity;
  897. end;
  898. procedure TImagingGraphicForSave.WriteDataToStream(Stream: TStream);
  899. var
  900. Image: TSingleImage;
  901. begin
  902. if FDefaultFileExt <> '' then
  903. begin
  904. Image := TSingleImage.Create;
  905. try
  906. Image.Assign(Self);
  907. if FSavingFormat <> ifUnknown then
  908. Image.Format := FSavingFormat;
  909. Image.SaveToStream(FDefaultFileExt, Stream);
  910. finally
  911. Image.Free;
  912. end;
  913. end;
  914. end;
  915. procedure TImagingGraphicForSave.SaveToStream(Stream: TStream);
  916. begin
  917. WriteDataToStream(Stream);
  918. end;
  919. {$IFDEF COMPONENT_SET_LCL}
  920. class function TImagingGraphicForSave.GetFileExtensions: string;
  921. begin
  922. Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]);
  923. end;
  924. function TImagingGraphicForSave.GetMimeType: string;
  925. begin
  926. Result := 'image/' + FDefaultFileExt;
  927. end;
  928. {$ENDIF}
  929. {$IFNDEF DONT_LINK_BITMAP}
  930. { TImagingBitmap class implementation }
  931. constructor TImagingBitmap.Create;
  932. begin
  933. inherited Create;
  934. FUseRLE := (GetFileFormat as TBitmapFileFormat).UseRLE;
  935. end;
  936. class function TImagingBitmap.GetFileFormat: TImageFileFormat;
  937. begin
  938. Result := FindImageFileFormatByClass(TBitmapFileFormat);
  939. end;
  940. procedure TImagingBitmap.SaveToStream(Stream: TStream);
  941. begin
  942. Imaging.PushOptions;
  943. Imaging.SetOption(ImagingBitmapRLE, Ord(FUseRLE));
  944. inherited SaveToStream(Stream);
  945. Imaging.PopOptions;
  946. end;
  947. {$ENDIF}
  948. {$IFNDEF DONT_LINK_JPEG}
  949. { TImagingJpeg class implementation }
  950. constructor TImagingJpeg.Create;
  951. begin
  952. inherited Create;
  953. FQuality := (GetFileFormat as TJpegFileFormat).Quality;
  954. FProgressive := (GetFileFormat as TJpegFileFormat).Progressive;
  955. end;
  956. class function TImagingJpeg.GetFileFormat: TImageFileFormat;
  957. begin
  958. Result := FindImageFileFormatByClass(TJpegFileFormat);
  959. end;
  960. {$IFDEF COMPONENT_SET_LCL}
  961. function TImagingJpeg.GetMimeType: string;
  962. begin
  963. Result := 'image/jpeg';
  964. end;
  965. {$ENDIF}
  966. procedure TImagingJpeg.SaveToStream(Stream: TStream);
  967. begin
  968. Imaging.PushOptions;
  969. Imaging.SetOption(ImagingJpegQuality, FQuality);
  970. Imaging.SetOption(ImagingJpegProgressive, Ord(FProgressive));
  971. inherited SaveToStream(Stream);
  972. Imaging.PopOptions;
  973. end;
  974. {$ENDIF}
  975. {$IFNDEF DONT_LINK_PNG}
  976. { TImagingPNG class implementation }
  977. constructor TImagingPNG.Create;
  978. begin
  979. inherited Create;
  980. FPreFilter := (GetFileFormat as TPNGFileFormat).PreFilter;
  981. FCompressLevel := (GetFileFormat as TPNGFileFormat).CompressLevel;
  982. end;
  983. class function TImagingPNG.GetFileFormat: TImageFileFormat;
  984. begin
  985. Result := FindImageFileFormatByClass(TPNGFileFormat);
  986. end;
  987. procedure TImagingPNG.SaveToStream(Stream: TStream);
  988. begin
  989. Imaging.PushOptions;
  990. Imaging.SetOption(ImagingPNGPreFilter, FPreFilter);
  991. Imaging.SetOption(ImagingPNGCompressLevel, FCompressLevel);
  992. inherited SaveToStream(Stream);
  993. Imaging.PopOptions;
  994. end;
  995. {$ENDIF}
  996. {$IFNDEF DONT_LINK_GIF}
  997. { TImagingGIF class implementation}
  998. class function TImagingGIF.GetFileFormat: TImageFileFormat;
  999. begin
  1000. Result := FindImageFileFormatByClass(TGIFFileFormat);
  1001. end;
  1002. {$ENDIF}
  1003. {$IFNDEF DONT_LINK_TARGA}
  1004. { TImagingTarga class implementation }
  1005. constructor TImagingTarga.Create;
  1006. begin
  1007. inherited Create;
  1008. FUseRLE := (GetFileFormat as TTargaFileFormat).UseRLE;
  1009. end;
  1010. class function TImagingTarga.GetFileFormat: TImageFileFormat;
  1011. begin
  1012. Result := FindImageFileFormatByClass(TTargaFileFormat);
  1013. end;
  1014. procedure TImagingTarga.SaveToStream(Stream: TStream);
  1015. begin
  1016. Imaging.PushOptions;
  1017. Imaging.SetOption(ImagingTargaRLE, Ord(FUseRLE));
  1018. inherited SaveToStream(Stream);
  1019. Imaging.PopOptions;
  1020. end;
  1021. {$ENDIF}
  1022. {$IFNDEF DONT_LINK_DDS}
  1023. { TImagingDDS class implementation }
  1024. constructor TImagingDDS.Create;
  1025. begin
  1026. inherited Create;
  1027. FCompression := dcNone;
  1028. end;
  1029. class function TImagingDDS.GetFileFormat: TImageFileFormat;
  1030. begin
  1031. Result := FindImageFileFormatByClass(TDDSFileFormat);
  1032. end;
  1033. procedure TImagingDDS.SaveToStream(Stream: TStream);
  1034. begin
  1035. case FCompression of
  1036. dcNone: FSavingFormat := ifUnknown;
  1037. dcDXT1: FSavingFormat := ifDXT1;
  1038. dcDXT3: FSavingFormat := ifDXT3;
  1039. dcDXT5: FSavingFormat := ifDXT5;
  1040. end;
  1041. Imaging.PushOptions;
  1042. Imaging.SetOption(ImagingDDSSaveCubeMap, Ord(False));
  1043. Imaging.SetOption(ImagingDDSSaveVolume, Ord(False));
  1044. Imaging.SetOption(ImagingDDSSaveMipMapCount, 1);
  1045. Imaging.SetOption(ImagingDDSSaveDepth, 1);
  1046. inherited SaveToStream(Stream);
  1047. Imaging.PopOptions;
  1048. end;
  1049. {$ENDIF}
  1050. {$IFNDEF DONT_LINK_MNG}
  1051. { TImagingMNG class implementation }
  1052. constructor TImagingMNG.Create;
  1053. begin
  1054. inherited Create;
  1055. FLossyCompression := (GetFileFormat as TMNGFileFormat).LossyCompression;
  1056. FLossyAlpha := (GetFileFormat as TMNGFileFormat).LossyAlpha;
  1057. FPreFilter := (GetFileFormat as TMNGFileFormat).PreFilter;
  1058. FCompressLevel := (GetFileFormat as TMNGFileFormat).CompressLevel;
  1059. FQuality := (GetFileFormat as TMNGFileFormat).Quality;
  1060. FProgressive := (GetFileFormat as TMNGFileFormat).Progressive;
  1061. end;
  1062. class function TImagingMNG.GetFileFormat: TImageFileFormat;
  1063. begin
  1064. Result := FindImageFileFormatByClass(TMNGFileFormat);
  1065. end;
  1066. {$IFDEF COMPONENT_SET_LCL}
  1067. function TImagingMNG.GetMimeType: string;
  1068. begin
  1069. Result := 'video/mng';
  1070. end;
  1071. {$ENDIF}
  1072. procedure TImagingMNG.SaveToStream(Stream: TStream);
  1073. begin
  1074. Imaging.PushOptions;
  1075. Imaging.SetOption(ImagingMNGLossyCompression, Ord(FLossyCompression));
  1076. Imaging.SetOption(ImagingMNGLossyAlpha, Ord(FLossyAlpha));
  1077. Imaging.SetOption(ImagingMNGPreFilter, FPreFilter);
  1078. Imaging.SetOption(ImagingMNGCompressLevel, FCompressLevel);
  1079. Imaging.SetOption(ImagingMNGQuality, FQuality);
  1080. Imaging.SetOption(ImagingMNGProgressive, Ord(FProgressive));
  1081. inherited SaveToStream(Stream);
  1082. Imaging.PopOptions;
  1083. end;
  1084. {$ENDIF}
  1085. {$IFNDEF DONT_LINK_JNG}
  1086. { TImagingJNG class implementation }
  1087. constructor TImagingJNG.Create;
  1088. begin
  1089. inherited Create;
  1090. FLossyAlpha := (GetFileFormat as TJNGFileFormat).LossyAlpha;
  1091. FAlphaPreFilter := (GetFileFormat as TJNGFileFormat).PreFilter;
  1092. FAlphaCompressLevel := (GetFileFormat as TJNGFileFormat).CompressLevel;
  1093. FQuality := (GetFileFormat as TJNGFileFormat).Quality;
  1094. FProgressive := (GetFileFormat as TJNGFileFormat).Progressive;
  1095. end;
  1096. class function TImagingJNG.GetFileFormat: TImageFileFormat;
  1097. begin
  1098. Result := FindImageFileFormatByClass(TJNGFileFormat);
  1099. end;
  1100. procedure TImagingJNG.SaveToStream(Stream: TStream);
  1101. begin
  1102. Imaging.PushOptions;
  1103. Imaging.SetOption(ImagingJNGLossyALpha, Ord(FLossyAlpha));
  1104. Imaging.SetOption(ImagingJNGAlphaPreFilter, FAlphaPreFilter);
  1105. Imaging.SetOption(ImagingJNGAlphaCompressLevel, FAlphaCompressLevel);
  1106. Imaging.SetOption(ImagingJNGQuality, FQuality);
  1107. Imaging.SetOption(ImagingJNGProgressive, Ord(FProgressive));
  1108. inherited SaveToStream(Stream);
  1109. Imaging.PopOptions;
  1110. end;
  1111. {$ENDIF}
  1112. initialization
  1113. RegisteredFormats := TList.Create;
  1114. RegisterTypes;
  1115. finalization
  1116. UnRegisterTypes;
  1117. RegisteredFormats.Free;
  1118. {$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
  1119. {
  1120. File Notes:
  1121. -- TODOS ----------------------------------------------------
  1122. - nothing now
  1123. -- 0.77.1 ---------------------------------------------------
  1124. - Fixed bug in ConvertBitmapToData causing images from GTK2 bitmaps
  1125. to have swapped RB channels.
  1126. - LCL: Removed GTK1 support (deprecated).
  1127. -- 0.26.3 Changes/Bug Fixes ---------------------------------
  1128. - Transparency of 8bit images (like loaded from 8bit PNG or GIF) is
  1129. kept intact during conversion to TBitmap in ConvertDataToBitmap
  1130. (32bit bitmap is created).
  1131. -- 0.26.3 Changes/Bug Fixes ---------------------------------
  1132. - Setting AlphaFormat property of TBitmap in ConvertDataToBitmap
  1133. when using Delphi 2009+.
  1134. - Fixed garbled LCL TBitmaps created by ConvertDataToBitmap
  1135. in Mac OS X (Carbon).
  1136. -- 0.26.1 Changes/Bug Fixes ---------------------------------
  1137. - Added some more IFDEFs for Lazarus widget sets.
  1138. - Removed CLX code.
  1139. - GTK version of Unix DisplayImageData only used with LCL GTK so the
  1140. the rest of the unit can be used with Qt or other LCL interfaces.
  1141. - Fallback mechanism for DisplayImageDataOnDC, it may fail on occasions.
  1142. - Changed file format conditional compilation to reflect changes
  1143. in LINK symbols.
  1144. - Lazarus 0.9.26 compatibility changes.
  1145. -- 0.24.1 Changes/Bug Fixes ---------------------------------
  1146. - Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus
  1147. with GTK2 target.
  1148. - Added commnets with code for Lazarus rev. 11861+ regarding
  1149. RawImage interface. Replace current code with that in comments
  1150. if you use Lazarus from SVN. New RawImage interface will be used by
  1151. default after next Lazarus release.
  1152. -- 0.23 Changes/Bug Fixes -----------------------------------
  1153. - Added TImagingGIF.
  1154. -- 0.21 Changes/Bug Fixes -----------------------------------
  1155. - Uses only high level interface now (except for saving options).
  1156. - Slightly changed class hierarchy. TImagingGraphic is now only for loading
  1157. and base class for savers is new TImagingGraphicForSave. Also
  1158. TImagingGraphic is now registered with all supported file formats
  1159. by TPicture's format support.
  1160. -- 0.19 Changes/Bug Fixes -----------------------------------
  1161. - added DisplayImage procedures (thanks to Paul Michell, modified)
  1162. - removed RegisterTypes and UnRegisterTypes from interface section,
  1163. they are called automatically
  1164. - added procedures: ConvertImageToBitmap and ConvertBitmapToImage
  1165. -- 0.17 Changes/Bug Fixes -----------------------------------
  1166. - LCL data to bitmap conversion didn´t work in Linux, fixed
  1167. - added MNG file format
  1168. - added JNG file format
  1169. -- 0.15 Changes/Bug Fixes -----------------------------------
  1170. - made it LCL compatible
  1171. - made it CLX compatible
  1172. - added all initial stuff
  1173. }
  1174. end.