unit ATxImageProc;

interface

uses
  Windows, Graphics, ExtCtrls;

type
  TATImageEffect = (
    iefCorrectOnly,
    iefRotate90,
    iefRotate270,
    iefGrayscale,
    iefNegative
    );

function ImageApplyEffect(
  Image: TImage;
  Effect: TATImageEffect;
  BackColor: TColor): boolean;

function BitmapPrint(
  ABitmap: TBitmap;
  ACopies: word;
  AFitToPage,
  AFitOnlyLarger,
  ACenter: boolean;
  APixelsPerInch: integer;
  const ACaption: string): boolean;

function ImagePrint(
  AImage: TImage;
  ACopies: word;
  AFitToPage,
  AFitOnlyLarger,
  ACenter: boolean;
  APixelsPerInch: integer;
  const ACaption: string): boolean;

function CorrectImage(Image: TImage; BackColor: TColor): boolean;

procedure FixIcon(AIcon: TIcon);


implementation

uses
  Classes, ATxBitmapProc, Jpeg, Printers;

(*
//Old version, doesn't correct icons and metafiles
function CorrectImage(Image: TImage): boolean;
var
  bmp: TBitmap;
begin
  with Image.Picture do
    begin
    Result:= (not (Graphic is TIcon)) and (not (Graphic is TMetafile));
    if Result then
      begin
      if not (Graphic is TBitmap) then
        begin
        bmp:= TBitmap.Create;
        bmp.PixelFormat:= pf24Bit;
        try
          try
            bmp.Assign(Graphic);
            Graphic:= bmp;
          finally
            bmp.Free;
          end;
        except
          Result:= false;
        end;
        end;
      Bitmap.PixelFormat:= pf24Bit;
      end;
    end;

  //debug
  //if not Result then MessageBox(0, 'CorrectImage failed', 'Debug', MB_OK or MB_ICONERROR);
end;
*)

//------------------------------------------------------------------------------
{
From VirtualShellTools,
added BackColor by AT
}
procedure SpStretchDraw(G: TGraphic; OutBitmap: TBitmap; DestR: TRect; UseSubsampling: Boolean; BackColor: TColor);
// Canvas.StretchDraw is NOT THREADSAFE!!!
// Use StretchBlt instead, we have to use a worker bitmap to do so
var
  Work: TBitmap;
begin
  Work := TBitmap.Create;
  Work.Canvas.Lock;
  try
    // Paint the Picture in Work
    if (G is TJpegImage) or (G is TBitmap) then
      Work.Assign(G) //assign works in this case
    else begin
      Work.Width := G.Width;
      Work.Height := G.Height;

      Work.Canvas.Brush.Color:= BackColor;
      Work.Canvas.FillRect(Rect(0, 0, Work.Width, Work.Height));

      Work.Canvas.Draw(0, 0, G);
    end;

    if UseSubsampling then
      SetStretchBltMode(OutBitmap.Canvas.Handle, STRETCH_HALFTONE)
    else
      SetStretchBltMode(OutBitmap.Canvas.Handle, STRETCH_DELETESCANS);

    StretchBlt(OutBitmap.Canvas.Handle,
      DestR.Left, DestR.Top, DestR.Right - DestR.Left, DestR.Bottom - DestR.Top,
      Work.Canvas.Handle, 0, 0, G.Width, G.Height, SRCCopy);
  finally
    Work.Canvas.Unlock;
    Work.Free;
  end;
end;

//------------------------------------------------------------------------------
function CorrectImageToBitmap(Image: TImage; bmp: TBitmap; BackColor: TColor): boolean;
var
  DestR: TRect;
begin
  Result:= true;

  Assert(
    Assigned(bmp),
    'CorrectImageToBitmap: bitmap not assigned.');

  with Image.Picture do
    try
      bmp.PixelFormat:= pf24Bit;
      DestR:= Rect(0, 0, 0, 0);
      DestR.Right:= Graphic.Width;
      DestR.Bottom:= Graphic.Height;
      bmp.Width:= DestR.Right;
      bmp.Height:= DestR.Bottom;
      bmp.Canvas.Brush.Color:= BackColor;
      bmp.Canvas.FillRect(Rect(0, 0, DestR.Right, DestR.Bottom));
      SpStretchDraw(Graphic, bmp, DestR, false, BackColor);
    except
      Result:= false;
    end;

  Assert(
    (bmp.Width>0) and (bmp.Height>0),
    'CorrectImageToBitmap: result bitmap is empty.');
end;


function CorrectImage(Image: TImage; BackColor: TColor): boolean;
var
  bmp: TBitmap;
begin
  Result:= true;
  with Image.Picture do
    if (not (Graphic is TBitmap)) or ((Graphic is TBitmap) and (TBitmap(Graphic).PixelFormat<>pf24Bit)) then
      try
        bmp:= TBitmap.Create;
        try
          Result:= CorrectImageToBitmap(Image, bmp, BackColor);
          Image.Picture.Graphic:= bmp;
        finally
          bmp.Free;
        end;
      except
        Result:= false;
      end;
end;


//------------------------------------------------------------------------------
function ImageApplyEffect(
  Image: TImage;
  Effect: TATImageEffect;
  BackColor: TColor): boolean;
var
  bmp: TBitmap;
begin
  Result:= CorrectImage(Image, BackColor);
  if Result then
    if Effect<>iefCorrectOnly then
      begin
      bmp:= nil;
      try
        case Effect of
          iefRotate90: bmp:= RotateBitmap90(Image.Picture.Bitmap);
          iefRotate270: bmp:= RotateBitmap270(Image.Picture.Bitmap);
          iefGrayscale: bmp:= ConvertToGrayscale(Image.Picture.Bitmap);
          iefNegative: bmp:= ConvertToNegative(Image.Picture.Bitmap);
        end;
        Image.Picture.Bitmap.FreeImage;
        Image.Picture.Bitmap.Assign(bmp);
      finally
        if Assigned(bmp) then
          bmp.Free;
      end;
      end;
