图像缩小放大问题(300分)

要求图片能放大和缩小并保存成文件

有个很笨的办法，要是jpg图，可以装入到TImage里面，利用其stetch(好象叫这个名字)属性
设置为 True 了过后(AotuSize得为 False)，改变TImage的大小试一试？明白了吧
至于保存嘛，可以用抓图的办法
不过一般不会这样用的[]

读指定象素

图象的缩放以前曾经有过很多的解答，建议你参考 ：

http://www.delphibbs.com/delphibbs/dispq.asp?lid=551858

http://www.delphibbs.com/delphibbs/dispq.asp?lid=11806

http://www.delphibbs.com/delphibbs/dispq.asp?lid=102387

以下是一个窗体ResizeCtrlForm.dfm：
object ResizeCtrlForm: TResizeCtrlForm
Left = 242
Top = 41
Width = 208
Height = 371
Caption = '改变尺寸'
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -14
Font.Name = '宋体'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
OnCreate = FormCreate
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 14
object GroupBox1: TGroupBox
Left = 8
Top = 8
Width = 177
Height = 129
Caption = '实际大小'
TabOrder = 0
object Label1: TLabel
Left = 81
Top = 48
Width = 7
Height = 14
Caption = 'X'
end
object Label2: TLabel
Left = 8
Top = 24
Width = 28
Height = 14
Caption = '宽度'
end
object Label3: TLabel
Left = 96
Top = 24
Width = 28
Height = 14
Caption = '高度'
end
object Label7: TLabel
Left = 88
Top = 104
Width = 21
Height = 14
Caption = ': 1'
end
object ActWidEdit: TEdit
Left = 8
Top = 40
Width = 55
Height = 22
TabOrder = 0
OnKeyUp = ActWidEditKeyUp
end
object ActHeiEdit: TEdit
Left = 96
Top = 40
Width = 55
Height = 22
TabOrder = 1
OnKeyUp = ActHeiEditKeyUp
end
object RatioEdit: TEdit
Left = 8
Top = 96
Width = 65
Height = 22
TabOrder = 2
OnKeyUp = RatioEditKeyUp
end
object RatioCheckBox: TCheckBox
Left = 8
Top = 72
Width = 161
Height = 17
Caption = '保持外观比例'
Checked = True
State = cbChecked
TabOrder = 3
end
end
object GroupBox2: TGroupBox
Left = 8
Top = 144
Width = 177
Height = 97
Caption = '百分比'
TabOrder = 1
object Label4: TLabel
Left = 81
Top = 48
Width = 7
Height = 14
Caption = 'X'
end
object Label5: TLabel
Left = 8
Top = 24
Width = 28
Height = 14
Caption = '宽度'
end
object Label6: TLabel
Left = 96
Top = 24
Width = 28
Height = 14
Caption = '高度'
end
object ActHPercEdit: TEdit
Left = 8
Top = 40
Width = 55
Height = 22
TabOrder = 0
OnKeyUp = ActHPercEditKeyUp
end
object ActVPercEdit: TEdit
Left = 96
Top = 40
Width = 55
Height = 22
TabOrder = 1
OnKeyUp = ActVPercEditKeyUp
end
object SynchronCheck: TCheckBox
Left = 8
Top = 72
Width = 97
Height = 17
Caption = '同步'
Checked = True
State = cbChecked
TabOrder = 2
end
end
object GroupBox3: TGroupBox
Left = 8
Top = 248
Width = 177
Height = 57
Caption = '改变尺寸类型'
TabOrder = 2
object TypeCombo: TComboBox
Left = 8
Top = 24
Width = 161
Height = 22
ItemHeight = 14
TabOrder = 0
Items.Strings = (
'SplineFilter'
'BellFilter'
'TriangleFilter'
'BoxFilter'
'HermiteFilter'
'Lanczos3Filter'
'MitchellFilter')
end
end
object BitBtn1: TBitBtn
Left = 8
Top = 312
Width = 75
Height = 25
Caption = '确定'
ModalResult = 1
TabOrder = 3
OnClick = BitBtn1Click
Glyph.Data = {
DE010000424DDE01000000000000760000002800000024000000120000000100
0400000000006801000000000000000000001000000000000000000000000000
80000080000000808000800000008000800080800000C0C0C000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
3333333333333333333333330000333333333333333333333333F33333333333
00003333344333333333333333388F3333333333000033334224333333333333
338338F3333333330000333422224333333333333833338F3333333300003342
222224333333333383333338F3333333000034222A22224333333338F338F333
8F33333300003222A3A2224333333338F3838F338F33333300003A2A333A2224
33333338F83338F338F33333000033A33333A222433333338333338F338F3333
0000333333333A222433333333333338F338F33300003333333333A222433333
333333338F338F33000033333333333A222433333333333338F338F300003333
33333333A222433333333333338F338F00003333333333333A22433333333333
3338F38F000033333333333333A223333333333333338F830000333333333333
333A333333333333333338330000333333333333333333333333333333333333
0000}
NumGlyphs = 2
end
object BitBtn2: TBitBtn
Left = 112
Top = 312
Width = 75
Height = 25
Caption = '取消'
TabOrder = 4
Kind = bkCancel
end
end

