magickimage.pas

ImageMagick library of image with Visual C++6

begin
  Result := 0;
  if assigned(FFrames) then
    Result := GetImageListLength(FFrames);
end;

function TMagickImage.GetFramePtr(Index: integer): PImrImage;
begin
  Result := nil;
  if (Index >= 0) and (Index < FrameCount) then
    Result := GetImageFromList(FFrames, Index);
end;

function TMagickImage.GetHeight: Integer;
var
  AFrame: PImrImage;
begin
  Result := 0;
  AFrame := GetFramePtr(FFrameIndex);
  if assigned(AFrame) then
    Result := AFrame.Rows;
end;

function TMagickImage.GetMagickFormat: string;
begin
  Result := '';
  if assigned(FImageInfo) then
    Result := FImageInfo.magick;
end;

function TMagickImage.GetQuality: integer;
// Set JPG/MIFF/PNG compression level
begin
  Result := 75;
  if assigned(FImageInfo) then
    Result := FImageInfo.Quality;
end;

function TMagickImage.GetWidth: Integer;
var
  AFrame: PImrImage;
begin
  Result := 0;
  AFrame := GetFramePtr(FFrameIndex);
  if assigned(AFrame) then
    Result := AFrame.Columns;
end;

procedure TMagickImage.LoadFromClipboardFormat(AFormat: Word;
  AData: THandle; APalette: HPALETTE);
// Load ourself from the clipboard (if format = TBitmap)
var
  ABitmap: TBitmap;
begin
  ABitmap := TBitmap.Create;
  try
    ABitmap.LoadFromClipboardFormat(AFormat, AData, APalette);
    Assign(ABitmap);
  finally
    ABitmap.Free;
  end;
end;

procedure TMagickImage.LoadFromFile(const Filename: string);
// Load an image from AName (either a filename or URL)
var
  ExceptionInfo: TImrExceptionInfo;
  ADensity: string;
begin
  // Create new Exception Info
  GetExceptionInfo(@exceptionInfo);
  try

    if FImageInfo <> nil then begin

      StrPCopy(FImageInfo.Filename, FileName);

      // Set resolution with which to read the image
      ADensity := '';
      if FResolution > 0 then begin
        ADensity := IntToStr(FResolution);
        FImageInfo.Density := PChar(ADensity);
      end;

      FFrames := ReadImage(FImageInfo, @ExceptionInfo);

      // Check for read errors
      ProcessExceptions(ExceptionInfo);

      FImageInfo.Density := nil;

    end;
  finally
    DestroyExceptionInfo(@exceptionInfo);
  end;
end;

procedure TMagickImage.LoadFromStream(Stream: TStream);
var
  ASize: integer;
  ExceptionInfo: TImrExceptionInfo;
  ADensity: string;
begin
  ASize := Stream.Size - Stream.Position;
  if ASize <= 0 then
    raise EInvalidGraphic.Create('Stream size must be defined.');

  // Create new Exception Info
  GetExceptionInfo(@ExceptionInfo);
  try

    if FImageInfo <> nil then begin

      // Set resolution with which to read the image
      ADensity := '';
      if FResolution > 0 then begin
        ADensity := IntToStr(FResolution);
        FImageInfo.Density := PChar(ADensity);
      end;

      // Read stream data into buffer
      FFrames := StreamToImage(Stream, FImageInfo, ASize, @ExceptionInfo);

      // Any errors?
      ProcessExceptions(ExceptionInfo);

      FImageInfo.Density := nil;
    end;
  finally
    DestroyExceptionInfo(@ExceptionInfo);
  end;
end;

procedure TMagickImage.MedianFilterFrame(Radius: Double);
//By Tabibi
var
  ExceptionInfo: TImrExceptionInfo;
  AFrame, NewFrame: PImrImage;
begin
  // Create new Exception Info
  GetExceptionInfo(@ExceptionInfo);
  try
    AFrame := GetFramePtr(FFrameIndex);
    NewFrame := nil;
    if assigned(AFrame) then begin
      NewFrame := MedianFilterImage(AFrame, Radius, @ExceptionInfo);
      // Any errors?
      ProcessExceptions(ExceptionInfo);
    end;
    // Now copy the image back to the original position
    ReplaceFrame(NewFrame);
  finally
    DestroyExceptionInfo(@ExceptionInfo);
  end;
end;