end;


//------------------------------------------------------------------------------
//{$define ADV_IMAGE_CONV}

{
Печать изображения. Использует модуль Printers.
Должно работать со всеми типами графики: битмепами, метафайлами и иконками.
(c) Alexey Torgashin, 2007

Последняя версия функции всегда доступна в исходниках компонента ATViewer:
http://atorg.net.ru/delphi/atviewer.htm

Параметры:
- AImage: TImage объект.
- ACopies: число копий (можно задать 0 для одной копии).
- AFitToPage: умещать картинку в страницу принтера. Если картинка меньше
  страницы и AFitOnlyLarger=False, то картинка будет растянута.
- AFitOnlyLarger: разрешает умещать только картинки, бОльшие размера страницы.
- ACenter: центрировать картинку по странице.
- APixelsPerInch: число точек на дюйм на экране. Передавайте сюда значение
  св-ва PixelsPerInch Вашей формы или объекта Screen.
- ACaption: заголовок задания печати в Print Manager.

-----------------------------------

Image printing. Uses Printers unit.
Should work with all graphics: bitmaps, metafiles and icons.

Parameters:
- AImage: TImage object.
- ACopies: number of copies (you may set 0 for a single copy).
- AFitToPage: fit image to a printer page. If image is smaller than a page and
  AFitOnlyLarger=False then image will be stretched up to a page.
- AFitOnlyLarger: allows to stretch images smaller than a page.
- ACenter: center image on a page.
- APixelsPerInch: pass here value of PixelsPerInch property of your form or
  of a Screen object (Screen.PixelsPerInch).
- ACaption: print job caption in Print Manager.
}

function ImagePrint(
  AImage: TImage;
  ACopies: word;
  AFitToPage,
  AFitOnlyLarger,
  ACenter: boolean;
  APixelsPerInch: integer;
  const ACaption: string): boolean;
var
  bmp: TBitmap;
begin
  bmp:= TBitmap.Create;
  try
    {$ifdef ADV_IMAGE_CONV}
    if not CorrectImageToBitmap(AImage, bmp, clWhite) then
    begin
      Result:= false;
      Exit
    end;
    {$else}
    with AImage.Picture do
    begin
      bmp.PixelFormat:= pf24bit;
      bmp.Width:= Graphic.Width;
      bmp.Height:= Graphic.Height;
      bmp.Canvas.Draw(0, 0, Graphic);
    end;
    {$endif}

    Result:= BitmapPrint( //Declared below
      bmp,
      ACopies,
      AFitToPage,
      AFitOnlyLarger,
      ACenter,
      APixelsPerInch,
      ACaption);
  finally
    bmp.Free;
  end;
end;


function BitmapPrint(
  ABitmap: TBitmap;
  ACopies: word;
  AFitToPage,
  AFitOnlyLarger,
  ACenter: boolean;
  APixelsPerInch: integer;
  const ACaption: string): boolean;
var
  Scale, ScalePX, ScalePY, ScaleX, ScaleY: Double;
  SizeX, SizeY,
  RectSizeX, RectSizeY, RectOffsetX, RectOffsetY: integer;
  i: integer;
Begin
  Result:= true;

  Assert(
    Assigned(ABitmap) and (ABitmap.Width>0) and (ABitmap.Height>0),
    'BitmapPrint: bitmap is empty.');

  if ACopies = 0 then
    Inc(ACopies);

  with Printer do
  begin
    SizeX:= PageWidth;
    SizeY:= PageHeight;

    ScalePX:= GetDeviceCaps(Handle, LOGPIXELSX) / APixelsPerInch;
    ScalePY:= GetDeviceCaps(Handle, LOGPIXELSY) / APixelsPerInch;

    ScaleX:= SizeX / ABitmap.Width / ScalePX;
    ScaleY:= SizeY / ABitmap.Height / ScalePY;
    
    if ScaleX < ScaleY then
      Scale:= ScaleX
    else
      Scale:= ScaleY;

    if (not AFitToPage) or (AFitOnlyLarger and (Scale > 1.0)) then
      Scale:= 1.0;

    RectSizeX:= Trunc(ABitmap.Width * Scale * ScalePX);
    RectSizeY:= Trunc(ABitmap.Height * Scale * ScalePY);

    if ACenter then
    begin
      RectOffsetX:= (SizeX - RectSizeX) div 2;
      RectOffsetY:= (SizeY - RectSizeY) div 2;
    end
    else
    begin
      RectOffsetX:= 0;
      RectOffsetY:= 0;
    end;

    Title:= ACaption;

    try
      BeginDoc;
      try
        for i:= 1 to ACopies do
        begin
          Canvas.StretchDraw(
            Rect(
              RectOffsetX,
              RectOffsetY,
              RectOffsetX + RectSizeX,
              RectOffsetY + RectSizeY),
            ABitmap
            );
          if i < ACopies then
            NewPage;
        end;
      finally
        EndDoc;
      end;
    except
      Result:= false;
    end;
  end;
end;


{
Need to "fix" icon sizes. Icon should be drawn once before its sizes are to be read.
http://qc.codegear.com/wc/qcmain.aspx?d=6018
}
procedure FixIcon(AIcon: TIcon);
var
  Bmp: TBitmap;
begin
  try
    Bmp:= TBitmap.Create;
    try
      Bmp.PixelFormat:= pf24bit;
      Bmp.Canvas.Draw(0, 0, AIcon);
    finally
      Bmp.Free;
    end;
  except
  end;
end;


end.
