src/lib/vampimg/ImagingComponents.pas

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