unit Resizectrl;

interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons,hhx_basedef,hhx_rotresize,vcl_tools;

type
TResizeCtrlForm = class(TForm)
GroupBox1: TGroupBox;
ActWidEdit: TEdit;
ActHeiEdit: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
GroupBox2: TGroupBox;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
ActHPercEdit: TEdit;
ActVPercEdit: TEdit;
GroupBox3: TGroupBox;
TypeCombo: TComboBox;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
SynchronCheck: TCheckBox;
Label7: TLabel;
RatioEdit: TEdit;
RatioCheckBox: TCheckBox;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure ActWidEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure ActHeiEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure ActVPercEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure ActHPercEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure RatioEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private-Deklarationen }
procedure ActualizeValues;
public
FOrgWidth:Integer;
FOrgHeight:Integer;
FWidth:Integer;
FHeight:Integer;
FHPercent:Integer;
FVPercent:Integer;
FSrcBitmap:TBitmap;
FDestBitmap:TBitmap;
FRatioouble;
{ Public-Deklarationen }
Oldbmp : Tbitmap;

end;

var
ResizeCtrlForm: TResizeCtrlForm;

implementation

uses photomain;

{$R *.DFM}



procedure TResizeCtrlForm.FormCreate(Sender: TObject);
begin
TypeCombo.ItemIndex:=6;
FDestBitmap:=TBitmap.Create;
FDestBitmap.PixelFormat:=pf24Bit;
FSrcBitmap:=TBitmap.Create;
FSrcBitmap.PixelFormat:=pf24Bit;
end;

procedure TResizeCtrlForm.FormShow(Sender: TObject);
begin
Oldbmp := TBitmap.Create;
Oldbmp.Assign(FormMain.image1.Picture.Graphic);

if not Assigned(FSrcBitmap) then
begin
EGraphicConvert.Create('Internal Error. Bitmap not assigned');
Close;
end else
begin
if FSrcBitmap.PixelFormat<>pf24Bit then FSrcBitmap.Pixelformat:=pf24bit;
FOrgWidth:=FSrcBitmap.Width;
FOrgHeight:=FSrcBitmap.Height;
FWidth:=FOrgWidth;
FHeight:=FOrgHeight;
FHPercent:=100;
FVPercent:=100;
FRatio:=FSrcBitmap.Width / FSrcBitmap.Height;
ActualizeValues;
end;
end;

procedure TResizeCtrlForm.ActualizeValues;
begin
ActHPercEdit.Text:=IntToStr(FHPercent);
ActVPercEdit.Text:=IntToStr(FVPercent);
ActWidEdit.Text:=IntToStr(FWidth);
ActHeiEdit.Text:=IntToStr(FHeight);
RatioEdit.Text:=FloatToStr(FRatio);
end;

procedure TResizeCtrlForm.BitBtn1Click(Sender: TObject);
begin
Screen.Cursor:=crHourGlass;
CreateXPanel(Self,200,100);
XPanel.Caption:='正在调整尺寸...';
try
FormMain.SaveCurrentBitmap(OldBmp, FormMain.sCurrentFile , '改变大小');
FormMain.MainMenu1.Items.Items[1].Items[0].Caption :='恢复 改变大小';
FormMain.MenuProcess;

case TypeCombo.ItemIndex of

0: Resample(FSrcBitmap,FDestBitmap,FWidth,Fheight,SplineFilter,3,XProgress);
1: Resample(FSrcBitmap,FDestBitmap,FWidth,Fheight,BellFilter,3,XProgress);
2: Resample(FSrcBitmap,FDestBitmap,FWidth,Fheight,TriangleFilter,3,XProgress);
3: Resample(FSrcBitmap,FDestBitmap,FWidth,Fheight,BoxFilter,3,XProgress);
4: Resample(FSrcBitmap,FDestBitmap,FWidth,Fheight,HermiteFilter,3,XProgress);
5: Resample(FSrcBitmap,FDestBitmap,FWidth,Fheight,Lanczos3Filter,3,XProgress);
6: Resample(FSrcBitmap,FDestBitmap,FWidth,Fheight,MitchellFilter,3,XProgress);
end;
finally
ReleaseXPanel;
Screen.Cursor:=crDefault;
end;
end;

procedure TResizeCtrlForm.ActWidEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Sender as TEdit).Text<>'' then
begin
FWidth:=StrToInt(ActWidEdit.Text);
if RatioCheckBox.Checked then
begin
FHeight:=Round(FWidth / FRatio);
end;
FHPercent:=round(FWidth / (FOrgWidth / 100));
FVPercent:=round(FHeight / (FOrgHeight / 100));
ActualizeValues;
end;

