freebitmap.pas

image converter source code

unit FreeBitmap;

// ==========================================================
//
// Delphi wrapper for FreeImage 3
//
// Design and implementation by
// - Anatoliy Pulyaevskiy ([e-mail])
//
// Contributors:
// - Enzo Costantini ([e-mail])
//
// This file is part of FreeImage 3
//
// COVERED CODE IS PROVIDED UNDER THIS LICENSE ON AN "AS IS" BASIS, WITHOUT WARRANTY
// OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, WITHOUT LIMITATION, WARRANTIES
// THAT THE COVERED CODE IS FREE OF DEFECTS, MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE
// OR NON-INFRINGING. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE COVERED
// CODE IS WITH YOU. SHOULD ANY COVERED CODE PROVE DEFECTIVE IN ANY RESPECT, YOU (NOT
// THE INITIAL DEVELOPER OR ANY OTHER CONTRIBUTOR) ASSUME THE COST OF ANY NECESSARY
// SERVICING, REPAIR OR CORRECTION. THIS DISCLAIMER OF WARRANTY CONSTITUTES AN ESSENTIAL
// PART OF THIS LICENSE. NO USE OF ANY COVERED CODE IS AUTHORIZED HEREUNDER EXCEPT UNDER
// THIS DISCLAIMER.
//
// Use at your own risk!
//
// ==========================================================
//
// From begining all code of this file is based on C++ wrapper to
// FreeImage - FreeImagePlus.
//
// ==========================================================

interface

uses
  SysUtils, Classes, Windows, FreeImage;

