图片等比例大小拉伸，保持最大限度不失真

图片等比例大小拉伸，保持最大限度不失真

procedure StretchImage(ASourceBmp, AStretchBmp: TBitmap; AWidth, AHeight: Integer);
begin
  ASourceBmp.PixelFormat := pf32bit;  //设置位图为32色位图
  AStretchBmp.PixelFormat := pf32bit;  //设置bmp为32色位图
  AStretchBmp.Width := AWidth;
  AStretchBmp.Height := AHeight;
  //保持最大限度不失真
  SetStretchBltMode(AStretchBmp.Canvas.Handle, HALFTONE);
  StretchBlt(AStretchBmp.Canvas.Handle, 0, 0, AWidth, AHeight,
             ASourceBmp.Canvas.Handle, 0, 0, ASourceBmp.Width, ASourceBmp.Height,
             SRCCOPY);
end;

核心使用windows API，其他语言通用，替换即可。再列出样例。 

unit1.pas

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.StdCtrls,
  Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    btn1: TButton;
    trcWidth: TTrackBar;
    trcHeight: TTrackBar;
    lbl1: TLabel;
    lbl2: TLabel;
    procedure trcWidthChange(Sender: TObject);
    procedure btn1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    FStream: TMemoryStream;
    function GetStream: TMemoryStream;
    { Private declarations }
  public
    { Public declarations }
    property Stream: TMemoryStream read GetStream write FStream;
  end;

  function StreamToString(AStream: TStream): string;
  function StringToFile(AString: string; AFileName: TFileName): Boolean;
  function FileToString(AFileName: TFileName): string;
  { 截取当前屏幕}
  procedure CaptureScreen(AStream: TStream);
  { 保持最大限度不失真 拉伸图片}
  procedure StretchImage(ASourceBmp, AStretchBmp: TBitmap; AWidth, AHeight: Integer);

var
  Form1: TForm1;

implementation

{$R *.dfm}
{ 截取当前屏幕}
procedure CaptureScreen(AStream: TStream);
const
  CAPTUREBLT = $40000000;
var
  vHDCScreen: HDC;
  vHDCCompatible: HDC;
  vBmp: TBitmap;
  vHBmpScreen: HBITMAP;
begin
  vHDCScreen := CreateDC('DISPLAY', nil, nil, nil);
  vHDCCompatible := CreateCompatibleDC(vHDCScreen);
  vHBmpScreen := CreateCompatibleBitmap(vHDCScreen,
                                        GetDeviceCaps(vHDCScreen, HORZRES),
                                        GetDeviceCaps(vHDCScreen, VERTRES));
  SelectObject(vHDCCompatible, vHBmpScreen);
  vBmp := TBitmap.Create;
  try
    vBmp.Handle := vHBmpScreen;
    BitBlt(vHDCCompatible, 0, 0, vBmp.Width, vBmp.Height,
           vHDCScreen, 0, 0, SRCCOPY or CAPTUREBLT);
    vBmp.SaveToStream(AStream);
  finally
    vBmp.Free;
    DeleteDC(vHDCScreen);
    DeleteDC(vHDCCompatible);
  end;
end;

procedure TForm1.btn1Click(Sender: TObject);
begin
  CaptureScreen(FStream);
  FStream.Position := 0;
  trcWidthChange(nil);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FreeAndNil(FStream);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FStream := TMemoryStream.Create;

  trcWidth.Min := 1;
  trcWidth.Max := 750;
  trcWidth.Position := trcWidth.Max;

  trcHeight.Min := 1;
  trcHeight.Max := 370;
  trcHeight.Position := trcHeight.Max;

  btn1Click(nil);
end;

function TForm1.GetStream: TMemoryStream;
begin
  FStream.Position := 0;
  Result := FStream;
end;