end;

procedure TResizeCtrlForm.ActHeiEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Sender as TEdit).Text<>'' then
begin
FHeight:=StrToInt(ActHeiEdit.Text);
if RatioCheckBox.Checked then
begin
FWidth:=Round(FHeight*FRatio);
end;
FHPercent:=round(FWidth / (FOrgWidth / 100));
FVPercent:=round(FHeight / (FOrgHeight / 100));
ActualizeValues;
end;
end;

procedure TResizeCtrlForm.ActVPercEditKeyUp(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if (Sender as TEdit).Text<>'' then
begin
FVPercent:=StrToInt(ActVPercEdit.Text);
if SynchronCheck.Checked then
begin
FHpercent:=FVPercent;
end;
FWidth:=Round((FOrgWidth / 100)*FHPercent);
Fheight:=Round((FOrgHeight / 100)*FVPercent);
ActualizeValues;
end;
end;

procedure TResizeCtrlForm.ActHPercEditKeyUp(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if (Sender as TEdit).Text<>'' then
begin
FHPercent:=StrToInt(ActHPercEdit.Text);
if SynchronCheck.Checked then
begin
FVpercent:=FHPercent;
end;
FWidth:=Round((FOrgWidth / 100)*FHPercent);
Fheight:=Round((FOrgHeight / 100)*FVPercent);
ActualizeValues;
end;

end;

procedure TResizeCtrlForm.RatioEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Sender as TEdit).Text<>'' then
FRatio:=StrToFloat(RatioEdit.Text);
FHeight:=Round(FWidth / FRatio);
FHPercent:=round(FWidth / (FOrgWidth / 100));
FVPercent:=round(FHeight / (FOrgHeight / 100));

ActualizeValues;
end;
end.

见procedure Resample

unit hhx_RotResize;

interface
uses Classes,Graphics,hhx_basedef;

type TFilterProc = function(Value: Single): Single;

TResampleCallBack = procedure (const Min,Max,Pos:Integer);

TSizeMode= (smUseZoomValue,smOriginal,smFitBoth,smFitWidth,smFitHeight);

PROCEDURE StretchResize(SrcBitmap,DestBitmap:TBitmap;dWidth,dHeight:LongInt;WithBorder:Boolean;BorderColor:TColor;Thumb:Boolean);
PROCEDURE FitResize(SrcBitmap,DestBitmap:TBitmap;dWidth,dHeight:LongInt;WithBorder:Boolean;BorderColor:TColor;Mode:Integer);
PROCEDURE RotateBitmap(SrcBitmap,DestBitmap:TBitmap;Degrees,CenterX,CenterY:Integer;EnlargeCanvas:Boolean;BackGrndColor:TColor;
ResampleCallback:TResampleCallBack);

PROCEDURE FlipBitmap(SrcBitmap,DestBitmap:TBitmap;ResampleCallback:TResampleCallBack);
PROCEDURE MirrorBitmap(SrcBitmap,DestBitmap:TBitmap;ResampleCallback:TResampleCallBack);

procedure Resample(SrcBitmap, DstBitmap: TBitmap;NewWidth,NewHeight:LongInt;Filter: TFilterProc; fwidth: single;
ResampleCallback:TResampleCallBack);

// Sample filters for use with Resample()
function SplineFilter(Value: Single): Single;
function BellFilter(Value: Single): Single;
function TriangleFilter(Value: Single): Single;
function BoxFilter(Value: Single): Single;
function HermiteFilter(Value: Single): Single;
function Lanczos3Filter(Value: Single): Single;
function MitchellFilter(Value: Single): Single;

implementation

// -----------------------------------------------------------------------------
//
// Stretchresize Bitmap
//
// -----------------------------------------------------------------------------

PROCEDURE StretchResize(SrcBitmap,DestBitmap:TBitmap;dWidth,dHeight:LongInt;WithBorder:Boolean;BorderColor:TColor;Thumb:Boolean);
var aWidth,aHeight,dx,dy,mWidth,mHeight:LongInt;
x:Extended;
begin

aWidth:=SrcBitmap.Width;
aHeight:=SrcBitmap.Height;
mWidth:=dWidth;
mHeight:=dHeight;
if (aWidth>=mWidth) or (aHeight>=mHeight) then
begin
if aWidth> aHeight then
begin
x:=aWidth/mWidth;
aWidth:=mWidth;
if x <> 0 then aHeight:=round(aHeight*(1/x));
if aHeight=0 then aHeight:=1;
end
else begin
x:=aHeight/mHeight;
aHeight:=mHeight;
if x <> 0 then aWidth:=round(aWidth*(1/x));
if aWidth=0 then aWidth:=1;
end;
if Assigned(DestBitmap) then with DestBitmap do
begin
PixelFormat:=SrcBitmap.PixelFormat;
dx:=0;
dy:=0;
if WithBorder then
begin
dx:=Round((mWidth-aWidth)/2);
dy:=Round((mHeight-aHeight)/2);
end;
Width:=mWidth;
Height:=mHeight;
Canvas.Brush.Color:=BorderColor;
Canvas.FillRect(Rect(0,0,mWidth,mHeight));
Canvas.Brush.Color:=clNone;
Canvas.CopyMode:=cmSrcCopy;
Canvas.StretchDraw(Rect(dx,dy,dx+aWidth,dy+aHeight),SrcBitmap)
end;
end
else
if (aWidth<mWidth) and (aHeight<mHeight) then
begin
// if picture should be shown as thumb, then use the original imagedimensions
if Thumb then
begin
if Assigned(DestBitmap) then with DestBitmap do
begin
Width:=mWidth;
Height:=mHeight;
Canvas.Brush.Color:=BorderColor;
Canvas.FillRect(Rect(0,0,mWidth,mHeight));
Canvas.Brush.Color:=clNone;
Canvas.CopyMode:=cmSrcCopy;
Canvas.Draw((mwidth-aWidth )div 2,(mHeight-aHeight )div 2,SrcBitmap);
end;
end else
// otherwise, make result larger than original
begin
if aWidth> aHeight then
begin
x:=mWidth/aWidth;
aWidth:=mWidth;
if x <> 0 then aHeight:=round(aHeight*x);
end
else begin
x:=mHeight/aHeight;
aHeight:=mHeight;
if x <> 0 then aWidth:=round(aWidth*x);
end;

if Assigned(DestBitmap) then with DestBitmap do
begin
dx:=0;
dy:=0;
if WithBorder then
begin
dx:=Round((mWidth-aWidth)/2);
dy:=Round((mHeight-aHeight)/2);
end;

Width:=mWidth;
Height:=mHeight;
Canvas.Brush.Color:=BorderColor;
Canvas.FillRect(Rect(0,0,mWidth,mHeight));
Canvas.Brush.Color:=clNone;
Canvas.CopyMode:=cmSrcCopy;
Canvas.StretchDraw(Rect(dx,dy,dx+aWidth,dy+aHeight),SrcBitmap)
end;
end;
end;
end;

// -----------------------------------------------------------------------------
//
// Stretchresize Bitmap
//
// -----------------------------------------------------------------------------

PROCEDURE FitResize(SrcBitmap,DestBitmap:TBitmap;dWidth,dHeight:LongInt;WithBorder:Boolean;BorderColor:TColor;Mode:Integer);
var aWidth,aHeight,dx,dy,mWidth,mHeight:LongInt;
x:Extended;
begin

if Mode=0 then
begin
// change nothing
DestBitmap.Assign(SrcBitmap);
Exit;
end;

aWidth:=SrcBitmap.Width;
aHeight:=SrcBitmap.Height;
mWidth:=dWidth;
mHeight:=dHeight;

// if (aWidth>=mWidth) or (aHeight>=mHeight) then
begin
x:=1;

case Mode of
1:begin
// fit both
if aWidth> aHeight then
begin
if aWidth>mWidth then
begin
x:=aWidth/mWidth;
aWidth:=mWidth;
if x <> 0 then aHeight:=round(aHeight*(1/x));
mHeight:=aHeight;
end else
begin
x:=mWidth/aWidth;
if x <> 0 then aHeight:=round(aHeight*(x));
mHeight:=aHeight;
end;
end
else
begin
if aHeight>mHeight then
begin
x:=aHeight/mHeight;
aHeight:=mHeight;
if x <> 0 then aWidth:=round(aWidth*(1/x));
mWidth:=aWidth;
end else
begin
x:=mHeight/aHeight;
if x <> 0 then aWidth:=round(aWidth*(x));
mWidth:=aWidth;
end;
end;
end;
2:begin
//fit width
if aWidth>mWidth then
begin
x:=aWidth/mWidth;
aWidth:=mWidth;
if x <> 0 then aHeight:=round(aHeight*(1/x));
mHeight:=aHeight;
end else
begin
mHeight:=aHeight;
mWidth:=aWidth;

// x:=mWidth/aWidth;
// if x <> 0 then aHeight:=round(aHeight*(x));
end;
end;
3:begin
//fit height
if aHeight>mHeight then
begin
x:=aHeight/mHeight;
aHeight:=mHeight;
if x <> 0 then aWidth:=round(aWidth*(1/x));
mWidth:=aWidth;
end else
begin
mHeight:=aHeight;
mWidth:=aWidth;
end;
end;
end;

if Assigned(DestBitmap) then with DestBitmap do
begin
PixelFormat:=SrcBitmap.PixelFormat;
dx:=0;
dy:=0;
if WithBorder then
begin
dx:=Round((mWidth-aWidth)/2);
if dx<0 then dx:=0;
dy:=Round((mHeight-aHeight)/2);
if dy<0 then dy:=0;
end;
Width:=mWidth;
Height:=mHeight;
Canvas.Brush.Color:=BorderColor;
Canvas.FillRect(Rect(0,0,mWidth,mHeight));
Canvas.Brush.Color:=clNone;
Canvas.CopyMode:=cmSrcCopy;
Canvas.StretchDraw(Rect(dx,dy,dx+aWidth,dy+aHeight),SrcBitmap)
end;
end
end;

// -----------------------------------------------------------------------------
//
// Rotate Bitmap
//
// -----------------------------------------------------------------------------

PROCEDURE RotateBitmap(SrcBitmap,DestBitmap:TBitmap;Degrees,CenterX,CenterY:Integer;EnlargeCanvas:Boolean;BackGrndColor:TColor;
ResampleCallback:TResampleCallBack);
VAR
cosTheta,sinTheta,Theta : DOUBLE;
Delta : INTEGER;
ecX1,ecY1: Integer;
ecX2,ecY2: Integer;
ecX3,ecY3: Integer;
ecX4,ecY4: Integer;
xDiff,yDiff: Integer;
minX,maxX:Integer;
minY,maxY:Integer;
i,j : INTEGER;
iSrc,jSrc : INTEGER;
iSrcPrime,iDestPrime : INTEGER;
jSrcPrime,jDestPrime : INTEGER;
SrcRow,DestRow : pRGBArray;
function GetRotatedY(OrgX,OrgY:Integer;SinTheta,CosThetaouble):Integer;
begin
Result:=(ROUND((2*(OrgX) + 1) * sinTheta + (2*(OrgY) + 1) * cosTheta) - 1) div 2;
end;
function GetRotatedX(OrgX,OrgY:Integer;SinTheta,CosThetaouble):Integer;
begin
Result:=(ROUND((2*(OrgX) + 1) * CosTheta - (2*(OrgY) + 1) * sinTheta) - 1) div 2;
end;

begin
SrcBitmap.PixelFormat := pf24bit;
DestBitmap.PixelFormat := pf24bit;
Theta := -Degrees * PI / 180;
sinTheta := SIN(Theta);
cosTheta := COS(Theta);
if EnlargeCanvas then
begin
ecX1 := GetRotatedX(0,0,SinTheta,CosTheta);
ecY1 := GetRotatedY(0,0,SinTheta,CosTheta);
ecX2 := GetRotatedX(SrcBitmap.Width,0,SinTheta,CosTheta);
ecY2 := GetRotatedY(SrcBitmap.Width,0,SinTheta,CosTheta);
ecX3 := GetRotatedX(SrcBitmap.Width,SrcBitmap.Height,SinTheta,CosTheta);
ecY3 := GetRotatedY(SrcBitmap.Width,SrcBitmap.Height,SinTheta,CosTheta);
ecX4 := GetRotatedX(0,SrcBitmap.Height,SinTheta,CosTheta);
ecY4 := GetRotatedY(0,SrcBitmap.Height,SinTheta,CosTheta);
if ecX1>=ecX2 then begin maxX:=ecX1;minX:=ecX2;end else begin maxX:=ecX2;minX:=ecX1; end;
if ecY1>=ecY2 then begin maxY:=ecY1;minY:=ecY2;end else begin maxY:=ecY2;minY:=ecY1; end;
if ecX3>=maxX then maxX:=ecX3 else if ecX3<=minX then minX:=ecX3;
if ecY3>=maxY then maxY:=ecY3 else if ecY3<=minY then minY:=ecY3;
if ecX4>=maxX then maxX:=ecX4 else if ecX4<=minX then minX:=ecX4;
if ecY4>=maxY then maxY:=ecY4 else if ecY4<=minY then minY:=ecY4;
DestBitmap.Width:=Abs(MaxX-MinX);
DestBitmap.Height:=Abs(MaxY-MinY);
XDiff :=(DestBitmap.Width-SrcBitmap.Width) div 2;
YDiff :=(DestBitmap.height-SrcBitmap.Height) div 2;

end else
begin
DestBitmap.Width := SrcBitmap.Width;
DestBitmap.Height := SrcBitmap.Height;
yDiff:=0;
xDiff:=0;
end;
FOR j := DestBitmap.Height-1 DOWNTO 0 DO
BEGIN
DestRow := DestBitmap.Scanline[j];
jSrcPrime := 2*(j - (YDiff+CenterY)) + 1;

if Assigned(ResampleCallBack) then ResampleCallBack(0,100,Round(((DestBitmap.Height-j)/DestBitmap.Height)*100));

FOR i := DestBitmap.Width-1 DOWNTO 0 DO
BEGIN
iSrcPrime := 2*(i - (XDiff+CenterX)) + 1;
iDestPrime := ROUND(iSrcPrime * CosTheta - jSrcPrime * sinTheta);
jDestPrime := ROUND(iSrcPrime * sinTheta + jSrcPrime * cosTheta);
iSrc := (iDestPrime - 1) div 2 + CenterX;
jSrc := (jDestPrime - 1) div 2 + CenterY;

IF (iSrc >= 0) AND (iSrc <= SrcBitmap.Width-1) AND
(jSrc >= 0) AND (jSrc <= SrcBitmap.Height-1)
THEN BEGIN
SrcRow := SrcBitmap.Scanline[jSrc];
DestRow := SrcRow[iSrc]
END
ELSE WITH DestRow DO BEGIN
rgbtBlue := (BackgrndColor and $00ff0000) shr 16;
rgbtGreen := (BackgrndColor and $0000ff00) shr 8;
rgbtRed := (BackgrndColor and $000000ff);
END
END
END;
END;

// -----------------------------------------------------------------------------
//
// Flip Bitmap
//
// -----------------------------------------------------------------------------

PROCEDURE FlipBitmap(SrcBitmap,DestBitmap:TBitmap;ResampleCallback:TResampleCallBack);
var i,j :Integer;
SrcRow,DestRow RGBArray;
begin
SetBitmapsEql(SrcBitmap,DestBitmap);
for i:=DestBitmap.Height-1 downto 0 do
begin
SrcRow:=SrcBitmap.ScanLine[DestBitmap.Height-i-1];
DestRow:=DestBitmap.ScanLine;

if Assigned(ResampleCallBack) then ResampleCallBack(0,100,Round((i/SrcBitmap.Height)*100));

for j:=0 to DestBitmap.Width-1 do begin
DestRow[j].rgbtBlue:=SrcRow[j].rgbtBlue;
DestRow[j].rgbtGreen:=SrcRow[j].rgbtGreen;
DestRow[j].rgbtRed:=SrcRow[j].rgbtRed;
end;
end;
end;

// -----------------------------------------------------------------------------
//
// Mirror Bitmap
//
// -----------------------------------------------------------------------------

PROCEDURE MirrorBitmap(SrcBitmap,DestBitmap:TBitmap;ResampleCallback:TResampleCallBack);
var i,j :Integer;
SrcRow,DestRow RGBArray;
begin
SetBitmapsEql(SrcBitmap,DestBitmap);
for i:=DestBitmap.Height-1 downto 0 do
begin
SrcRow:=SrcBitmap.ScanLine;
DestRow:=DestBitmap.ScanLine;

if Assigned(ResampleCallBack) then ResampleCallBack(0,100,Round((i/SrcBitmap.Height)*100));

for j:=0 to DestBitmap.Width-1 do begin
DestRow[j].rgbtBlue:=SrcRow[SrcBitmap.Width-j-1].rgbtBlue;
DestRow[j].rgbtGreen:=SrcRow[SrcBitmap.Width-j-1].rgbtGreen;
DestRow[j].rgbtRed:=SrcRow[SrcBitmap.Width-j-1].rgbtRed;
end;
end;
end;

{
RESAMPLE PART
}
// -----------------------------------------------------------------------------
//
// Filter functions
// (c) by Anders Melander, anders@melander.dk
// -----------------------------------------------------------------------------

// Hermite filter
function HermiteFilter(Value: Single): Single;
begin
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0
else
Result := 0.0;
end;

// Box filter
// a.k.a. "Nearest Neighbour" filter
// anme: I have not been able to get acceptable
// results with this filter for subsampling.
function BoxFilter(Value: Single): Single;
begin
if (Value > -0.5) and (Value <= 0.5) then
Result := 1.0
else
Result := 0.0;
end;

// Triangle filter
function TriangleFilter(Value: Single): Single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
Result := 1.0 - Value
else
Result := 0.0;
end;

// Bell filter
function BellFilter(Value: Single): Single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 0.5) then
Result := 0.75 - Sqr(Value)
else if (Value < 1.5) then
begin
Value := Value - 1.5;
Result := 0.5 * Sqr(Value);
end else
Result := 0.0;
end;

