You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1308 lines
42 KiB
1308 lines
42 KiB
{
|
|
Vampyre Imaging Library
|
|
by Marek Mauder
|
|
http://imaginglib.sourceforge.net
|
|
|
|
The contents of this file are used with permission, subject to the Mozilla
|
|
Public License Version 1.1 (the "License"); you may not use this file except
|
|
in compliance with the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL/MPL-1.1.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
Alternatively, the contents of this file may be used under the terms of the
|
|
GNU Lesser General Public License (the "LGPL License"), in which case the
|
|
provisions of the LGPL License are applicable instead of those above.
|
|
If you wish to allow use of your version of this file only under the terms
|
|
of the LGPL License and not to allow others to use your version of this file
|
|
under the MPL, indicate your decision by deleting the provisions above and
|
|
replace them with the notice and other provisions required by the LGPL
|
|
License. If you do not delete the provisions above, a recipient may use
|
|
your version of this file under either the MPL or the LGPL License.
|
|
|
|
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
|
|
}
|
|
|
|
{ This unit contains VCL/LCL TGraphic descendant which uses Imaging library
|
|
for saving and loading.}
|
|
unit ImagingComponents;
|
|
|
|
{$I ImagingOptions.inc}
|
|
|
|
interface
|
|
|
|
{$IFDEF LCL}
|
|
{$DEFINE COMPONENT_SET_LCL}
|
|
{$UNDEF COMPONENT_SET_VCL}
|
|
{$ENDIF}
|
|
|
|
{$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
|
|
// If no component sets should be used just include empty unit.
|
|
//DOC-IGNORE-BEGIN
|
|
implementation
|
|
//DOC-IGNORE-END
|
|
{$ELSE}
|
|
|
|
uses
|
|
SysUtils, Types, Classes,
|
|
{$IFDEF MSWINDOWS}
|
|
Windows,
|
|
{$ENDIF}
|
|
{$IFDEF COMPONENT_SET_VCL}
|
|
Graphics,
|
|
{$ENDIF}
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
InterfaceBase,
|
|
GraphType,
|
|
Graphics,
|
|
LCLType,
|
|
LCLIntf,
|
|
{$ENDIF}
|
|
ImagingTypes, Imaging, ImagingClasses;
|
|
|
|
type
|
|
{ Graphic class which uses Imaging to load images.
|
|
It has standard TBitmap class as ancestor and it can
|
|
Assign also to/from TImageData structres and TBaseImage
|
|
classes. For saving is uses inherited TBitmap methods.
|
|
This class is automatically registered to TPicture for all
|
|
file extensions supported by Imaging (useful only for loading).
|
|
If you just want to load images in various formats you can use this
|
|
class or simply use TPicture.LoadFromXXX which will create this class
|
|
automatically. For TGraphic class that saves with Imaging look
|
|
at TImagingGraphicForSave class.}
|
|
TImagingGraphic = class(TBitmap)
|
|
protected
|
|
procedure ReadDataFromStream(Stream: TStream); virtual;
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
public
|
|
constructor Create; override;
|
|
|
|
{ Loads new image from the stream. It can load all image
|
|
file formats supported by Imaging (and enabled of course)
|
|
even though it is called by descendant class capable of
|
|
saving only one file format.}
|
|
procedure LoadFromStream(Stream: TStream); override;
|
|
{ Copies the image contained in Source to this graphic object.
|
|
Supports also TBaseImage descendants from ImagingClasses unit. }
|
|
procedure Assign(Source: TPersistent); override;
|
|
{ Copies the image contained in TBaseImage to this graphic object.}
|
|
procedure AssignFromImage(Image: TBaseImage);
|
|
{ Copies the current image to TBaseImage object.}
|
|
procedure AssignToImage(Image: TBaseImage);
|
|
{ Copies the image contained in TImageData structure to this graphic object.}
|
|
procedure AssignFromImageData(const ImageData: TImageData);
|
|
{ Copies the current image to TImageData structure.}
|
|
procedure AssignToImageData(var ImageData: TImageData);
|
|
|
|
{$IFDEF FPC}
|
|
class function IsStreamFormatSupported(Stream: TStream): boolean; override;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
TImagingGraphicClass = class of TImagingGraphic;
|
|
|
|
{ Base class for file format specific TGraphic classes that use
|
|
Imaging for saving. Each descendant class can load all file formats
|
|
supported by Imaging but save only one format (TImagingBitmap
|
|
for *.bmp, TImagingJpeg for *.jpg). Format specific classes also
|
|
allow easy access to Imaging options that affect saving of files
|
|
(they are properties here).}
|
|
TImagingGraphicForSave = class(TImagingGraphic)
|
|
protected
|
|
FDefaultFileExt: string;
|
|
FSavingFormat: TImageFormat;
|
|
procedure WriteDataToStream(Stream: TStream); virtual;
|
|
public
|
|
constructor Create; override;
|
|
{ Saves the current image to the stream. It is saved in the
|
|
file format according to the DefaultFileExt property.
|
|
So each descendant class can save some other file format.}
|
|
procedure SaveToStream(Stream: TStream); override;
|
|
{ Returns TImageFileFormat descendant for this graphic class.}
|
|
class function GetFileFormat: TImageFileFormat; virtual; abstract;
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
{ Returns file extensions of this graphic class.}
|
|
class function GetFileExtensions: string; override;
|
|
{ Returns default MIME type of this graphic class.}
|
|
function GetMimeType: string; override;
|
|
{$ENDIF}
|
|
{ Default (the most common) file extension of this graphic class.}
|
|
property DefaultFileExt: string read FDefaultFileExt;
|
|
end;
|
|
|
|
TImagingGraphicForSaveClass = class of TImagingGraphicForSave;
|
|
|
|
{$IFNDEF DONT_LINK_BITMAP}
|
|
{ TImagingGraphic descendant for loading/saving Windows bitmaps.
|
|
VCL/CLX/LCL all have native support for bitmaps so you might
|
|
want to disable this class (although you can save bitmaps with
|
|
RLE compression with this class).}
|
|
TImagingBitmap = class(TImagingGraphicForSave)
|
|
protected
|
|
FUseRLE: Boolean;
|
|
public
|
|
constructor Create; override;
|
|
procedure SaveToStream(Stream: TStream); override;
|
|
class function GetFileFormat: TImageFileFormat; override;
|
|
{ See ImagingBitmapRLE option for details.}
|
|
property UseRLE: Boolean read FUseRLE write FUseRLE;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_JPEG}
|
|
{ TImagingGraphic descendant for loading/saving JPEG images.}
|
|
TImagingJpeg = class(TImagingGraphicForSave)
|
|
protected
|
|
FQuality: LongInt;
|
|
FProgressive: Boolean;
|
|
public
|
|
constructor Create; override;
|
|
procedure SaveToStream(Stream: TStream); override;
|
|
class function GetFileFormat: TImageFileFormat; override;
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
function GetMimeType: string; override;
|
|
{$ENDIF}
|
|
{ See ImagingJpegQuality option for details.}
|
|
property Quality: LongInt read FQuality write FQuality;
|
|
{ See ImagingJpegProgressive option for details.}
|
|
property Progressive: Boolean read FProgressive write FProgressive;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_PNG}
|
|
{ TImagingGraphic descendant for loading/saving PNG images.}
|
|
TImagingPNG = class(TImagingGraphicForSave)
|
|
protected
|
|
FPreFilter: LongInt;
|
|
FCompressLevel: LongInt;
|
|
public
|
|
constructor Create; override;
|
|
procedure SaveToStream(Stream: TStream); override;
|
|
class function GetFileFormat: TImageFileFormat; override;
|
|
{ See ImagingPNGPreFilter option for details.}
|
|
property PreFilter: LongInt read FPreFilter write FPreFilter;
|
|
{ See ImagingPNGCompressLevel option for details.}
|
|
property CompressLevel: LongInt read FCompressLevel write FCompressLevel;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_GIF}
|
|
{ TImagingGraphic descendant for loading/saving GIF images.}
|
|
TImagingGIF = class(TImagingGraphicForSave)
|
|
public
|
|
class function GetFileFormat: TImageFileFormat; override;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_TARGA}
|
|
{ TImagingGraphic descendant for loading/saving Targa images.}
|
|
TImagingTarga = class(TImagingGraphicForSave)
|
|
protected
|
|
FUseRLE: Boolean;
|
|
public
|
|
constructor Create; override;
|
|
procedure SaveToStream(Stream: TStream); override;
|
|
class function GetFileFormat: TImageFileFormat; override;
|
|
{ See ImagingTargaRLE option for details.}
|
|
property UseRLE: Boolean read FUseRLE write FUseRLE;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_DDS}
|
|
{ Compresssion type used when saving DDS files by TImagingDds.}
|
|
TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5);
|
|
|
|
{ TImagingGraphic descendant for loading/saving DDS images.}
|
|
TImagingDDS = class(TImagingGraphicForSave)
|
|
protected
|
|
FCompression: TDDSCompresion;
|
|
public
|
|
constructor Create; override;
|
|
procedure SaveToStream(Stream: TStream); override;
|
|
class function GetFileFormat: TImageFileFormat; override;
|
|
{ You can choose compression type used when saving DDS file.
|
|
dcNone means that file will be saved in the current bitmaps pixel format.}
|
|
property Compression: TDDSCompresion read FCompression write FCompression;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_MNG}
|
|
{ TImagingGraphic descendant for loading/saving MNG images.}
|
|
TImagingMNG = class(TImagingGraphicForSave)
|
|
protected
|
|
FLossyCompression: Boolean;
|
|
FLossyAlpha: Boolean;
|
|
FPreFilter: LongInt;
|
|
FCompressLevel: LongInt;
|
|
FQuality: LongInt;
|
|
FProgressive: Boolean;
|
|
public
|
|
constructor Create; override;
|
|
procedure SaveToStream(Stream: TStream); override;
|
|
class function GetFileFormat: TImageFileFormat; override;
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
function GetMimeType: string; override;
|
|
{$ENDIF}
|
|
{ See ImagingMNGLossyCompression option for details.}
|
|
property LossyCompression: Boolean read FLossyCompression write FLossyCompression;
|
|
{ See ImagingMNGLossyAlpha option for details.}
|
|
property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha;
|
|
{ See ImagingMNGPreFilter option for details.}
|
|
property PreFilter: LongInt read FPreFilter write FPreFilter;
|
|
{ See ImagingMNGCompressLevel option for details.}
|
|
property CompressLevel: LongInt read FCompressLevel write FCompressLevel;
|
|
{ See ImagingMNGQuality option for details.}
|
|
property Quality: LongInt read FQuality write FQuality;
|
|
{ See ImagingMNGProgressive option for details.}
|
|
property Progressive: Boolean read FProgressive write FProgressive;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_JNG}
|
|
{ TImagingGraphic descendant for loading/saving JNG images.}
|
|
TImagingJNG = class(TImagingGraphicForSave)
|
|
protected
|
|
FLossyAlpha: Boolean;
|
|
FAlphaPreFilter: LongInt;
|
|
FAlphaCompressLevel: LongInt;
|
|
FQuality: LongInt;
|
|
FProgressive: Boolean;
|
|
public
|
|
constructor Create; override;
|
|
procedure SaveToStream(Stream: TStream); override;
|
|
class function GetFileFormat: TImageFileFormat; override;
|
|
{ See ImagingJNGLossyAlpha option for details.}
|
|
property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha;
|
|
{ See ImagingJNGPreFilter option for details.}
|
|
property AlphaPreFilter: LongInt read FAlphaPreFilter write FAlphaPreFilter;
|
|
{ See ImagingJNGCompressLevel option for details.}
|
|
property AlphaCompressLevel: LongInt read FAlphaCompressLevel write FAlphaCompressLevel;
|
|
{ See ImagingJNGQuality option for details.}
|
|
property Quality: LongInt read FQuality write FQuality;
|
|
{ See ImagingJNGProgressive option for details.}
|
|
property Progressive: Boolean read FProgressive write FProgressive;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{ Returns bitmap pixel format with the closest match with given data format.}
|
|
function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat;
|
|
{ Returns data format with closest match with given bitmap pixel format.}
|
|
function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat;
|
|
|
|
{ Converts TImageData structure to VCL/CLX/LCL bitmap.}
|
|
procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap);
|
|
{ Converts VCL/CLX/LCL bitmap to TImageData structure.}
|
|
procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData);
|
|
{ Converts TBaseImage instance to VCL/CLX/LCL bitmap.}
|
|
procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap);
|
|
{ Converts VCL/CLX/LCL bitmap to TBaseImage. Image must exist before
|
|
procedure is called. It overwrites its current image data.
|
|
When Image is TMultiImage only the current image level is overwritten.}
|
|
procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage);
|
|
|
|
{ Displays image stored in TImageData structure onto TCanvas. This procedure
|
|
draws image without converting from Imaging format to TBitmap.
|
|
Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
|
|
when you want displaying images that change frequently (because converting to
|
|
TBitmap by ConvertImageDataToBitmap is generally slow). Dest and Src
|
|
rectangles represent coordinates in the form (X1, Y1, X2, Y2).}
|
|
procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
|
|
{ Displays image onto TCanvas at position [DstX, DstY]. This procedure
|
|
draws image without converting from Imaging format to TBitmap.
|
|
Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
|
|
when you want displaying images that change frequently (because converting to
|
|
TBitmap by ConvertImageDataToBitmap is generally slow).}
|
|
procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage); overload;
|
|
{ Displays image onto TCanvas to rectangle DstRect. This procedure
|
|
draws image without converting from Imaging format to TBitmap.
|
|
Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
|
|
when you want displaying images that change frequently (because converting to
|
|
TBitmap by ConvertImageDataToBitmap is generally slow).}
|
|
procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage); overload;
|
|
{ Displays part of the image specified by SrcRect onto TCanvas to rectangle DstRect.
|
|
This procedure draws image without converting from Imaging format to TBitmap.
|
|
Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
|
|
when you want displaying images that change frequently (because converting to
|
|
TBitmap by ConvertImageDataToBitmap is generally slow).}
|
|
procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect); overload;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
{ Displays image stored in TImageData structure onto Windows device context.
|
|
Behaviour is the same as of DisplayImageData.}
|
|
procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
|
|
{$ENDIF}
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$IF Defined(LCL)}
|
|
{$IF Defined(LCLGTK2)}
|
|
GLib2, GDK2, GTK2, GTK2Def, GTK2Proc,
|
|
{$IFEND}
|
|
{$IFEND}
|
|
{$IFNDEF DONT_LINK_BITMAP}
|
|
ImagingBitmap,
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_JPEG}
|
|
ImagingJpeg,
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_GIF}
|
|
ImagingGif,
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_TARGA}
|
|
ImagingTarga,
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_DDS}
|
|
ImagingDds,
|
|
{$ENDIF}
|
|
{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
|
|
ImagingNetworkGraphics,
|
|
{$IFEND}
|
|
ImagingFormats, ImagingUtility;
|
|
|
|
resourcestring
|
|
SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s';
|
|
SBadFormatBitmapToData = 'Cannot find compatible data format for bitmap %p';
|
|
SBadFormatDisplay = 'Unsupported image format passed';
|
|
SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set';
|
|
SImagingGraphicName = 'Imaging Graphic AllInOne';
|
|
|
|
{ Registers types to VCL/LCL.}
|
|
procedure RegisterTypes;
|
|
var
|
|
I: LongInt;
|
|
|
|
procedure RegisterFileFormatAllInOne(Format: TImageFileFormat);
|
|
var
|
|
I: LongInt;
|
|
begin
|
|
for I := 0 to Format.Extensions.Count - 1 do
|
|
TPicture.RegisterFileFormat(Format.Extensions[I], SImagingGraphicName,
|
|
TImagingGraphic);
|
|
end;
|
|
|
|
procedure RegisterFileFormat(AClass: TImagingGraphicForSaveClass);
|
|
var
|
|
I: LongInt;
|
|
begin
|
|
for I := 0 to AClass.GetFileFormat.Extensions.Count - 1 do
|
|
TPicture.RegisterFileFormat(AClass.GetFileFormat.Extensions[I],
|
|
AClass.GetFileFormat.Name, AClass);
|
|
end;
|
|
|
|
begin
|
|
for I := Imaging.GetFileFormatCount - 1 downto 0 do
|
|
RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I));
|
|
Classes.RegisterClass(TImagingGraphic);
|
|
|
|
{$IFNDEF DONT_LINK_TARGA}
|
|
RegisterFileFormat(TImagingTarga);
|
|
Classes.RegisterClass(TImagingTarga);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_DDS}
|
|
RegisterFileFormat(TImagingDDS);
|
|
Classes.RegisterClass(TImagingDDS);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_JNG}
|
|
RegisterFileFormat(TImagingJNG);
|
|
Classes.RegisterClass(TImagingJNG);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_MNG}
|
|
RegisterFileFormat(TImagingMNG);
|
|
Classes.RegisterClass(TImagingMNG);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_GIF}
|
|
RegisterFileFormat(TImagingGIF);
|
|
Classes.RegisterClass(TImagingGIF);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_PNG}
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
// Unregister Lazarus´ default PNG loader which crashes on some PNG files
|
|
TPicture.UnregisterGraphicClass(TPortableNetworkGraphic);
|
|
{$ENDIF}
|
|
RegisterFileFormat(TImagingPNG);
|
|
Classes.RegisterClass(TImagingPNG);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_JPEG}
|
|
RegisterFileFormat(TImagingJpeg);
|
|
Classes.RegisterClass(TImagingJpeg);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_BITMAP}
|
|
RegisterFileFormat(TImagingBitmap);
|
|
Classes.RegisterClass(TImagingBitmap);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{ Unregisters types from VCL/LCL.}
|
|
procedure UnRegisterTypes;
|
|
begin
|
|
{$IFNDEF DONT_LINK_BITMAP}
|
|
TPicture.UnregisterGraphicClass(TImagingBitmap);
|
|
Classes.UnRegisterClass(TImagingBitmap);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_JPEG}
|
|
TPicture.UnregisterGraphicClass(TImagingJpeg);
|
|
Classes.UnRegisterClass(TImagingJpeg);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_PNG}
|
|
TPicture.UnregisterGraphicClass(TImagingPNG);
|
|
Classes.UnRegisterClass(TImagingPNG);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_GIF}
|
|
TPicture.UnregisterGraphicClass(TImagingGIF);
|
|
Classes.UnRegisterClass(TImagingGIF);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_TARGA}
|
|
TPicture.UnregisterGraphicClass(TImagingTarga);
|
|
Classes.UnRegisterClass(TImagingTarga);
|
|
{$ENDIF}
|
|
{$IFNDEF DONT_LINK_DDS}
|
|
TPicture.UnregisterGraphicClass(TImagingDDS);
|
|
Classes.UnRegisterClass(TImagingDDS);
|
|
{$ENDIF}
|
|
TPicture.UnregisterGraphicClass(TImagingGraphic);
|
|
Classes.UnRegisterClass(TImagingGraphic);
|
|
end;
|
|
|
|
function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat;
|
|
begin
|
|
case Format of
|
|
{$IFDEF COMPONENT_SET_VCL}
|
|
ifIndex8: Result := pf8bit;
|
|
ifR5G6B5: Result := pf16bit;
|
|
ifR8G8B8: Result := pf24bit;
|
|
{$ENDIF}
|
|
ifA8R8G8B8,
|
|
ifX8R8G8B8: Result := pf32bit;
|
|
else
|
|
Result := pfCustom;
|
|
end;
|
|
end;
|
|
|
|
function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat;
|
|
begin
|
|
case Format of
|
|
pf8bit: Result := ifIndex8;
|
|
pf15bit: Result := ifA1R5G5B5;
|
|
pf16bit: Result := ifR5G6B5;
|
|
pf24bit: Result := ifR8G8B8;
|
|
pf32bit: Result := ifA8R8G8B8;
|
|
else
|
|
Result := ifUnknown;
|
|
end;
|
|
end;
|
|
|
|
procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap);
|
|
var
|
|
I, LineBytes: LongInt;
|
|
PF: TPixelFormat;
|
|
Info: TImageFormatInfo;
|
|
WorkData: TImageData;
|
|
{$IFDEF COMPONENT_SET_VCL}
|
|
LogPalette: TMaxLogPalette;
|
|
{$ENDIF}
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
RawImage: TRawImage;
|
|
ImgHandle, ImgMaskHandle: HBitmap;
|
|
{$ENDIF}
|
|
begin
|
|
PF := DataFormatToPixelFormat(Data.Format);
|
|
GetImageFormatInfo(Data.Format, Info);
|
|
|
|
if (PF = pf8bit) and PaletteHasAlpha(Data.Palette, Info.PaletteEntries) then
|
|
begin
|
|
// Some indexed images may have valid alpha data, dont lose it!
|
|
// (e.g. transparent 8bit PNG or GIF images)
|
|
PF := pfCustom;
|
|
end;
|
|
|
|
if PF = pfCustom then
|
|
begin
|
|
// Convert from formats not supported by Graphics unit
|
|
Imaging.InitImage(WorkData);
|
|
Imaging.CloneImage(Data, WorkData);
|
|
if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then
|
|
Imaging.ConvertImage(WorkData, ifA8R8G8B8)
|
|
else
|
|
begin
|
|
{$IFDEF COMPONENT_SET_VCL}
|
|
if Info.IsIndexed or Info.HasGrayChannel then
|
|
Imaging.ConvertImage(WorkData, ifIndex8)
|
|
else if Info.UsePixelFormat then
|
|
Imaging.ConvertImage(WorkData, ifR5G6B5)
|
|
else
|
|
Imaging.ConvertImage(WorkData, ifR8G8B8);
|
|
{$ELSE}
|
|
Imaging.ConvertImage(WorkData, ifA8R8G8B8);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
PF := DataFormatToPixelFormat(WorkData.Format);
|
|
GetImageFormatInfo(WorkData.Format, Info);
|
|
end
|
|
else
|
|
WorkData := Data;
|
|
|
|
if PF = pfCustom then
|
|
RaiseImaging(SBadFormatDataToBitmap, [ImageToStr(WorkData)]);
|
|
|
|
LineBytes := WorkData.Width * Info.BytesPerPixel;
|
|
|
|
{$IFDEF COMPONENT_SET_VCL}
|
|
Bitmap.Width := WorkData.Width;
|
|
Bitmap.Height := WorkData.Height;
|
|
Bitmap.PixelFormat := PF;
|
|
|
|
if (PF = pf8bit) and (WorkData.Palette <> nil) then
|
|
begin
|
|
// Copy palette, this must be done before copying bits
|
|
FillChar(LogPalette, SizeOf(LogPalette), 0);
|
|
LogPalette.palVersion := $300;
|
|
LogPalette.palNumEntries := Info.PaletteEntries;
|
|
for I := 0 to Info.PaletteEntries - 1 do
|
|
with LogPalette do
|
|
begin
|
|
palPalEntry[I].peRed := WorkData.Palette[I].R;
|
|
palPalEntry[I].peGreen := WorkData.Palette[I].G;
|
|
palPalEntry[I].peBlue := WorkData.Palette[I].B;
|
|
end;
|
|
Bitmap.Palette := CreatePalette(PLogPalette(@LogPalette)^);
|
|
end;
|
|
// Copy scanlines
|
|
for I := 0 to WorkData.Height - 1 do
|
|
Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes);
|
|
|
|
// Delphi 2009 and newer support alpha transparency fro TBitmap
|
|
{$IF Defined(DELPHI) and (CompilerVersion >= 20.0)}
|
|
if Bitmap.PixelFormat = pf32bit then
|
|
Bitmap.AlphaFormat := afDefined;
|
|
{$IFEND}
|
|
|
|
{$ENDIF}
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
// Create 32bit raw image from image data
|
|
FillChar(RawImage, SizeOf(RawImage), 0);
|
|
with RawImage.Description do
|
|
begin
|
|
Width := WorkData.Width;
|
|
Height := WorkData.Height;
|
|
BitsPerPixel := 32;
|
|
Format := ricfRGBA;
|
|
LineEnd := rileDWordBoundary;
|
|
BitOrder := riboBitsInOrder;
|
|
ByteOrder := riboLSBFirst;
|
|
LineOrder := riloTopToBottom;
|
|
AlphaPrec := 8;
|
|
RedPrec := 8;
|
|
GreenPrec := 8;
|
|
BluePrec := 8;
|
|
AlphaShift := 24;
|
|
RedShift := 16;
|
|
GreenShift := 8;
|
|
BlueShift := 0;
|
|
Depth := 32; // Must be 32 for alpha blending (and for working in MacOSX Carbon)
|
|
end;
|
|
RawImage.Data := WorkData.Bits;
|
|
RawImage.DataSize := WorkData.Size;
|
|
|
|
// Create bitmap from raw image
|
|
if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle) then
|
|
begin
|
|
Bitmap.Handle := ImgHandle;
|
|
Bitmap.MaskHandle := ImgMaskHandle;
|
|
end;
|
|
{$ENDIF}
|
|
if WorkData.Bits <> Data.Bits then
|
|
Imaging.FreeImage(WorkData);
|
|
end;
|
|
|
|
procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData);
|
|
var
|
|
I, LineBytes: LongInt;
|
|
Format: TImageFormat;
|
|
Info: TImageFormatInfo;
|
|
{$IFDEF COMPONENT_SET_VCL}
|
|
Colors: Word;
|
|
LogPalette: TMaxLogPalette;
|
|
{$ENDIF}
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
RawImage: TRawImage;
|
|
LineLazBytes: LongInt;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
// In the current Lazarus 0.9.10 Bitmap.PixelFormat property is useless.
|
|
// We cannot change bitmap's format by changing it (it will just release
|
|
// old image but not convert it to new format) nor we can determine bitmaps's
|
|
// current format (it is usually set to pfDevice). So bitmap's format is obtained
|
|
// trough RawImage api and cannot be changed to mirror some Imaging format
|
|
// (so formats with no coresponding Imaging format cannot be saved now).
|
|
|
|
if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then
|
|
case RawImage.Description.BitsPerPixel of
|
|
8: Format := ifIndex8;
|
|
16:
|
|
if RawImage.Description.Depth = 15 then
|
|
Format := ifA1R5G5B5
|
|
else
|
|
Format := ifR5G6B5;
|
|
24: Format := ifR8G8B8;
|
|
32: Format := ifA8R8G8B8;
|
|
48: Format := ifR16G16B16;
|
|
64: Format := ifA16R16G16B16;
|
|
else
|
|
Format := ifUnknown;
|
|
end;
|
|
{$ELSE}
|
|
Format := PixelFormatToDataFormat(Bitmap.PixelFormat);
|
|
if Format = ifUnknown then
|
|
begin
|
|
// Convert from formats not supported by Imaging (1/4 bit)
|
|
if Bitmap.PixelFormat < pf8bit then
|
|
Bitmap.PixelFormat := pf8bit
|
|
else
|
|
Bitmap.PixelFormat := pf32bit;
|
|
Format := PixelFormatToDataFormat(Bitmap.PixelFormat);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
if Format = ifUnknown then
|
|
RaiseImaging(SBadFormatBitmapToData, []);
|
|
|
|
Imaging.NewImage(Bitmap.Width, Bitmap.Height, Format, Data);
|
|
GetImageFormatInfo(Data.Format, Info);
|
|
LineBytes := Data.Width * Info.BytesPerPixel;
|
|
|
|
{$IFDEF COMPONENT_SET_VCL}
|
|
if (Format = ifIndex8) and (GetObject(Bitmap.Palette, SizeOf(Colors),
|
|
@Colors) <> 0) then
|
|
begin
|
|
// Copy palette
|
|
GetPaletteEntries(Bitmap.Palette, 0, Colors, LogPalette.palPalEntry);
|
|
if Colors > Info.PaletteEntries then
|
|
Colors := Info.PaletteEntries;
|
|
for I := 0 to Colors - 1 do
|
|
with LogPalette do
|
|
begin
|
|
Data.Palette[I].A := $FF;
|
|
Data.Palette[I].R := palPalEntry[I].peRed;
|
|
Data.Palette[I].G := palPalEntry[I].peGreen;
|
|
Data.Palette[I].B := palPalEntry[I].peBlue;
|
|
end;
|
|
end;
|
|
// Copy scanlines
|
|
for I := 0 to Data.Height - 1 do
|
|
Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes);
|
|
{$ENDIF}
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
// Get raw image from bitmap (mask handle must be 0 or expect violations)
|
|
if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then
|
|
begin
|
|
LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel,
|
|
RawImage.Description.LineEnd);
|
|
// Copy scanlines
|
|
for I := 0 to Data.Height - 1 do
|
|
begin
|
|
Move(PByteArray(RawImage.Data)[I * LineLazBytes],
|
|
PByteArray(Data.Bits)[I * LineBytes], LineBytes);
|
|
end;
|
|
// May need to swap RB order, depends on wifget set
|
|
if RawImage.Description.BlueShift > RawImage.Description.RedShift then
|
|
SwapChannels(Data, ChannelRed, ChannelBlue);
|
|
|
|
RawImage.FreeData;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap);
|
|
begin
|
|
ConvertDataToBitmap(Image.ImageDataPointer^, Bitmap);
|
|
end;
|
|
|
|
procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage);
|
|
begin
|
|
ConvertBitmapToData(Bitmap, Image.ImageDataPointer^);
|
|
end;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
|
|
var
|
|
OldMode: Integer;
|
|
BitmapInfo: Windows.TBitmapInfo;
|
|
Bmp: TBitmap;
|
|
begin
|
|
if TestImage(ImageData) then
|
|
begin
|
|
Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay);
|
|
OldMode := Windows.SetStretchBltMode(DC, COLORONCOLOR);
|
|
|
|
FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
|
|
with BitmapInfo.bmiHeader do
|
|
begin
|
|
biSize := SizeOf(TBitmapInfoHeader);
|
|
biPlanes := 1;
|
|
biBitCount := 32;
|
|
biCompression := BI_RGB;
|
|
biWidth := ImageData.Width;
|
|
biHeight := -ImageData.Height;
|
|
biSizeImage := ImageData.Size;
|
|
biXPelsPerMeter := 0;
|
|
biYPelsPerMeter := 0;
|
|
biClrUsed := 0;
|
|
biClrImportant := 0;
|
|
end;
|
|
|
|
try
|
|
with SrcRect, ImageData do
|
|
if Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top,
|
|
DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left,
|
|
Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then
|
|
begin
|
|
// StretchDIBits may fail on some ocassions (error 487, http://support.microsoft.com/kb/269585).
|
|
// This fallback is slow but works every time. Thanks to Sergey Galezdinov for the fix.
|
|
Bmp := TBitmap.Create;
|
|
try
|
|
ConvertDataToBitmap(ImageData, Bmp);
|
|
StretchBlt(DC, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top,
|
|
Bmp.Canvas.Handle, 0, 0, Width, Height, SRCCOPY);
|
|
finally
|
|
Bmp.Free;
|
|
end;
|
|
end;
|
|
finally
|
|
Windows.SetStretchBltMode(DC, OldMode);
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
|
|
{$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32
|
|
begin
|
|
DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect);
|
|
end;
|
|
{$ELSEIF Defined(LCLGTK2)}
|
|
type
|
|
TDeviceContext = TGtk2DeviceContext;
|
|
|
|
procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
|
|
SrcWidth, SrcHeight: Integer; ImageData: TImageData);
|
|
var
|
|
P: TPoint;
|
|
begin
|
|
P := TDeviceContext(Dest).Offset;
|
|
Inc(DstX, P.X);
|
|
Inc(DstY, P.Y);
|
|
gdk_draw_rgb_32_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC,
|
|
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
|
|
@PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
|
|
end;
|
|
|
|
var
|
|
DisplayImage: TImageData;
|
|
NewWidth, NewHeight: Integer;
|
|
SrcBounds, DstBounds, DstClip: TRect;
|
|
begin
|
|
if TestImage(ImageData) then
|
|
begin
|
|
Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay);
|
|
InitImage(DisplayImage);
|
|
|
|
SrcBounds := RectToBounds(SrcRect);
|
|
DstBounds := RectToBounds(DstRect);
|
|
WidgetSet.GetClipBox(DstCanvas.Handle, @DstClip);
|
|
|
|
ClipStretchBounds(SrcBounds.Left, SrcBounds.Top, SrcBounds.Right, SrcBounds.Bottom,
|
|
DstBounds.Left, DstBounds.Top, DstBounds.Right, DstBounds.Bottom, ImageData.Width,
|
|
ImageData.Height, DstClip);
|
|
|
|
NewWidth := DstBounds.Right;
|
|
NewHeight := DstBounds.Bottom;
|
|
|
|
if (NewWidth > 0) and (NewHeight > 0) then
|
|
begin
|
|
if (SrcBounds.Right = NewWidth) and (SrcBounds.Bottom = NewHeight) then
|
|
try
|
|
CloneImage(ImageData, DisplayImage);
|
|
// Swap R-B channels for GTK display compatability!
|
|
SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
|
|
GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top,
|
|
SrcBounds.Left, SrcBounds.Top, NewWidth, NewHeight, DisplayImage);
|
|
finally
|
|
FreeImage(DisplayImage);
|
|
end
|
|
else
|
|
try
|
|
// Create new image with desired dimensions
|
|
NewImage(NewWidth, NewHeight, ImageData.Format, DisplayImage);
|
|
// Stretch pixels from old image to new one TResizeFilter = (rfNearest, rfBilinear, rfBicubic);
|
|
StretchRect(ImageData, SrcBounds.Left, SrcBounds.Top, SrcBounds.Right,
|
|
SrcBounds.Bottom, DisplayImage, 0, 0, NewWidth, NewHeight, rfNearest);
|
|
// Swap R-B channels for GTK display compatability!
|
|
SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
|
|
GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, 0, 0,
|
|
NewWidth, NewHeight, DisplayImage);
|
|
finally
|
|
FreeImage(DisplayImage);
|
|
end
|
|
end;
|
|
end;
|
|
end;
|
|
{$ELSE}
|
|
begin
|
|
raise Exception.Create(SUnsupportedLCLWidgetSet);
|
|
end;
|
|
{$IFEND}
|
|
|
|
procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage);
|
|
begin
|
|
DisplayImageData(DstCanvas, BoundsToRect(DstX, DstY, Image.Width, Image.Height),
|
|
Image.ImageDataPointer^, Image.BoundsRect);
|
|
end;
|
|
|
|
procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage);
|
|
begin
|
|
DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, Image.BoundsRect);
|
|
end;
|
|
|
|
procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect);
|
|
begin
|
|
DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, SrcRect);
|
|
end;
|
|
|
|
|
|
{ TImagingGraphic class implementation }
|
|
|
|
constructor TImagingGraphic.Create;
|
|
begin
|
|
inherited Create;
|
|
PixelFormat := pf24Bit;
|
|
end;
|
|
|
|
procedure TImagingGraphic.LoadFromStream(Stream: TStream);
|
|
begin
|
|
ReadDataFromStream(Stream);
|
|
end;
|
|
|
|
procedure TImagingGraphic.ReadDataFromStream(Stream: TStream);
|
|
var
|
|
Image: TSingleImage;
|
|
begin
|
|
Image := TSingleImage.Create;
|
|
try
|
|
Image.LoadFromStream(Stream);
|
|
Assign(Image);
|
|
finally
|
|
Image.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TImagingGraphic.AssignTo(Dest: TPersistent);
|
|
var
|
|
Arr: TDynImageDataArray;
|
|
begin
|
|
if Dest is TSingleImage then
|
|
begin
|
|
AssignToImage(TSingleImage(Dest))
|
|
end
|
|
else if Dest is TMultiImage then
|
|
begin
|
|
SetLength(Arr, 1);
|
|
AssignToImageData(Arr[0]);
|
|
TMultiImage(Dest).CreateFromArray(Arr);
|
|
Imaging.FreeImagesInArray(Arr);
|
|
end
|
|
else
|
|
inherited AssignTo(Dest);
|
|
end;
|
|
|
|
{$IFDEF FPC}
|
|
class function TImagingGraphic.IsStreamFormatSupported(Stream: TStream): Boolean;
|
|
begin
|
|
Result := DetermineStreamFormat(Stream) <> '';
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TImagingGraphic.Assign(Source: TPersistent);
|
|
begin
|
|
if Source is TBaseImage then
|
|
AssignFromImage(TBaseImage(Source))
|
|
else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
procedure TImagingGraphic.AssignFromImage(Image: TBaseImage);
|
|
begin
|
|
if (Image <> nil) and Image.Valid then
|
|
AssignFromImageData(Image.ImageDataPointer^);
|
|
end;
|
|
|
|
procedure TImagingGraphic.AssignToImage(Image: TBaseImage);
|
|
begin
|
|
if (Image <> nil) and (Image.ImageDataPointer <> nil) then
|
|
AssignToImageData(Image.ImageDataPointer^);
|
|
end;
|
|
|
|
procedure TImagingGraphic.AssignFromImageData(const ImageData: TImageData);
|
|
begin
|
|
if Imaging.TestImage(ImageData) then
|
|
ConvertDataToBitmap(ImageData, Self);
|
|
end;
|
|
|
|
procedure TImagingGraphic.AssignToImageData(var ImageData: TImageData);
|
|
begin
|
|
Imaging.FreeImage(ImageData);
|
|
ConvertBitmapToData(Self, ImageData);
|
|
end;
|
|
|
|
|
|
{ TImagingGraphicForSave class implementation }
|
|
|
|
constructor TImagingGraphicForSave.Create;
|
|
begin
|
|
inherited Create;
|
|
FDefaultFileExt := GetFileFormat.Extensions[0];
|
|
FSavingFormat := ifUnknown;
|
|
GetFileFormat.CheckOptionsValidity;
|
|
end;
|
|
|
|
procedure TImagingGraphicForSave.WriteDataToStream(Stream: TStream);
|
|
var
|
|
Image: TSingleImage;
|
|
begin
|
|
if FDefaultFileExt <> '' then
|
|
begin
|
|
Image := TSingleImage.Create;
|
|
try
|
|
Image.Assign(Self);
|
|
if FSavingFormat <> ifUnknown then
|
|
Image.Format := FSavingFormat;
|
|
Image.SaveToStream(FDefaultFileExt, Stream);
|
|
finally
|
|
Image.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TImagingGraphicForSave.SaveToStream(Stream: TStream);
|
|
begin
|
|
WriteDataToStream(Stream);
|
|
end;
|
|
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
class function TImagingGraphicForSave.GetFileExtensions: string;
|
|
begin
|
|
Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]);
|
|
end;
|
|
|
|
function TImagingGraphicForSave.GetMimeType: string;
|
|
begin
|
|
Result := 'image/' + FDefaultFileExt;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_BITMAP}
|
|
|
|
{ TImagingBitmap class implementation }
|
|
|
|
constructor TImagingBitmap.Create;
|
|
begin
|
|
inherited Create;
|
|
FUseRLE := (GetFileFormat as TBitmapFileFormat).UseRLE;
|
|
end;
|
|
|
|
class function TImagingBitmap.GetFileFormat: TImageFileFormat;
|
|
begin
|
|
Result := FindImageFileFormatByClass(TBitmapFileFormat);
|
|
end;
|
|
|
|
procedure TImagingBitmap.SaveToStream(Stream: TStream);
|
|
begin
|
|
Imaging.PushOptions;
|
|
Imaging.SetOption(ImagingBitmapRLE, Ord(FUseRLE));
|
|
inherited SaveToStream(Stream);
|
|
Imaging.PopOptions;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_JPEG}
|
|
|
|
{ TImagingJpeg class implementation }
|
|
|
|
constructor TImagingJpeg.Create;
|
|
begin
|
|
inherited Create;
|
|
FQuality := (GetFileFormat as TJpegFileFormat).Quality;
|
|
FProgressive := (GetFileFormat as TJpegFileFormat).Progressive;
|
|
end;
|
|
|
|
class function TImagingJpeg.GetFileFormat: TImageFileFormat;
|
|
begin
|
|
Result := FindImageFileFormatByClass(TJpegFileFormat);
|
|
end;
|
|
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
function TImagingJpeg.GetMimeType: string;
|
|
begin
|
|
Result := 'image/jpeg';
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TImagingJpeg.SaveToStream(Stream: TStream);
|
|
begin
|
|
Imaging.PushOptions;
|
|
Imaging.SetOption(ImagingJpegQuality, FQuality);
|
|
Imaging.SetOption(ImagingJpegProgressive, Ord(FProgressive));
|
|
inherited SaveToStream(Stream);
|
|
Imaging.PopOptions;
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_PNG}
|
|
|
|
{ TImagingPNG class implementation }
|
|
|
|
constructor TImagingPNG.Create;
|
|
begin
|
|
inherited Create;
|
|
FPreFilter := (GetFileFormat as TPNGFileFormat).PreFilter;
|
|
FCompressLevel := (GetFileFormat as TPNGFileFormat).CompressLevel;
|
|
end;
|
|
|
|
class function TImagingPNG.GetFileFormat: TImageFileFormat;
|
|
begin
|
|
Result := FindImageFileFormatByClass(TPNGFileFormat);
|
|
end;
|
|
|
|
procedure TImagingPNG.SaveToStream(Stream: TStream);
|
|
begin
|
|
Imaging.PushOptions;
|
|
Imaging.SetOption(ImagingPNGPreFilter, FPreFilter);
|
|
Imaging.SetOption(ImagingPNGCompressLevel, FCompressLevel);
|
|
inherited SaveToStream(Stream);
|
|
Imaging.PopOptions;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_GIF}
|
|
|
|
{ TImagingGIF class implementation}
|
|
|
|
class function TImagingGIF.GetFileFormat: TImageFileFormat;
|
|
begin
|
|
Result := FindImageFileFormatByClass(TGIFFileFormat);
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_TARGA}
|
|
|
|
{ TImagingTarga class implementation }
|
|
|
|
constructor TImagingTarga.Create;
|
|
begin
|
|
inherited Create;
|
|
FUseRLE := (GetFileFormat as TTargaFileFormat).UseRLE;
|
|
end;
|
|
|
|
class function TImagingTarga.GetFileFormat: TImageFileFormat;
|
|
begin
|
|
Result := FindImageFileFormatByClass(TTargaFileFormat);
|
|
end;
|
|
|
|
procedure TImagingTarga.SaveToStream(Stream: TStream);
|
|
begin
|
|
Imaging.PushOptions;
|
|
Imaging.SetOption(ImagingTargaRLE, Ord(FUseRLE));
|
|
inherited SaveToStream(Stream);
|
|
Imaging.PopOptions;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_DDS}
|
|
|
|
{ TImagingDDS class implementation }
|
|
|
|
constructor TImagingDDS.Create;
|
|
begin
|
|
inherited Create;
|
|
FCompression := dcNone;
|
|
end;
|
|
|
|
class function TImagingDDS.GetFileFormat: TImageFileFormat;
|
|
begin
|
|
Result := FindImageFileFormatByClass(TDDSFileFormat);
|
|
end;
|
|
|
|
procedure TImagingDDS.SaveToStream(Stream: TStream);
|
|
begin
|
|
case FCompression of
|
|
dcNone: FSavingFormat := ifUnknown;
|
|
dcDXT1: FSavingFormat := ifDXT1;
|
|
dcDXT3: FSavingFormat := ifDXT3;
|
|
dcDXT5: FSavingFormat := ifDXT5;
|
|
end;
|
|
Imaging.PushOptions;
|
|
Imaging.SetOption(ImagingDDSSaveCubeMap, Ord(False));
|
|
Imaging.SetOption(ImagingDDSSaveVolume, Ord(False));
|
|
Imaging.SetOption(ImagingDDSSaveMipMapCount, 1);
|
|
Imaging.SetOption(ImagingDDSSaveDepth, 1);
|
|
inherited SaveToStream(Stream);
|
|
Imaging.PopOptions;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_MNG}
|
|
|
|
{ TImagingMNG class implementation }
|
|
|
|
constructor TImagingMNG.Create;
|
|
begin
|
|
inherited Create;
|
|
FLossyCompression := (GetFileFormat as TMNGFileFormat).LossyCompression;
|
|
FLossyAlpha := (GetFileFormat as TMNGFileFormat).LossyAlpha;
|
|
FPreFilter := (GetFileFormat as TMNGFileFormat).PreFilter;
|
|
FCompressLevel := (GetFileFormat as TMNGFileFormat).CompressLevel;
|
|
FQuality := (GetFileFormat as TMNGFileFormat).Quality;
|
|
FProgressive := (GetFileFormat as TMNGFileFormat).Progressive;
|
|
end;
|
|
|
|
class function TImagingMNG.GetFileFormat: TImageFileFormat;
|
|
begin
|
|
Result := FindImageFileFormatByClass(TMNGFileFormat);
|
|
end;
|
|
|
|
{$IFDEF COMPONENT_SET_LCL}
|
|
function TImagingMNG.GetMimeType: string;
|
|
begin
|
|
Result := 'video/mng';
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TImagingMNG.SaveToStream(Stream: TStream);
|
|
begin
|
|
Imaging.PushOptions;
|
|
Imaging.SetOption(ImagingMNGLossyCompression, Ord(FLossyCompression));
|
|
Imaging.SetOption(ImagingMNGLossyAlpha, Ord(FLossyAlpha));
|
|
Imaging.SetOption(ImagingMNGPreFilter, FPreFilter);
|
|
Imaging.SetOption(ImagingMNGCompressLevel, FCompressLevel);
|
|
Imaging.SetOption(ImagingMNGQuality, FQuality);
|
|
Imaging.SetOption(ImagingMNGProgressive, Ord(FProgressive));
|
|
inherited SaveToStream(Stream);
|
|
Imaging.PopOptions;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DONT_LINK_JNG}
|
|
|
|
{ TImagingJNG class implementation }
|
|
|
|
constructor TImagingJNG.Create;
|
|
begin
|
|
inherited Create;
|
|
FLossyAlpha := (GetFileFormat as TJNGFileFormat).LossyAlpha;
|
|
FAlphaPreFilter := (GetFileFormat as TJNGFileFormat).PreFilter;
|
|
FAlphaCompressLevel := (GetFileFormat as TJNGFileFormat).CompressLevel;
|
|
FQuality := (GetFileFormat as TJNGFileFormat).Quality;
|
|
FProgressive := (GetFileFormat as TJNGFileFormat).Progressive;
|
|
end;
|
|
|
|
class function TImagingJNG.GetFileFormat: TImageFileFormat;
|
|
begin
|
|
Result := FindImageFileFormatByClass(TJNGFileFormat);
|
|
end;
|
|
|
|
procedure TImagingJNG.SaveToStream(Stream: TStream);
|
|
begin
|
|
Imaging.PushOptions;
|
|
Imaging.SetOption(ImagingJNGLossyALpha, Ord(FLossyAlpha));
|
|
Imaging.SetOption(ImagingJNGAlphaPreFilter, FAlphaPreFilter);
|
|
Imaging.SetOption(ImagingJNGAlphaCompressLevel, FAlphaCompressLevel);
|
|
Imaging.SetOption(ImagingJNGQuality, FQuality);
|
|
Imaging.SetOption(ImagingJNGProgressive, Ord(FProgressive));
|
|
inherited SaveToStream(Stream);
|
|
Imaging.PopOptions;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
initialization
|
|
RegisterTypes;
|
|
finalization
|
|
UnRegisterTypes;
|
|
|
|
{$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
|
|
|
|
{
|
|
File Notes:
|
|
|
|
-- TODOS ----------------------------------------------------
|
|
- nothing now
|
|
|
|
-- 0.77.1 ---------------------------------------------------
|
|
- Fixed bug in ConvertBitmapToData causing images from GTK2 bitmaps
|
|
to have swapped RB channels.
|
|
- LCL: Removed GTK1 support (deprecated).
|
|
|
|
-- 0.26.3 Changes/Bug Fixes ---------------------------------
|
|
- Transparency of 8bit images (like loaded from 8bit PNG or GIF) is
|
|
kept intact during conversion to TBitmap in ConvertDataToBitmap
|
|
(32bit bitmap is created).
|
|
|
|
-- 0.26.3 Changes/Bug Fixes ---------------------------------
|
|
- Setting AlphaFormat property of TBitmap in ConvertDataToBitmap
|
|
when using Delphi 2009+.
|
|
- Fixed garbled LCL TBitmaps created by ConvertDataToBitmap
|
|
in Mac OS X (Carbon).
|
|
|
|
-- 0.26.1 Changes/Bug Fixes ---------------------------------
|
|
- Added some more IFDEFs for Lazarus widget sets.
|
|
- Removed CLX code.
|
|
- GTK version of Unix DisplayImageData only used with LCL GTK so the
|
|
the rest of the unit can be used with Qt or other LCL interfaces.
|
|
- Fallback mechanism for DisplayImageDataOnDC, it may fail on occasions.
|
|
- Changed file format conditional compilation to reflect changes
|
|
in LINK symbols.
|
|
- Lazarus 0.9.26 compatibility changes.
|
|
|
|
-- 0.24.1 Changes/Bug Fixes ---------------------------------
|
|
- Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus
|
|
with GTK2 target.
|
|
- Added commnets with code for Lazarus rev. 11861+ regarding
|
|
RawImage interface. Replace current code with that in comments
|
|
if you use Lazarus from SVN. New RawImage interface will be used by
|
|
default after next Lazarus release.
|
|
|
|
-- 0.23 Changes/Bug Fixes -----------------------------------
|
|
- Added TImagingGIF.
|
|
|
|
-- 0.21 Changes/Bug Fixes -----------------------------------
|
|
- Uses only high level interface now (except for saving options).
|
|
- Slightly changed class hierarchy. TImagingGraphic is now only for loading
|
|
and base class for savers is new TImagingGraphicForSave. Also
|
|
TImagingGraphic is now registered with all supported file formats
|
|
by TPicture's format support.
|
|
|
|
-- 0.19 Changes/Bug Fixes -----------------------------------
|
|
- added DisplayImage procedures (thanks to Paul Michell, modified)
|
|
- removed RegisterTypes and UnRegisterTypes from interface section,
|
|
they are called automatically
|
|
- added procedures: ConvertImageToBitmap and ConvertBitmapToImage
|
|
|
|
-- 0.17 Changes/Bug Fixes -----------------------------------
|
|
- LCL data to bitmap conversion didn´t work in Linux, fixed
|
|
- added MNG file format
|
|
- added JNG file format
|
|
|
|
-- 0.15 Changes/Bug Fixes -----------------------------------
|
|
- made it LCL compatible
|
|
- made it CLX compatible
|
|
- added all initial stuff
|
|
}
|
|
|
|
end.
|
|
|