evbgraphics.pas

很好的源代码

unit EvBGraphics;
{ Extensions on the Delphi Graphics unit.
  Contains an TBitmap extension that allows for reading and writing various
  bitmap file formats }

interface

uses
  Windows, Graphics, Classes, SysUtils;

const
  MinCompressionQuality = 1;
  MaxCompressionQuality = 100;

type
  TEvBCompressionQuality = MinCompressionQuality..MaxCompressionQuality;
  { Compression quality for lossy image formats.
    1=lowest quality (smallest file size),
    100=highest quality (biggest file size) }

type
  TEvBBitmapFileFormat = class
  { Base class for reading/writing a custom bitmap file format.
    The various file format filters derive from this class. For specialized
    implementations, see the units EvBFileFormatAIC, EvBFileFormatJPG,
    EvBFileFormatJP2 and EvBFileFormatPNM. }
  private
    FDescription: String;
    FBitmap: TBitmap;
    FBitmapCopy: TBitmap;
    FStream: TStream;
    FQuality: TEvBCompressionQuality;
  protected
    procedure InvalidStream;
    { Can be called by the ReadStream method of a descendent filter to raise an
      exception meaning that the image file does not contain a valid image }
    procedure InternalError(const Msg: String);
    { Can be called by a descendant filter to raise an internal error exception }
    function CreateGreyscalePalette: HPalette;
    { Creates a Windows palette containing 256 entries with greyscale values
      ranging from total black to total white. Can be used by a descendant
      filter when reading a greyscale image. }
    function IsGreyscalePalette(const Palette: HPalette): Boolean;
    { Checks if Palette only contains greyscale values (conforming to the same
      layout as CreateGreyscalePalette). Can be used by a descendant filter to
      determine if the image is in greyscale }
    function CreateGreyscaleBitmapCopy: TBitmap;
    { Creates a greyscale version (8-bit)of the bitmap. Can be used by the
      WriteStream method of a descendant filter if it needs to save a greyscale
      version of the bitmap, and the bitmap is not in greyscale.
      You must NOT free the bitmap returned by this method. This is done
      automatically. A previously made copy (using CreateGreyscaleBitmapCopy
      or CreateTrueColorBitmapCopy) is overwritten by this method. }
    function CreateTrueColorBitmapCopy: TBitmap;
    { Creates a true color version (24-bit) of the bitmap. Can be used by the
      WriteStream method of a descendant filter if it needs to save a true color
      version of the bitmap, and the bitmap is not in true color.
      You must NOT free the bitmap returned by this method. This is done
      automatically. A previously made copy (using CreateGreyscaleBitmapCopy
      or CreateTrueColorBitmapCopy) is overwritten by this method. }

    property Bitmap: TBitmap read FBitmap;
    { The bitmap that needs to be read or written }
    property Stream: TStream read FStream;
    { The stream used to read or write the bitmap }
  public
    constructor Create(const ADescription: String; const ABitmap: TBitmap);
    { Creates in instance of the filter with a description and a bitmap.
      ADescription is used in error messages.
      ABitmap is the bitmap to read or write }
    destructor Destroy; override;
    { Cleanup }

    procedure ReadStream(const Stream: TStream); virtual;
    { The method that must be overwritten to read the bitmap from the stream.
      The overridden method MUST first call the inherited ReadStream.
      This method should set the properties of the Bitmap (size, pixel format
      and contents) }
    procedure WriteStream(const Stream: TStream); virtual;
    { The method that must be overwritten to write the bitmap to the stream.
      The overridden method MUST first call the inherited WriteStream.
      This methoud should write the Bitmap properties (size, pixel format and
      contents) to the stream.
      IMPORTANT: You may not modifiy the contents or properties of the bitmap
      (since this would effect the original bitmap too). If you do need to make
      modifications, you should assign the bitmap to a temporary bitmap or use
      the methods CreateGreyscaleBitmapCopy orCreate TrueColorBitmapCopy. }

    property Quality: TEvBCompressionQuality read FQuality write FQuality;
    { The quality level used to write the bitmap using WriteStream.
      Is only used by filters that support lossy quality levels.
      Defaults to 100 (maximum quality) }
  end;

  TEvBBitmapFileFormatClass = class of TEvBBitmapFileFormat;