// B-spline filter
function SplineFilter(Value: Single): Single;
var
tt : single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
begin
tt := Sqr(Value);
Result := 0.5*tt*Value - tt + 2.0 / 3.0;
end else if (Value < 2.0) then
begin
Value := 2.0 - Value;
Result := 1.0/6.0 * Sqr(Value) * Value;
end else
Result := 0.0;
end;

// Lanczos3 filter
function Lanczos3Filter(Value: Single): Single;
function SinC(Value: Single): Single;
begin
if (Value <> 0.0) then
begin
Value := Value * Pi;
Result := sin(Value) / Value
end else
Result := 1.0;
end;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 3.0) then
Result := SinC(Value) * SinC(Value / 3.0)
else
Result := 0.0;
end;

function MitchellFilter(Value: Single): Single;
const
B = (1.0 / 3.0);
C = (1.0 / 3.0);
var
tt : single;
begin
if (Value < 0.0) then
Value := -Value;
tt := Sqr(Value);
if (Value < 1.0) then
begin
Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * tt))
+ ((-18.0 + 12.0 * B + 6.0 * C) * tt)
+ (6.0 - 2 * B));
Result := Value / 6.0;
end else
if (Value < 2.0) then
begin
Value := (((-1.0 * B - 6.0 * C) * (Value * tt))
+ ((6.0 * B + 30.0 * C) * tt)
+ ((-12.0 * B - 48.0 * C) * Value)
+ (8.0 * B + 24 * C));
Result := Value / 6.0;
end else
Result := 0.0;
end;