procedure TMagickImage.ProcessExceptions(const ExceptionInfo: TImrExceptionInfo);
begin
  if integer(ExceptionInfo.Severity)  >= FMinExceptionLevel then
  if ExceptionInfo.Severity  <> imUndefinedException then begin
    raise Exception.Create(ExceptionInfo.Reason + #13#10 + ExceptionInfo.Description);
  end;
end;

procedure TMagickImage.Quantize(DitherSize, NumberColors,
  TreeDepth: Cardinal);
//By Tabibi
var
  QuantizeInfo: PImrQuantizeInfo;
  AFrame: PImrImage;
begin
  New(QuantizeInfo);
  GetQuantizeInfo(QuantizeInfo);

  try
    with QuantizeInfo^ do
    begin
      ColorSpace := imRGBColorspace;
      dither := DitherSize;
      MeasureError := 0;
      NumColors := NumberColors;
      TreeDepth := TreeDepth;
    end;

    AFrame := GetFramePtr(FFrameIndex);
    if assigned(AFrame) then
    begin
      QuantizeImage(QuantizeInfo, AFrame);
    end;

  finally
    Dispose(QuantizeInfo);
  end;
end;

procedure TMagickImage.ReplaceFrame(NewFrame: PImrImage);
// Replace the frame at FrameIndex with NewFrame
var
  CurFrame: PImrImage;
begin
  CurFrame := GetFramePtr(FFrameIndex);
  if assigned(CurFrame) and assigned(NewFrame) then begin
    ReplaceImageInList(CurFrame, NewFrame);
    if FFrameIndex = 0 then
      FFrames := NewFrame;
  end;
end;

procedure TMagickImage.ResizeFrame(NewWidth, NewHeight: integer;
  Method: TImResizeMethod; Filter: TImFilterType; BlurRadius: double);
// Resize the current frame
var
  ExceptionInfo: TImrExceptionInfo;
  AFrame, NewFrame: PImrImage;
begin
  // Create new Exception Info
  GetExceptionInfo(@ExceptionInfo);
  try
    AFrame := GetFramePtr(FFrameIndex);
    NewFrame := nil;
    if assigned(AFrame) then begin
      // Resize
      case Method of
      imMagnifyImage:
        NewFrame := MagnifyImage(AFrame, @ExceptionInfo);
      imMinifyImage:
        NewFrame := MinifyImage(AFrame, @ExceptionInfo);
      imResizeImage:
        NewFrame := ResizeImage(AFrame, NewWidth, NewHeight, Filter, BlurRadius, @ExceptionInfo);
      imSampleImage:
        NewFrame := SampleImage(AFrame, NewWidth, NewHeight, @ExceptionInfo);
      imScaleImage:
        NewFrame := ScaleImage(AFrame, NewWidth, NewHeight, @ExceptionInfo);
      imThumbnailImage:
        NewFrame := ThumbnailImage(AFrame, NewWidth, NewHeight, @ExceptionInfo);
      end;
      // Any errors?
      ProcessExceptions(ExceptionInfo);
    end;
    // Now copy the image back to the original position
    ReplaceFrame(NewFrame);
  finally
    DestroyExceptionInfo(@ExceptionInfo);
  end;
end;

procedure TMagickImage.SaveToClipboardFormat(var AFormat: Word;
  var AData: THandle; var APalette: HPALETTE);
// Save ourself to the clipboard (as format = TBitmap)
var
  ABitmap: TBitmap;
begin
  ABitmap := TBitmap.Create;
  try
    AssignTo(ABitmap);
    ABitmap.SaveToClipboardFormat(AFormat, AData, APalette);
  finally
    ABitmap.Free;
  end;
end;

procedure TMagickImage.SaveToFile(const Filename: string);
// Save an image to Filename (either a filename or URL)
var
  ExceptionInfo: TImrExceptionInfo;
  AFrame: PImrImage;
begin
  // Create new Exception Info
  GetExceptionInfo(@exceptionInfo);
  try
    if assigned(FImageInfo) then begin
      AFrame := GetFramePtr(FFrameIndex);
      if assigned(AFrame) then begin
        WriteImages(FImageInfo, AFrame, PChar(FileName), @ExceptionInfo);
        ProcessExceptions(ExceptionInfo);
      end;
    end;
  finally
    DestroyExceptionInfo(@exceptionInfo);
  end;
end;

procedure TMagickImage.SaveToStream(Stream: TStream);
// Save an image to Stream.
// Important! Make sure to set the Magick property to the correct format first,
// e.g. MagickFormat := 'Gif' or MagickFormat := GetFileExt(MyFilename).
// WARNING
// Even with this setting, this procedure still does NOT work correctly in many
// cases. It is better to use SaveToFile instead. Any suggestions why are welcome.
var
  ExceptionInfo: TImrExceptionInfo;
  AFrame: PImrImage;
begin
  // Create new Exception Info
  GetExceptionInfo(@exceptionInfo);
  try
    if assigned(FImageInfo) then begin

      AFrame := GetFramePtr(FFrameIndex);
      if assigned(AFrame) then begin
        ImageToStream(Stream, FImageInfo, AFrame, @ExceptionInfo);
        ProcessExceptions(ExceptionInfo);
      end;
    end;
  finally
    DestroyExceptionInfo(@ExceptionInfo);
  end;
end;

procedure TMagickImage.SetFileName(const Value: string);
begin
  if assigned(FImageInfo) then
    StrPCopy(FImageInfo.Filename, Value);
end;

procedure TMagickImage.SetFrameIndex(const Value: integer);
begin
  if FFrameIndex <> Value then begin
    if FrameCount > 1 then begin
      FFrameIndex := Value;
      // Limit to viable range
      FFrameIndex := Max(0, Min(FFrameIndex, FrameCount - 1));
    end;
  end;
end;

procedure TMagickImage.SetHeight(Value: Integer);
// This routine is present to avoid "abstract" warnings
begin
  // Default does nothing
end;

procedure TMagickImage.SetMagickFormat(const Value: string);
var
  AValue: string;
begin
  if assigned(FImageInfo) then begin
    // Make uppercase
    AValue := Uppercase(Value);
    // Remove first dot (if present)
    if Pos('.', AValue) = 1 then
      AValue := copy(AValue, 2, length(AValue));
    StrPCopy(FImageInfo.Magick, AValue);
  end;
end;

procedure TMagickImage.SetQuality(const Value: integer);
// Set JPG/MIFF/PNG compression level
begin
  if assigned(FImageInfo) then
    FImageInfo.Quality := Value;
end;

procedure TMagickImage.SetWidth(Value: Integer);
// This routine is present to avoid "abstract" warnings
begin
  // Default does nothing..
end;

procedure TMagickImage.ThresholdFrame(const Threshold: Double);
//By Tabibi
var
  AFrame: PImrImage;
begin
  AFrame := GetFramePtr(FFrameIndex);
  if assigned(AFrame) then
    ThresholdImage(AFrame, Threshold);
end;

{ Initialization / Finalization }

procedure InitializeLibrary;
// Here we initialize the Magick library
// with the path to our executable
var
  i: integer;
  AExt, Regd: string;
  Descriptions: string;
const
  cKnownExts  = '.bmp;.ico;.wmf;.emf;';
  // Some formats are better not previewed because they would cause uncomfortably
  // long delay in the Open Picture / Save Picture dialogs
  cNoPreview  = '.avi;.dpx;.epdf;.epi;.eps;.eps2;.eps3;.epsf;.epsi;.ept;.mng;' +
                '.mpeg;.mpg;.m2v;.pdf;.ps;.ps2;.ps3;';
  cImagickFmt = 'Imagick Format'; // A short description - to avoid grahics unit bug
begin
  // We must initialise the library. If it is defined to link dynamically, this
  // call will perform the loadlibrary call and assign all the functions. If
  // the lib is linked statically, this call just returns true. You can change
  // behaviour between dynamic/static behaviour by commenting in/out the define
  // {$DEFINE _DYNAMIC_LOAD} in the ImageMagick Delphi import file.
  FImageMagickAvail := InitImageMagick;

  // Initialize TPicture graphic file formats so they preview in the file open
  // and file save dialog boxes
  for i := 0 to cFilterItemCount - 1 do with cFilterItems[i] do begin
    AExt := Format('.%s;', [LowerCase(Ext)]);
    if (Pos(AExt, cKnownExts) = 0) AND
       (Pos(AExt, cNoPreview) = 0) AND
       (Pos(AExt, Regd)       = 0) then begin

      // Due to a design limitation internally to the graphics unit, the
      // descriptions string cannot become longer than 4098 bytes (D5). There-
      // fore, we must limit the number of added formats here if neccesary.
      // The bug is a result of the buffer limit of the FmtStr command.
      Descriptions := GraphicFilter(TGraphic);
      if Length(Descriptions) > (4098 - 100) then
        raise EInvalidGraphic.Create('Not all ImageMagick formats can be previewed');
      TPicture.RegisterFileFormat(Lowercase(Ext), cImagickFmt, TMagickImage);
      Regd := Regd + Format('.%s;', [AExt]);
    end;
  end;

end;

procedure FinalizeLibrary;
begin
  // This call will unload the library if we are the last to stop using it.
  FreeImageMagick;
end;

initialization

  InitializeLibrary;

finalization

  FinalizeLibrary;

end.