type
  TEvBBitmapFileFormatInfo = class
  { Helper class representing the details of a file format.
    Used to retrieve file format information by calling
    TEvBBitmap.GetRegisteredFileFormat. }
  private
    FDescription: String;
    FExtension: String;
    FHeader: String;
    FHeaderOffset: Integer;
    FSupportsQualityLevels: Boolean;
    FFileFormatClass: TEvBBitmapFileFormatClass;
  public
    constructor Create(const ADescription, AExtension, AHeader: String;
      const AHeaderOffset: Integer; const ASupportsQualityLevels: Boolean;
      const AFileFormatClass: TEvBBitmapFileFormatClass);

    property Description: String read FDescription;
    { The description of the file format, eg. 'JPEG-2000' }
    property Extension: String read FExtension;
    { The extension for files in this format, including period, eg. '.JP2' }
    property Header: String read FHeader;
    { A sequence of characters, present at the beginning of the file,
      identifying the format. For example, Bitmap files always start with
      'BM' and .PPM files with 'P6'. }
    property HeaderOffset: Integer read FHeaderOffset;
    { Used in conjunction with Header if this header does not start at the
      beginning of the file. For example, the JPEG-2000 file format stores the
      header 'jP  ' after the first 4 bytes of the file }
    property SupportsQualityLevels: Boolean read FSupportsQualityLevels;
    { Specifies if the file format supports lossy quality levels. }
    property FileFormatClass: TEvBBitmapFileFormatClass read FFileFormatClass;
    { The filter class used to read and write these files. }
  end;

type
  TEvBFilterStringOption = (fsoAllSupportedFiles,fsoAllFiles);
  TEvBFilterStringOptions = set of TEvBFilterStringOption;

