Delphi XE10进行图像裁剪缩放

unit uImageCropping;

{
图像缩放剪裁单元
支持bmp\jpg\jpeg\png
}

interface

uses
  System.Types, vcl.Graphics, System.SysUtils, Vcl.Imaging.pngimage,
  Vcl.Imaging.jpeg, System.Math;

const
  GDefaultWidth  = 800;
  GDefaultHeight = 600;

  function CutZoom(var _bmp:TBitmap):Boolean;
  function ImageCropping(ASrcFile, ADestFile:string):Boolean;

implementation

uses
  ServerModule;

function GetBytesPerPixel(PixelFormat: TPixelFormat): Integer;
begin
  case PixelFormat of
    pfDevice:       Result := 0;       // 设备相关格式（需特殊处理）
    pf1bit:         Result := 0;       // 1位/像素（按位操作，非字节对齐）
    pf4bit:         Result := 0;       // 4位/像素（按半字节操作）
    pf8bit:         Result := 1;       // 8位/像素（1字节）
    pf15bit:        Result := 2;       // 15位高彩色（2字节，已过时）
    pf16bit:        Result := 2;       // 16位高彩色（2字节）
    pf24bit:        Result := 3;       // 24位真彩色（3字节）
    pf32bit:        Result := 4;       // 32位带Alpha通道（4字节）
  else
    Result := 0; // 未知格式
  end;
end;

//裁剪缩放图像
function CutZoom(var _bmp:TBitmap):Boolean;
var
  _BmpIn, _BmpCut, _BmpOut : TBitmap;
  _SrcRect, _DestRect : TRect;
  _SrcLine, _DestLine: PByteArray;
  Y: Integer;
  _BytesPerPixel : Byte;
  //计算裁剪边界
  function CalculateBoundary(_OriginalWidth, _OriginalHeight : Integer;  var _ASrcRect:TRect; var _ADestRect:TRect):Boolean;
  var
    _CenterX, _CenterY: Integer;
    _Ratio : Double;
  begin
    Result := False;
    if (_OriginalWidth <= 0) or (_OriginalHeight <= 0) then Exit;

    //计算中心坐标
    _CenterX := Round(_OriginalWidth / 2);
    _CenterY := Round(_OriginalHeight / 2);

    if (_OriginalWidth >= GDefaultWidth) and (_OriginalHeight >= GDefaultHeight) then
    begin
      _Ratio := Min(_OriginalWidth/GDefaultWidth, _OriginalHeight/GDefaultHeight);
    end
    else if (_OriginalWidth >= GDefaultWidth) and (_OriginalHeight < GDefaultHeight) then
    begin
      _Ratio := _OriginalHeight/GDefaultHeight;
    end
    else if (_OriginalWidth < GDefaultWidth) and (_OriginalHeight >= GDefaultHeight) then
    begin
      _Ratio := _OriginalWidth/GDefaultWidth;
    end
    else if (_OriginalWidth < GDefaultWidth) and (_OriginalHeight < GDefaultHeight) then
    begin
      _Ratio := Max(_OriginalWidth/GDefaultWidth, _OriginalHeight/GDefaultHeight);
    end;

    //计算输入和输出的画布大小
    _ASrcRect := Rect(Round(_CenterX - GDefaultWidth * _Ratio / 2),
                      Round(_CenterY - GDefaultHeight * _Ratio / 2),
                      Round(_CenterX + GDefaultWidth * _Ratio / 2),
                      Round(_CenterY + GDefaultHeight * _Ratio / 2));
    _ADestRect := Rect(0, 0, GDefaultWidth, GDefaultHeight);
    Result := True;
  end;
