ImagingComponents.pas 43 KB

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