procedure StretchImage(ASourceBmp, AStretchBmp: TBitmap; AWidth, AHeight: Integer);
begin
  ASourceBmp.PixelFormat := pf32bit;  //设置位图为32色位图
  AStretchBmp.PixelFormat := pf32bit;  //设置bmp为32色位图
  AStretchBmp.Width := AWidth;
  AStretchBmp.Height := AHeight;
  //保持最大限度不失真
  SetStretchBltMode(AStretchBmp.Canvas.Handle, HALFTONE);
  StretchBlt(AStretchBmp.Canvas.Handle, 0, 0, AWidth, AHeight,
             ASourceBmp.Canvas.Handle, 0, 0, ASourceBmp.Width, ASourceBmp.Height,
             SRCCOPY);
end;

procedure TForm1.trcWidthChange(Sender: TObject);
var
  vRectDest, vRectSource: TRect;
  vSourceBmp, vStretchBmp: TBitmap;
begin
  if Stream.Size <= 0 then
    Exit;
  vRectSource.Top := 0;
  vRectSource.Left := 0;
  vRectSource.Width := trcWidth.Position;
  vRectSource.Height := trcHeight.Position;

  vRectDest.Top := vRectSource.Top + 70;
  vRectDest.Left := vRectSource.Left + 70;
  vRectDest.Width := vRectSource.Width;
  vRectDest.Height := vRectSource.Height;

  vSourceBmp := TBitmap.Create;
  vStretchBmp := TBitmap.Create;
  try
    vSourceBmp.LoadFromStream(Stream);
    StretchImage(vSourceBmp,
                 vStretchBmp, trcWidth.Position, trcHeight.Position);

    Canvas.Rectangle(ClientRect);
    Canvas.CopyRect(vRectDest, vStretchBmp.Canvas, vRectSource);
  finally
    FreeAndNil(vSourceBmp);
    FreeAndNil(vStretchBmp);
  end;
end;

//未使用到
{  StreamToString 将内存流转换成字符串   }
function StreamToString(AStream: TStream): string;
var
  I: Integer;
begin
  Result := '';
  if not Assigned(AStream) then
    Exit;
  SetLength(Result, AStream.Size);
  for I := 0 to Pred(AStream.Size) do
  try
    AStream.Position := I;
    AStream.Read(Result[Succ(I)], 1);
  except
    Result := '';
  end;
end;

{  StringToFile  返回字符串保存到文件是否成功    }
function StringToFile(AString: string; AFileName: TFileName): Boolean;
var
  vFileChar: file of Char;
  I: Integer;
begin
{$I-}
  AssignFile(vFileChar, AFileName);
  Rewrite(vFileChar);
  for I := 1 to Length(AString) do
    Write(vFileChar, AString[I]);
  CloseFile(vFileChar);
{$I+}
  Result := (IOResult = 0) and (AFileName <> '');
end;

{   FileToString    返回从文件载入字符串   }
function FileToString(AFileName: TFileName): string;
var
  vFileChar: file of Char;
  vChar: Char;
begin
  Result := '';
{$I-}
  AssignFile(vFileChar, AFileName);
  Reset(vFileChar);

  while not Eof(vFileChar) do
  begin
    Read(vFileChar, vChar);
    Result := Result + vChar;
  end;
  CloseFile(vFileChar);
{$I+}
end;

end.

unit1.dfm

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 465
  ClientWidth = 862
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object lbl1: TLabel
    Left = 20
    Top = 10
    Width = 36
    Height = 13
    Caption = #23485#24230#65306
  end
  object lbl2: TLabel
    Left = 359
    Top = 10
    Width = 36
    Height = 13
    Caption = #39640#24230#65306
  end
  object btn1: TButton
    Left = 703
    Top = 2
    Width = 98
    Height = 32
    Caption = #25130#23631
    TabOrder = 0
    OnClick = btn1Click
  end
  object trcWidth: TTrackBar
    Left = 56
    Top = 8
    Width = 297
    Height = 25
    TabOrder = 1
    OnChange = trcWidthChange
  end
  object trcHeight: TTrackBar
    Left = 392
    Top = 8
    Width = 289
    Height = 25
    TabOrder = 2
    OnChange = trcWidthChange
  end
end