begin
  Result := False;
  _BmpIn  := TBitmap.Create;
  _BmpCut := TBitmap.Create;
  _BmpOut := TBitmap.Create;
  try
    try
      //加载图像
      _BmpIn.Assign(_bmp);
      //计算区域
      if not CalculateBoundary(_BmpIn.Width,
                               _BmpIn.Height,
                               _SrcRect,
                               _DestRect) then Exit;

      _BytesPerPixel := GetBytesPerPixel(_BmpIn.PixelFormat);

      //剪切图像
      _BmpCut.SetSize(_SrcRect.Width, _SrcRect.Height);
      _BmpCut.PixelFormat := _BmpIn.PixelFormat;
      _BmpOut.AlphaFormat := afDefined;
      _BmpOut.HandleType := bmDIB;
      for Y := 0 to _BmpCut.Height - 1 do
      begin
        _SrcLine := _BmpIn.ScanLine[Y + _SrcRect.Top];
        _DestLine := _BmpCut.ScanLine[Y];
        Move(
              _SrcLine^[_SrcRect.Left * _BytesPerPixel],
              _DestLine^,
              _BmpCut.Width * _BytesPerPixel
            );
      end;

      //缩放图像
      _BmpOut.SetSize(GDefaultWidth, GDefaultHeight);
      _BmpOut.PixelFormat := _BmpIn.PixelFormat;//  pf32bit; pf24bit
      _BmpOut.AlphaFormat := afDefined;//   afDefined;
      _BmpOut.HandleType := bmDIB;
      _BmpOut.Canvas.StretchDraw(_DestRect, _BmpCut);
      //输出图像
      _bmp.Assign(_BmpOut);
      Result := True;
    except
      on e:exception do
      begin
        UniServerModule.Logger.AddLog('CutZoom', Format(' Err %s', [E.message]), 'Business');
      end;
    end;
  finally
    if Assigned(_BmpIn) then FreeAndNil(_BmpIn);
    if Assigned(_BmpCut) then FreeAndNil(_BmpCut);
    if Assigned(_BmpOut) then FreeAndNil(_BmpOut);
  end;
end;


function ImageCropping(ASrcFile, ADestFile:string):Boolean;
var
  _Bmp : TBitmap;
  _Pngimage : TPngimage;
  _JPEGImage : TJPEGImage;
  _sExt : string;
begin
  Result := False;
  //判断文件是否存在
  if not FileExists(ASrcFile) then Exit;
  _sExt := Lowercase(ExtractFileExt(ASrcFile));
  if (_sExt = '.jpg') or (_sExt = '.jpeg') then
  begin
    _Bmp := TBitmap.Create;
    _JPEGImage := TJPEGImage.Create;
    try
      //加载图片
      _JPEGImage.LoadFromFile(ASrcFile);
      //转由_Bmp处理
      _Bmp.Assign(_JPEGImage);

      //图像裁剪缩放
      if not CutZoom(_Bmp) then Exit;

      //保存至输出路径
      _JPEGImage.Assign(_Bmp);
      _JPEGImage.CompressionQuality := 80;
      _JPEGImage.SaveToFile(ADestFile);
      Result := True;
    finally
      if Assigned(_Bmp) then FreeAndNil(_Bmp);
      if Assigned(_JPEGImage) then FreeAndNil(_JPEGImage);
    end;
  end
  else if (_sExt = '.bmp') then
  begin
    _Bmp := TBitmap.Create;
    try
      //加载图片
      _Bmp.LoadFromFile(ASrcFile);

      //图像裁剪缩放
      if not CutZoom(_Bmp) then Exit;

      //保存至输出路径
      _Bmp.SaveToFile(ADestFile);
      Result := True;
    finally
      if Assigned(_Bmp) then FreeAndNil(_Bmp);
    end;
  end
  else if (_sExt = '.png') then
  begin
    _Bmp := TBitmap.Create;
    _Pngimage := TPngimage.Create;
    try
      //加载图片
      _Pngimage.LoadFromFile(ASrcFile);
      //转由_Bmp处理
      _Bmp.Assign(_Pngimage);

      //图像裁剪缩放
      if not CutZoom(_Bmp) then Exit;

      //保存至输出路径
      _Pngimage.Assign(_Bmp);
//      _Pngimage.CompressionQuality := 100;
      _Pngimage.SaveToFile(ADestFile);
      Result := True;
    finally
      if Assigned(_Bmp) then FreeAndNil(_Bmp);
      if Assigned(_Pngimage) then FreeAndNil(_Pngimage);
    end;
  end
end;

end.

uses uImageCropping;


_SrcFile  := 'D:\12.jpg';
_DestFile := 'D:\12_Cut.jpg';
ImageCropping(_SrcFile, _DestFile);