type
  { TFreeObject }

  TFreeObject = class(TObject)
  public
    function IsValid: Boolean; virtual;
  end;

  { TFreeTag }

  TFreeTag = class(TFreeObject)
  private
    // fields
    FTag: PFITAG;

    // getters & setters
    function GetCount: Cardinal;
    function GetDescription: string;
    function GetID: Word;
    function GetKey: string;
    function GetLength: Cardinal;
    function GetTagType: FREE_IMAGE_MDTYPE;
    function GetValue: Pointer;
    procedure SetCount(const Value: Cardinal);
    procedure SetDescription(const Value: string);
    procedure SetID(const Value: Word);
    procedure SetKey(const Value: string);
    procedure SetLength(const Value: Cardinal);
    procedure SetTagType(const Value: FREE_IMAGE_MDTYPE);
    procedure SetValue(const Value: Pointer);
  public
    // construction & destruction
    constructor Create(ATag: PFITAG = nil); virtual;
    destructor Destroy; override;

    // methods
    function Clone: TFreeTag;
    function IsValid: Boolean; override;
    function ToString(Model: FREE_IMAGE_MDMODEL; Make: PChar = nil): string;

    // properties
    property Key: string read GetKey write SetKey;
    property Description: string read GetDescription write SetDescription;
    property ID: Word read GetID write SetID;
    property TagType: FREE_IMAGE_MDTYPE read GetTagType write SetTagType;
    property Count: Cardinal read GetCount write SetCount;
    property Length: Cardinal read GetLength write SetLength;
    property Value: Pointer read GetValue write SetValue;
    property Tag: PFITAG read FTag;
  end;

  { forward declarations }

  TFreeBitmap = class;
  TFreeMemoryIO = class;

  { TFreeBitmap }

  TFreeBitmapChangingEvent = procedure(Sender: TFreeBitmap; var OldDib, NewDib: PFIBITMAP; var Handled: Boolean) of object;

  TFreeBitmap = class(TFreeObject)
  private
    // fields
    FDib: PFIBITMAP;
    FOnChange: TNotifyEvent;
    FOnChanging: TFreeBitmapChangingEvent;

    procedure SetDib(Value: PFIBITMAP);
  protected
    function DoChanging(var OldDib, NewDib: PFIBITMAP): Boolean; dynamic;
    function Replace(NewDib: PFIBITMAP): Boolean; dynamic;
  public
    constructor Create(ImageType: FREE_IMAGE_TYPE = FIT_BITMAP; Width: Integer = 0; Height: Integer = 0; Bpp: Integer = 0);
    destructor Destroy; override;
    function SetSize(ImageType: FREE_IMAGE_TYPE; Width, Height, Bpp: Integer; RedMask: Cardinal = 0; GreenMask: Cardinal = 0; BlueMask: Cardinal = 0): Boolean;
    procedure Change; dynamic;
    procedure Assign(Source: TFreeBitmap);
    function CopySubImage(Left, Top, Right, Bottom: Integer; Dest: TFreeBitmap): Boolean;
    function PasteSubImage(Src: TFreeBitmap; Left, Top: Integer; Alpha: Integer = 256): Boolean;
    procedure Clear; virtual;
    function Load(const FileName: string; Flag: Integer = 0): Boolean;
    function LoadU(const FileName: WideString; Flag: Integer = 0): Boolean;
    function LoadFromHandle(IO: PFreeImageIO; Handle: fi_handle; Flag: Integer = 0): Boolean;
    function LoadFromMemory(MemIO: TFreeMemoryIO; Flag: Integer = 0): Boolean;
    function LoadFromStream(Stream: TStream; Flag: Integer = 0): Boolean;
    // save functions
    function CanSave(fif: FREE_IMAGE_FORMAT): Boolean;
    function Save(const FileName: string; Flag: Integer = 0): Boolean;
    function SaveU(const FileName: WideString; Flag: Integer = 0): Boolean;
    function SaveToHandle(fif: FREE_IMAGE_FORMAT; IO: PFreeImageIO; Handle: fi_handle; Flag: Integer = 0): Boolean;
    function SaveToMemory(fif: FREE_IMAGE_FORMAT; MemIO: TFreeMemoryIO; Flag: Integer = 0): Boolean;
    function SaveToStream(fif: FREE_IMAGE_FORMAT; Stream: TStream; Flag: Integer = 0): Boolean;
    // image information
    function GetImageType: FREE_IMAGE_TYPE;
    function GetWidth: Integer;
    function GetHeight: Integer;
    function GetScanWidth: Integer;
    function IsValid: Boolean; override;
    function GetInfo: PBitmapInfo;
    function GetInfoHeader: PBitmapInfoHeader;
    function GetImageSize: Cardinal;
    function GetBitsPerPixel: Integer;
    function GetLine: Integer;
    function GetHorizontalResolution: Double;
    function GetVerticalResolution: Double;
    procedure SetHorizontalResolution(Value: Double);
    procedure SetVerticalResolution(Value: Double);
    // palette operations
    function GetPalette: PRGBQUAD;
    function GetPaletteSize: Integer;
    function GetColorsUsed: Integer;
    function GetColorType: FREE_IMAGE_COLOR_TYPE;
    function IsGrayScale: Boolean;
    // pixels access
    function AccessPixels: PByte;
    function GetScanLine(ScanLine: Integer): PByte;
    function GetPixelIndex(X, Y: Cardinal; var Value: PByte): Boolean;
    function GetPixelColor(X, Y: Cardinal; var Value: PRGBQUAD): Boolean;
    function SetPixelIndex(X, Y: Cardinal; Value: PByte): Boolean;
    function SetPixelColor(X, Y: Cardinal; Value: PRGBQUAD): Boolean;
    // convertion
    function ConvertToStandardType(ScaleLinear: Boolean): Boolean;
    function ConvertToType(ImageType: FREE_IMAGE_TYPE; ScaleLinear: Boolean): Boolean;
    function Threshold(T: Byte): Boolean;
    function ConvertTo4Bits: Boolean;
    function ConvertTo8Bits: Boolean;
    function ConvertTo16Bits555: Boolean;
    function ConvertTo16Bits565: Boolean;
    function ConvertTo24Bits: Boolean;
    function ConvertTo32Bits: Boolean;
    function ConvertToGrayscale: Boolean;
    function ColorQuantize(Algorithm: FREE_IMAGE_QUANTIZE): Boolean;
    function Dither(Algorithm: FREE_IMAGE_DITHER): Boolean;
    function ConvertToRGBF: Boolean;
    function ToneMapping(TMO: FREE_IMAGE_TMO; FirstParam, SecondParam: Double): Boolean;
    // transparency
    function IsTransparent: Boolean;
    function GetTransparencyCount: Cardinal;
    function GetTransparencyTable: PByte;
    procedure SetTransparencyTable(Table: PByte; Count: Integer);
    function HasFileBkColor: Boolean;
    function GetFileBkColor(var BkColor: PRGBQuad): Boolean;
    function SetFileBkColor(BkColor: PRGBQuad): Boolean;
    // channel processing routines
    function GetChannel(Bitmap: TFreeBitmap; Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean;
    function SetChannel(Bitmap: TFreeBitmap; Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean;
    function SplitChannels(RedChannel, GreenChannel, BlueChannel: TFreeBitmap): Boolean;
    function CombineChannels(Red, Green, Blue: TFreeBitmap): Boolean;
    // rotation and flipping
    function RotateEx(Angle, XShift, YShift, XOrigin, YOrigin: Double; UseMask: Boolean): Boolean;
    function Rotate(Angle: Double): Boolean;
    function FlipHorizontal: Boolean;
    function FlipVertical: Boolean;
    // color manipulation routines
    function Invert: Boolean;
    function AdjustCurve(Lut: PByte; Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean;
    function AdjustGamma(Gamma: Double): Boolean;
    function AdjustBrightness(Percentage: Double): Boolean;
    function AdjustContrast(Percentage: Double): Boolean;
    function GetHistogram(Histo: PDWORD; Channel: FREE_IMAGE_COLOR_CHANNEL = FICC_BLACK): Boolean;
    // upsampling / downsampling
    procedure MakeThumbnail(const Width, Height: Integer; DestBitmap: TFreeBitmap);
    function Rescale(NewWidth, NewHeight: Integer; Filter: FREE_IMAGE_FILTER; Dest: TFreeBitmap = nil): Boolean;
    // metadata routines
    function FindFirstMetadata(Model: FREE_IMAGE_MDMODEL; var Tag: TFreeTag): PFIMETADATA;
    function FindNextMetadata(MDHandle: PFIMETADATA; var Tag: TFreeTag): Boolean;
    procedure FindCloseMetadata(MDHandle: PFIMETADATA);
    function SetMetadata(Model: FREE_IMAGE_MDMODEL; const Key: string; Tag: TFreeTag): Boolean;
    function GetMetadata(Model: FREE_IMAGE_MDMODEL; const Key: string; var Tag: TFreeTag): Boolean;
    function GetMetadataCount(Model: FREE_IMAGE_MDMODEL): Cardinal;

    // properties
    property Dib: PFIBITMAP read FDib write SetDib;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TFreeBitmapChangingEvent read FOnChanging write FOnChanging;
  end;
  
  { TFreeWinBitmap }

  TFreeWinBitmap = class(TFreeBitmap)
  private
    FDeleteMe: Boolean;     // True - need to delete FDisplayDib
    FDisplayDib: PFIBITMAP; // Image that paints on DC
  public
    constructor Create(ImageType: FREE_IMAGE_TYPE = FIT_BITMAP; Width: Integer = 0; Height: Integer = 0; Bpp: Integer = 0);
    destructor Destroy; override;

    procedure Clear; override;
    function CopyToHandle: THandle;
    function CopyFromHandle(HMem: THandle): Boolean;
    function CopyFromBitmap(HBmp: HBITMAP): Boolean;
    function CopyToBitmapH: HBITMAP;
    function CopyToClipBoard(NewOwner: HWND): Boolean;
    function PasteFromClipBoard: Boolean;
    function CaptureWindow(ApplicationWindow, SelectedWindow: HWND): Boolean;

    procedure Draw(DC: HDC; Rect: TRect);
    procedure DrawEx(DC: HDC; Rect: TRect; UseFileBkg: Boolean = False; AppBkColor: PRGBQuad = nil; Bg: PFIBITMAP = nil);
  end;

  { TFreeMemoryIO }

  TFreeMemoryIO = class(TFreeObject)
  private
    FHMem: PFIMEMORY;
  public
    // construction and destruction
    constructor Create(Data: PByte = nil; SizeInBytes: DWORD = 0);
    destructor Destroy; override;

    function GetFileType: FREE_IMAGE_FORMAT;
    function Read(fif: FREE_IMAGE_FORMAT; Flag: Integer = 0): PFIBITMAP;
    function Write(fif: FREE_IMAGE_FORMAT; dib: PFIBITMAP; Flag: Integer = 0): Boolean;
    function Tell: Longint;
    function Seek(Offset: Longint; Origin: Word): Boolean;
    function Acquire(var Data: PByte; var SizeInBytes: DWORD): Boolean;
    // overriden methods
    function IsValid: Boolean; override;
  end;

  { TFreeMultiBitmap }

  TFreeMultiBitmap = class(TFreeObject)
  private
    FMPage: PFIMULTIBITMAP;
    FMemoryCache: Boolean;
  public
    // constructor and destructor
    constructor Create(KeepCacheInMemory: Boolean = False);
    destructor Destroy; override;

    // methods
    function Open(const FileName: string; CreateNew, ReadOnly: Boolean; Flags: Integer = 0): Boolean;
    function Close(Flags: Integer = 0): Boolean;
    function GetPageCount: Integer;
    procedure AppendPage(Bitmap: TFreeBitmap);
    procedure InsertPage(Page: Integer; Bitmap: TFreeBitmap);
    procedure DeletePage(Page: Integer);
    function MovePage(Target, Source: Integer): Boolean;
    procedure LockPage(Page: Integer; DestBitmap: TFreeBitmap);
    procedure UnlockPage(Bitmap: TFreeBitmap; Changed: Boolean);
    function GetLockedPageNumbers(var Pages: Integer; var Count: Integer): Boolean;    
    // overriden methods
    function IsValid: Boolean; override;

    // properties
    // change of this property influences only on the next opening of a file
    property MemoryCache: Boolean read FMemoryCache write FMemoryCache;
  end;

implementation

const
  ThumbSize = 150;

// marker used for clipboard copy / paste

procedure SetFreeImageMarker(bmih: PBitmapInfoHeader; dib: PFIBITMAP);
begin
  // Windows constants goes from 0L to 5L
	// Add $FF to avoid conflicts
	bmih.biCompression := $FF + FreeImage_GetImageType(dib);
end;

function GetFreeImageMarker(bmih: PBitmapInfoHeader): FREE_IMAGE_TYPE;
begin
  Result := FREE_IMAGE_TYPE(bmih.biCompression - $FF);
end;

{ TFreePersistent }

function TFreeObject.IsValid: Boolean;
begin
  Result := False
end;

{ TFreeBitmap }

function TFreeBitmap.AccessPixels: PByte;
begin
  Result := FreeImage_GetBits(FDib)
end;

function TFreeBitmap.AdjustBrightness(Percentage: Double): Boolean;
begin
  if FDib <> nil then
  begin
    Result := FreeImage_AdjustBrightness(FDib, Percentage);
    Change;
  end
  else
    Result := False
end;

function TFreeBitmap.AdjustContrast(Percentage: Double): Boolean;
begin
  if FDib <> nil then
  begin
    Result := FreeImage_AdjustContrast(FDib, Percentage);
    Change;
  end
  else
    Result := False
end;

function TFreeBitmap.AdjustCurve(Lut: PByte;
  Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean;
begin
  if FDib <> nil then
  begin
    Result := FreeImage_AdjustCurve(FDib, Lut, Channel);
    Change;
  end
  else
    Result := False
end;

function TFreeBitmap.AdjustGamma(Gamma: Double): Boolean;
begin
  if FDib <> nil then
  begin
    Result := FreeImage_AdjustGamma(FDib, Gamma);
    Change;
  end
  else
    Result := False
end;

procedure TFreeBitmap.Assign(Source: TFreeBitmap);
var
  SourceBmp: TFreeBitmap;
  Clone: PFIBITMAP;
begin
  if Source = nil then
  begin
    Clear;
    Exit;
  end;
  
  if Source is TFreeBitmap then
  begin
    SourceBmp := TFreeBitmap(Source);
    if SourceBmp <> Self then
    begin
      if SourceBmp.IsValid then
      begin
        Clone := FreeImage_Clone(SourceBmp.FDib);
        Replace(Clone);
      end
      else
        Clear;
    end;
  end;
end;

function TFreeBitmap.CanSave(fif: FREE_IMAGE_FORMAT): Boolean;
var
  ImageType: FREE_IMAGE_TYPE;
  Bpp: Word;
begin
  Result := False;
  if not IsValid then Exit;

  if fif <> FIF_UNKNOWN then
  begin
    // check that the dib can be saved in this format
    ImageType := FreeImage_GetImageType(FDib);
    if ImageType = FIT_BITMAP then
    begin
      // standard bitmap type
      Bpp := FreeImage_GetBPP(FDib);
      Result := FreeImage_FIFSupportsWriting(fif)
                and FreeImage_FIFSupportsExportBPP(fif, Bpp);
    end
    else // special bitmap type
      Result := FreeImage_FIFSupportsExportType(fif, ImageType);
  end;
end;

procedure TFreeBitmap.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self)
end;

procedure TFreeBitmap.Clear;
begin
  if FDib <> nil then
  begin
    FreeImage_Unload(FDib);
    FDib := nil;
    Change;
  end;
end;

function TFreeBitmap.ColorQuantize(
  Algorithm: FREE_IMAGE_QUANTIZE): Boolean;
var
  dib8: PFIBITMAP;
begin
  if FDib <> nil then
  begin
    dib8 := FreeImage_ColorQuantize(FDib, Algorithm);
    Result := Replace(dib8);
  end
  else
    Result := False;
end;

function TFreeBitmap.CombineChannels(Red, Green,
  Blue: TFreeBitmap): Boolean;
var
  Width, Height: Integer;
begin
  if FDib = nil then
  begin
    Width := Red.GetWidth;
    Height := Red.GetHeight;
    FDib := FreeImage_Allocate(Width, Height, 24, FI_RGBA_RED_MASK,
            FI_RGBA_GREEN_MASK, FI_RGBA_BLUE_MASK);
  end;

  if FDib <> nil then
  begin
    Result := FreeImage_SetChannel(FDib, Red.FDib, FICC_RED) and
              FreeImage_SetChannel(FDib, Green.FDib, FICC_GREEN) and
              FreeImage_SetChannel(FDib, Blue.FDib, FICC_BLUE);

    Change
  end
  else
    Result := False;
end;

function TFreeBitmap.ConvertTo16Bits555: Boolean;
var
  dib16_555: PFIBITMAP;
begin
  if FDib <> nil then
  begin
    dib16_555 := FreeImage_ConvertTo16Bits555(FDib);
    Result := Replace(dib16_555);
  end
  else
    Result := False
end;

function TFreeBitmap.ConvertTo16Bits565: Boolean;
var
  dib16_565: PFIBITMAP;
begin
  if FDib <> nil then
  begin
    dib16_565 := FreeImage_ConvertTo16Bits565(FDib);
    Result := Replace(dib16_565);
  end
  else
    Result := False
end;

function TFreeBitmap.ConvertTo24Bits: Boolean;
var
  dibRGB: PFIBITMAP;
begin
  if FDib <> nil then
  begin
    dibRGB := FreeImage_ConvertTo24Bits(FDib);
    Result := Replace(dibRGB);
  end
  else
    Result := False
end;

function TFreeBitmap.ConvertTo32Bits: Boolean;
var
  dib32: PFIBITMAP;
begin
  if FDib <> nil then
  begin
    dib32 := FreeImage_ConvertTo32Bits(FDib);
    Result := Replace(dib32);
  end
  else
    Result := False
end;

function TFreeBitmap.ConvertTo4Bits: Boolean;
var
  dib4: PFIBITMAP;
begin
  Result := False;
  if IsValid then
  begin
    dib4 := FreeImage_ConvertTo4Bits(FDib);