Delphi压缩图片代码.docx
- 文档编号:23736061
- 上传时间:2023-05-20
- 格式:DOCX
- 页数:26
- 大小:23.32KB
Delphi压缩图片代码.docx
《Delphi压缩图片代码.docx》由会员分享,可在线阅读,更多相关《Delphi压缩图片代码.docx(26页珍藏版)》请在冰豆网上搜索。
Delphi压缩图片代码
Delphi压缩图片代码
添加引用:
usesJPEG;
//=====================图片处理函数,将覆盖原图片文件===========================
//=====filename:
图片完整路径PressQuality:
压缩质量Width:
宽Height:
高
functionCompressMainFun(filename:
String;PressQuality,Width,Height:
integer):
Boolean;
var
bmp:
TBitmap;
jpg:
TJpegImage;
i:
Integer;
sTemp:
string;
begin
Result:
=False;
ifpos(UpperCase('.bmp'),UpperCase(filename))<>0then//bmp格式
begin
bmp.LoadFromFile(filename);
jpg.Assign(bmp);
jpg.CompressionQuality:
=PressQuality;
jpg.Compress;
bmp.height:
=Height;
bmp.Width:
=Width;
bmp.Canvas.StretchDraw(bmp.Canvas.ClipRect,jpg);
jpg.Assign(bmp);
sTemp:
=filename+'.jpg';
jpg.SaveToFile(sTemp);
DeleteFile(filename);
CopyFile(PChar(sTemp),PChar(filename),True);
DeleteFile(sTemp);
end
else//其它格式
begin
jpg.LoadFromFile(filename);
bmp.height:
=Height;
bmp.Width:
=Width;
bmp.Canvas.StretchDraw(bmp.Canvas.ClipRect,jpg);
jpg.Assign(bmp);
jpg.CompressionQuality:
=PressQuality;
jpg.Compress;
sTemp:
=filename+'.jpg';
jpg.SaveToFile(sTemp);
DeleteFile(filename);
CopyFile(PChar(sTemp),PChar(filename),True);
DeleteFile(sTemp);
end;
Result:
=True;
end;
压缩图像文件并转换成BMP格式
functionGraphicToBmp(P:
TPicture;Quality:
Integer=80):
TBitmap;
var
Jpg:
TJpegImage;
begin
Result:
=TBitmap.Create;
withResultdo
begin
Width:
=P.Width;
Height:
=P.Height;
Canvas.Draw(0,0,P.Graphic);
end;
ifAssigned(Result)then
begin
Jpg:
=TJpegImage.Create;
Jpg.Assign(Result);
Jpg.CompressionQuality:
=Quality;
Jpg.JPEGNeeded;
Jpg.Compress;
ifAssigned(Jpg)then
begin
Jpg.DIBNeeded;
Result.Assign(Jpg);
end;
end;
end;
delphi显示jpg、png、gif图片及gif动画
unitUnit1;
interface
uses
Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
Dialogs,StdCtrls,ExtCtrls;
type
TForm1=class(TForm)
Button1:
TButton;
Button2:
TButton;
Button3:
TButton;
Button4:
TButton;
procedureButton1Click(Sender:
TObject);
procedureButton2Click(Sender:
TObject);
procedureButton3Click(Sender:
TObject);
procedureButton4Click(Sender:
TObject);
end;
var
Form1:
TForm1;
implementation
{$R*.dfm}
usesjpeg,GIFImg,pngimage;
{显示jpg图片}
procedureTForm1.Button1Click(Sender:
TObject);
var
jpg:
TJPEGImage;
begin
jpg:
=TJPEGImage.Create;
jpg.LoadFromFile('C:
\Temp\Test.jpg');
Canvas.Draw(0,0,jpg);
jpg.Free;
end;
{显示png图片}
procedureTForm1.Button2Click(Sender:
TObject);
var
png:
TPngImage;
begin
png:
=TPngImage.Create;
png.LoadFromFile('C:
\Temp\Test.png');
Canvas.Draw(0,0,png);
png.Free;
end;
{显示gif图片}
procedureTForm1.Button3Click(Sender:
TObject);
var
gif:
TGIFImage;
begin
gif:
=TGIFImage.Create;
gif.LoadFromFile('C:
\Temp\Test.gif');
Canvas.Draw(0,0,gif);
gif.Free;
end;
{显示gif动画}
procedureTForm1.Button4Click(Sender:
TObject);
var
gif:
TGIFImage;
begin
gif:
=TGIFImage.Create;
gif.LoadFromFile('C:
\Temp\Test.gif');
gif.Animate:
=True;
withTImage.Create(Self)dobegin
Parent:
=Self;
Left:
=0;
Top:
=0;
Picture.Assign(gif);
end;
gif.Free;
end;
end.
用delphi2010可以将图片的格式在
Bmp,Png, Jpeg, Gif, Tiff WMPhoto
等格式之间互相转换
unitUnit1;
interface
uses
Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
Dialogs,ExtCtrls,StdCtrls;
type
TForm1=class(TForm)
Button1:
TButton;
Image1:
TImage;
procedureButton1Click(Sender:
TObject);
private
{Privatedeclarations}
public
{Publicdeclarations}
end;
var
Form1:
TForm1;
implementation
{$R*.dfm}
// JXSF_PIC_Format_Convert
// 图片格式转换
// [in] pic_stream 原图片的数据流
// [in] toPicForMat 要转换的图片格式
// 0 1 2 3 4 5
// Bmp,Png, Jpeg, Gif, Tiff WMPhoto
// [out]targ_stream
// 转换后的数据流
//返回:
// 转换是否成功
// 0=失败
// 1=成功
functionJXSF_PIC_Format_Convert(
constpic_stream:
TMemoryStream;
consttoPicForMat:
INT32;
consttarg_stream:
TMemoryStream
):
INT32;
var wi:
TWICImage;
var flag :
INT32;
begin
ifnot(toPicForMatin[0..5])then
begin
try
targ_stream.Clear;
except
end;
Result:
=0;exit;
end;
wi:
=TWICImage.Create;
try
pic_stream.Position:
=0;
targ_stream.Clear;
//下面是格式转换核心代码
wi.LoadFromStream(pic_stream);
wi.ImageFormat:
=TWICImageFormat(toPicForMat);
wi.SaveToStream(targ_stream);
targ_stream.Position:
=0;
flag:
=1;
except
flag:
=0;
end;
wi.Free;
Result:
=flag;
end;
procedureTForm1.Button1Click(Sender:
TObject);
varsm1,sm2:
TMemoryStream;
varwi:
TWICImage;
begin
sm1:
=TMemoryStream.Create;
sm2:
=TMemoryStream.Create;
sm1.LoadFromFile('c:
\tt\0002.jpg');
sm1.Position:
=0;
JXSF_PIC_Format_Convert(sm1,0,sm2);
wi:
=TWICImage.Create;
wi.LoadFromStream(sm2);
Image1.Picture.Assign(wi);
wi.Free;
sm1.Free;
sm2.Free;
end;
end.
∙Delphi常见图象格式转换技术
(二)
作者:
lyboy99
e-mail:
lyboy99@
url:
给大家提供几个常用的图象格式转换方法和其转换函数
希望能对你有帮助
1.TxT转换为GIF
2.WMF格式转换为BMP格式
3.BMP格式转换为WMF格式
4.TBitmapsto视窗系统Regions
-----------------------------------------------------------------------
TxT转换为GIF
------------------------------------------------
procedureTxtToGif(txt,FileName:
String);
var
temp:
TBitmap;
GIF:
TGIFImage;
begin
temp:
=TBitmap.Create;
try
temp.Height :
=400;
temp.Width :
=60;
temp.Transparent:
=True;
temp.Canvas.Brush.Color:
=colFondo.ColorValue;
temp.Canvas.Font.Name:
=Fuente.FontName;
temp.Canvas.Font.Color:
=colFuente.ColorValue;
temp.Canvas.TextOut(10,10,txt);
Imagen.Picture.Assign(nil);
GIF:
=TGIFImage.Create;
try
GIF.Assign(Temp);
//保存GIF
GIF.SaveToFile(FileName);
Imagen.Picture.Assign(GIF);
finally
GIF.Free;
end;
Finally
temp.Destroy;
End;
end;
---------------------------------------------------------------------
2.WMF格式转换为BMP格式
--------------------------------------------------------------------
procedureWmfToBmp(FicheroWmf,FicheroBmp:
string);
var
MetaFile:
TMetafile;
Bmp:
TBitmap;
begin
Metafile:
=TMetaFile.create;
{CreateaTemporalBitmap}
Bmp:
=TBitmap.create;
{LoadtheMetafile}
MetaFile.LoadFromFile(FicheroWmf);
{DrawthemetafileinBitmapscanvas}
withBmpdo
begin
Height:
=Metafile.Height;
Width:
=Metafile.Width;
Canvas.Draw(0,0,MetaFile);
{SavetheBMP}
SaveToFile(FicheroBmp);
{FreeBMP}
Free;
end;
{FreeMetafile}
MetaFile.Free;
end;
---------------------------------------------------------------------
3.BMP格式转换为WMF格式
---------------------------------------------------------------------
procedureBmpToWmf(BmpFile,WmfFile:
string);
var
MetaFile:
TMetaFile;
MFCanvas:
TMetaFileCanvas;
BMP:
TBitmap;
begin
{Createtemps}
MetaFile:
=TMetaFile.Create;
BMP:
=TBitmap.create;
BMP.LoadFromFile(BmpFile);
{Igualemostama?
os}
{Equalizingsizes}
MetaFile.Height:
=BMP.Height;
MetaFile.Width:
=BMP.Width;
{CreateacanvasfortheMetafile}
MFCanvas:
=TMetafileCanvas.Create(MetaFile,0);
withMFCanvasdo
begin
{DrawtheBMPintocanvas}
Draw(0,0,BMP);
{FreetheCanvas}
Free;
end;
{FreetheBMP}
BMP.Free;
withMetaFiledo
begin
{SavetheMetafile}
SaveToFile(WmfFile);
{Freeit...}
Free;
end;
end;
---------------------------------------------------------------------
4.TBitmapsto视窗系统Regions
---------------------------------------------------------------------
functionBitmapToRegion(bmp:
TBitmap;TransparentColor:
TColor=clBlack;
RedTol:
Byte=1;GreenTol:
Byte=1;BlueTol:
Byte=1):
HRGN;
const
AllocUnit=100;
type
PRectArray=^TRectArray;
TRectArray=Array[0..(MaxIntdivSizeOf(TRect))-1]ofTRect;
var
pr:
PRectArray;
h:
HRGN;
RgnData:
PRgnData;
lr,lg,lb,hr,hg,hb:
Byte;
x,y,x0:
Integer;
b:
PByteArray;
ScanLinePtr:
Pointer;
ScanLineInc:
Integer;
maxRects:
Cardinal;
begin
Result:
=0;
{Keeponhandlowestandhighestvaluesforthe"transparent"pixels}
lr:
=GetRValue(TransparentColor);
lg:
=GetGValue(TransparentColor);
lb:
=GetBValue(TransparentColor);
hr:
=Min($ff,lr+RedTol);
hg:
=Min($ff,lg+GreenTol);
hb:
=Min($ff,lb+BlueTol);
bmp.PixelFormat:
=pf32bit;
maxRects:
=AllocUnit;
GetMem(RgnData,SizeOf(RGNDATAHEADER)+(SizeOf(TRect)*maxRects));
try
withRgnData^.rdhdo
begin
dwSize:
=SizeOf(RGNDATAHEADER);
iType:
=RDH_RECTANGLES;
nCount:
=0;
nRgnSize:
=0;
SetRect(rcBound,MAXLONG,MAXLONG,0,0);
end;
ScanLinePtr:
=bmp.ScanLine[0];
ScanLineInc:
=Integer(bmp.ScanLine[1])-Integer(ScanLinePtr);
fory:
=0tobmp.Height-1do
begin
x:
=0;
whilex begin x0: =x; whilex begin b: =@PByteArray(ScanLinePtr)[x*SizeOf(TRGBQuad)]; //BGR-RGB: 视窗系统32bppBMPsaremadeofBGRaquads(notRGBa) if(b[2]>=lr)and(b[2]<=hr)and (b[1]>=lg)and(b[1]<=hg)and (b[0]>=lb)and(b[0]<=hb)then Break;//pixelistransparent Inc(x); end; {testtoseeifwehaveanon-transparentareainthe
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- Delphi 压缩 图片 代码