type
  TEvBBitmap = class(TBitmap)
  { A TBitmap extension that allows reading and writing bitmaps in various
    registered file formats }
  private
    FQuality: TEvBCompressionQuality;
  public
    constructor Create; override;
    procedure LoadFromFile(const Filename: String); override;
    { Loads the bitmap from a file. The file format filter used depends on the
      extension of Filename. If this extension is not known or not registered,
      Filename is treated as a regular .BMP file }
    procedure LoadFromStream(Stream: TStream); override;
    { Loads the bitmap from a stream. The first few bytes of the stream are used
      to determine which registered file filter should be used. If this
      signature is not known or not registered, it is assumed that the stream
      contains a regular Windows bitmap }
    procedure SaveToFile(const Filename: String); override;
    { Saves the bitmap to a file. The file format filter used depends on the
      extension of Filename. If this extension is not known or not registered,
      the image is written as a regular .BMP file }
    procedure SaveToStream(const Stream: TStream;
      const FileFormatExtension: String); reintroduce; overload;
    { Saves the bitmap to a stream. The FileFormatExtension (including the
      period, eg. '.jpg') determines which registered file filter should be
      used. If the extension is not known or not registered, the image is
      written as a regular Windows bitmap }
    class procedure RegisterFileFormat(const Description, Extension,
      Header: String; const FileFormatClass: TEvBBitmapFileFormatClass;
      const SupportsQualityLevels: Boolean; const HeaderOffset: Integer = 0);
    { Registers a file format filter so TEvBBitmap can use it to read or write
      bitmaps in other formats then the default .BMP format.
      Description: The description of the file format, eg. 'JPEG-2000'.
      Extension: The file extension for files in this format, including
        period, eg. '.JP2'.
      Header: A sequence of characters, present at the beginning of the file,
        identifying the format. For example, Bitmap files always start with
        'BM' and .PPM files with 'P6'.
      FileFormatClass: The filter class used to read and write these files.
      SupportsQualityLevels: Specifies if the file format supports lossy
        quality levels.
      HeaderOffset: Used in conjunction with Header if this header does not start
        at the beginning of the file. For example, the JPEG-2000 file format
        stores the header 'jP  ' after the first 4 bytes of the file }
    class function GetFilterString(const Options: TEvBFilterStringOptions): String;
    { Returns a filter string containing all registered file formats. This
      string can be used with TOpenDialog end TSaveDialog windows.
      Options can contain one or more of the following flags:
        fsoAllSupportedFiles:
          The filter string starts with 'All supported files'
        fsoAllFiles:
          The filter string ends with 'All files (*.*) }
    class function RegisteredFileFormatCount: Integer;
    { Returns the number of registered file formats }
    class function GetRegisteredFileFormat(const Index: Integer): TEvBBitmapFileFormatInfo;
    { Returns information for registered file format number Index }

    property Quality: TEvBCompressionQuality read FQuality write FQuality;
    { The quality level used when writing the bitmap to a format that uses
      lossy quality levels }
  end;

type
  TEvBXYZ = packed record
  { Can be used by file filters to read interleaved color values, for example
    RGB-bytes or BGR-bytes }
    case Boolean of
      False: (A: packed array [0..2] of Byte);
      True : (X, Y, Z: Byte);
  end;
  PEvBXYZ = ^TEvBXYZ;

implementation

uses
  Contnrs;

type
  TEvBBitmapFileFormatList = class(TObjectList)
  private
    function GetItem(const Index: Integer): TEvBBitmapFileFormatInfo;
  public
    constructor Create;
    procedure Add(const Description, Extension, Header: String;
      const HeaderOffset: Integer; const SupportsQualityLevels: Boolean; 
      const FileFormatClass: TEvBBitmapFileFormatClass);
    function FindByExtension(const Extension: String;
      out Description: String): TEvBBitmapFileFormatClass;
    function FindByHeader(const Header: String;
      out Description: String): TEvBBitmapFileFormatClass;

    property Items[const Index: Integer]: TEvBBitmapFileFormatInfo read GetItem; default;
  end;

var
  GlobalBitmapFileFormats: TEvBBitmapFileFormatList = nil;

function BitmapFileFormats: TEvBBitmapFileFormatList;
begin
  if GlobalBitmapFileFormats = nil then
    GlobalBitmapFileFormats := TEvBBitmapFileFormatList.Create;
  Result := GlobalBitmapFileFormats;
end;

{ TEvBBitmapFileFormatInfo }

constructor TEvBBitmapFileFormatInfo.Create(const ADescription, AExtension,
  AHeader: String; const AHeaderOffset: Integer; const ASupportsQualityLevels: Boolean;
  const AFileFormatClass: TEvBBitmapFileFormatClass);
begin
  inherited Create;
  FDescription := ADescription;
  FExtension := AExtension;
  FHeader := AHeader;
  FHeaderOffset := AHeaderOffset;
  FSupportsQualityLevels := ASupportsQualityLevels;
  FFileFormatClass := AFileFormatClass;
end;

{ TEvBBitmapFileFormatList }

procedure TEvBBitmapFileFormatList.Add(const Description, Extension,
  Header: String; const HeaderOffset: Integer; const SupportsQualityLevels: Boolean;
  const FileFormatClass: TEvBBitmapFileFormatClass);
begin
  inherited Insert(0,TEvBBitmapFileFormatInfo.Create(Description,Extension,
    Header,HeaderOffset,SupportsQualityLevels,FileFormatClass));
end;

constructor TEvBBitmapFileFormatList.Create;
begin
  inherited;
  Add('Windows Bitmap','.bmp','BM',0,False,nil);
end;

function TEvBBitmapFileFormatList.FindByExtension(
  const Extension: String; out Description: String): TEvBBitmapFileFormatClass;
var
  I: Integer;
  Info: TEvBBitmapFileFormatInfo;
begin
  for I := 0 to Count - 1 do begin
    Info := Items[I] as TEvBBitmapFileFormatInfo;
    if SameText(Info.Extension,Extension) then begin
      Result := Info.FileFormatClass;
      Description := Info.Description;
      Exit;
    end;
  end;
  Result := nil;
  Description := '';
end;

function TEvBBitmapFileFormatList.FindByHeader(
  const Header: String; out Description: String): TEvBBitmapFileFormatClass;
var
  I: Integer;
  Info: TEvBBitmapFileFormatInfo;
begin