procedure Resample(SrcBitmap, DstBitmap: TBitmap;NewWidth,NewHeight:LongInt;Filter: TFilterProc; fwidth: single;
ResampleCallback:TResampleCallBack);
// -----------------------------------------------------------------------------
//
// Interpolator
// based on algorythm from Anders Melander, anders@melander.dk
// -----------------------------------------------------------------------------
type
// Contributor for a pixel
TContributor = record
pixel: integer; // Source pixel
weight: single; // Pixel weight
end;

TContributorList = array[0..0] of TContributor;
PContributorList = ^TContributorList;

// List of source pixels contributing to a destination pixel
TCList = record
n : integer;
p : PContributorList;
end;

TCListList = array[0..0] of TCList;
PCListList = ^TCListList;

TRGB = packed record
r, g, b : single;
end;
// Physical bitmap scanline (row)
TRGBList = packed array[0..0] of TColorRGB;
PRGBList = ^TRGBList;
var
xscale, yscale : single; // Zoom scale factors
i, j, k : integer; // Loop variables
center : single; // Filter calculation variables
width, fscale, weight : single; // Filter calculation variables
left, right : integer; // Filter calculation variables
n : integer; // Pixel number
Work : TBitmap; // Temporary Bitmap
contrib : PCListList; // Contributor pointer
rgb : TRGB; // RGBTriple
color : TColorRGB; // COlorRGBTriple
SourceLine ,
DestLine : PRGBList;
SourcePixel ,
DestPixel : PColorRGB;
Delta ,
DestDelta : integer;
SrcWidth ,
SrcHeight ,
DstWidth ,
DstHeight : integer;
sMode : Boolean;
begin
DstWidth := NewWidth;
DstHeight := NewHeight;
DstBitmap.Width:=NewWidth;
DstBitmap.Height:=NewHeight;
SrcWidth := SrcBitmap.Width;
SrcHeight := SrcBitmap.Height;
if (SrcWidth < 1) or (SrcHeight < 1) then exit;

Work := TBitmap.Create;
try
Work.Height := SrcHeight;
Work.Width := DstWidth;
if (SrcWidth = 1) then
xscale:= DstWidth / SrcWidth
else
xscale:= (DstWidth - 1) / (SrcWidth - 1);
if (SrcHeight = 1) then
yscale:= DstHeight / SrcHeight
else
yscale:= (DstHeight - 1) / (SrcHeight - 1);

SrcBitmap.PixelFormat := pf24bit;
DstBitmap.PixelFormat := SrcBitmap.PixelFormat;
Work.PixelFormat := SrcBitmap.PixelFormat;

//-----------------------------------------------------------
//
// HORIZONTAL PART
//
//
//-----------------------------------------------------------

// --------------------------------------------
// Pre-calculate filter contributions for a row
// -----------------------------------------------
GetMem(contrib, DstWidth* sizeof(TCList));
// Horizontal sub-/supersampling

// set different modes depending on scaling factor
sMode:=xscale < 1.0;
if sMode then width := fwidth / xscale else width:=fWidth;
if sMode then fscale := 1.0 / xscale else fScale:=1;

for i := 0 to DstWidth-1 do
begin

if Assigned(ResampleCallBack) then ResampleCallBack(0,100,Round((i/DstWidth)*100));

contrib^.n := 0;
GetMem(contrib^.p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / xscale;
left := xFloor(center - width);
right := xCeil(center + width);
for j := left to right do
begin
weight := filter((center - j) / fscale) / fscale;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcWidth) then
n := SrcWidth - j + SrcWidth - 1
else
n := j;
k := contrib^.n;
contrib^.n := contrib^.n + 1;
contrib^.p^[k].pixel := n;
contrib^.p^[k].weight := weight;
end;
end;
// ----------------------------------------------------
// Apply filter to sample horizontally from Src to Work
// ----------------------------------------------------
for k := 0 to SrcHeight-1 do
begin

if Assigned(ResampleCallBack) then ResampleCallBack(0,100,Round((k/SrcHeight)*100));

SourceLine := SrcBitmap.ScanLine[k];
DestPixel := Work.ScanLine[k];
for i := 0 to DstWidth-1 do
begin
rgb.r := 0.0;
rgb.g := 0.0;
rgb.b := 0.0;
for j := 0 to contrib^.n-1 do
begin
color := SourceLine^[contrib^.p^[j].pixel];
weight := contrib^.p^[j].weight;
if (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
color.r:=TrimReal(0,255,RGB.r);
color.g:=TrimReal(0,255,RGB.g);
color.b:=TrimReal(0,255,RGB.b);
// Set new pixel value
DestPixel^ := color;
// Move on to next column
inc(DestPixel);
end;
end;

// Free the memory (horizontal filter weights)
for i := 0 to DstWidth-1 do
FreeMem(contrib^.p);

FreeMem(contrib);

//-----------------------------------------------------------
//
// VERTICAL PART
//
//
//-----------------------------------------------------------
// -----------------------------------------------
// Pre-calculate filter contributions for a column
// -----------------------------------------------
GetMem(contrib, DstHeight* sizeof(TCList));
// Vertical sub-/supersampling

sMode:=yscale < 1.0;
if sMode then width := fwidth / yscale else width:=fWidth;
if sMode then fscale := 1.0 / yscale else fScale:=1;
for i := 0 to DstHeight-1 do
begin

if Assigned(ResampleCallBack) then ResampleCallBack(0,100,Round((i/DstHeight)*100));

contrib^.n := 0;
GetMem(contrib^.p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / yscale;
left := xFloor(center - width);
right := xCeil(center + width);
for j := left to right do
begin
weight := filter((center - j) / fscale) / fscale;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcHeight) then
n := SrcHeight - j + SrcHeight - 1
else
n := j;
k := contrib^.n;
contrib^.n := contrib^.n + 1;
contrib^.p^[k].pixel := n;
contrib^.p^[k].weight := weight;
end;
end;

// --------------------------------------------------
// Apply filter to sample vertically from Work to Dst
// --------------------------------------------------
SourceLine := Work.ScanLine[0];
Delta := integer(Work.ScanLine[1]) - integer(SourceLine);
DestLine := DstBitmap.ScanLine[0];
DestDelta := integer(DstBitmap.ScanLine[1]) - integer(DestLine);
for k := 0 to DstWidth-1 do
begin

if Assigned(ResampleCallBack) then ResampleCallBack(0,100,Round((k/DstWidth)*100));

DestPixel := pointer(DestLine);
for i := 0 to DstHeight-1 do
begin
rgb.r := 0;
rgb.g := 0;
rgb.b := 0;
for j := 0 to contrib^.n-1 do
begin
color := PColorRGB(integer(SourceLine)+contrib^.p^[j].pixel*Delta)^;
weight := contrib^.p^[j].weight;
if (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
color.r:=TrimReal(0,255,RGB.r);
color.g:=TrimReal(0,255,RGB.g);
color.b:=TrimReal(0,255,RGB.b);
DestPixel^ := color;
inc(integer(DestPixel), DestDelta);
end;
Inc(SourceLine, 1);
Inc(DestLine, 1);
end;

// Free the memory (vertical filter weights)
for i := 0 to DstHeight-1 do
FreeMem(contrib^.p);

FreeMem(contrib);

finally
Work.Free;
end;
end;
end.

文件的保存如下： （ 需要安装gifimage控件以支持gif格式）

procedure TFormMain.mnuSaveASClick(Sender: TObject);
var
FileExtension:string; //OutAsBMP: TBitmap;
jpg:TJpegImage; gif:TGIFImage;
begin
FSave.DefaultExt := GraphicExtension(TBitmap);
FSave.FileName:=ChangeFileExt(FSave.FileName,'');
if FSave.Execute then
begin
sCurrentFile := FSave.FileName;

FSave.InitialDir:=ExtractFilePath(FSave.FileName);
FileExtension := LowerCase(ExtractFileExt(FSave.FileName));
if FileExtension ='.bmp' then
image1.picture.bitmap.SaveToFile(FSave.FileName)
else if (FileExtension ='.jpg') or (FileExtension ='.jpeg') then
begin
jpg:=TJpegImage.Create;
try
jpg.Assign(image1.picture.bitmap);
jpg.SaveToFile(FSave.FileName);
finally
jpg.Free;
end;
end
else if (FileExtension ='.gif') then
begin
gif:=TGIFImage.Create;
try
with gif do begin
Assign(image1.picture.bitmap); SaveToFile(FSave.FileName)
end;
finally
gif.Free;
end;
end;
// OutAsBMP.Free;
// ShowBMPFrm.Caption:=ExtractFileName(FSave.FileName);
end;
end;

多人接受答案了。