Delphi 压缩图片(BMP、JPG、PNG)

本文整理自网络，侵删。

 
function CompressImageFile(FileName: string;  Width, Height: integer; PressQuality:Integer= 90): Boolean;
   function GetNewSize(OldWidth, OldHeight: integer; NewWidth, NewHeight: integer; var RetWidth, RetHeight: integer):Boolean;
   var
       H:Boolean;
   begin
       Result := False;
       if (NewHeight < OldHeight) or (NewWidth < OldWidth) then
       begin
          H := NewHeight < OldHeight;
 
          if H then
          begin //按比例缩小,按高度来算高度的
             RetHeight := NewHeight;
             RetWidth := Round(OldWidth *  (NewHeight/OldHeight));
          end
          else
          begin //按比例缩小,按宽度来算宽度的
             RetWidth := NewWidth;
             RetHeight := Round(OldHeight * (NewWidth/OldWidth));
          end;
          Result:=True;
       end;
   end;
var
   bmp: TBitmap;
   jpg: TJpegImage;
   png: TPNGGraphic;
   i: Integer;
   sTemp: string;
begin
 
   Result := False;
   try
      bmp := TBitmap.Create;
      jpg := TJPEGImage.Create;
      png := TPNGGraphic.Create;
      if pos(UpperCase('.bmp'), UpperCase(filename)) <> 0 then   //bmp格式
      begin
         bmp.LoadFromFile(filename);
         jpg.Assign(bmp);
         jpg.CompressionQuality := PressQuality;
         jpg.Compress;
         if GetNewSize(bmp.Width,bmp.height,Width,Height,Width,Height) then
         begin
            bmp.height := Height;
            bmp.Width := Width;
            bmp.Canvas.StretchDraw(bmp.Canvas.ClipRect, jpg);
            jpg.Assign(bmp);
            sTemp := filename + '.lq';
            jpg.SaveToFile(sTemp);
            DeleteFile(filename);
            CopyFile(PChar(sTemp), PChar(filename), True);
            DeleteFile(sTemp);
            Result := True;
         end;
      end
      else if pos(UpperCase('.png'), UpperCase(filename)) <> 0 then //jpg其它格式
      begin
         jpg.LoadFromFile(filename);
         if GetNewSize(jpg.Width,jpg.height,Width,Height,Width,Height) then
         begin
            bmp.height := Height;
            bmp.Width := Width;
            bmp.Canvas.StretchDraw(bmp.Canvas.ClipRect, jpg);
            jpg.Assign(bmp);
            jpg.CompressionQuality := PressQuality;
            jpg.Compress;
            sTemp := filename + '.lq';
            jpg.SaveToFile(sTemp);
            DeleteFile(filename);
            CopyFile(PChar(sTemp), PChar(filename), True);
            DeleteFile(sTemp);
            Result := True;
         end;
      end
      else if pos(UpperCase('.png'), UpperCase(filename)) <> 0 then   //png格式
      begin
         png.LoadFromFile(filename);
         if GetNewSize(png.Width,png.height,Width,Height,Width,Height) then
         begin
            bmp.height := Height;
            bmp.Width := Width;
            bmp.Canvas.StretchDraw(bmp.Canvas.ClipRect, png);
            jpg.Assign(bmp);
            jpg.CompressionQuality := PressQuality;
            jpg.Compress;
            sTemp := filename + '.lq';
            jpg.SaveToFile(sTemp);
            DeleteFile(filename);
            CopyFile(PChar(sTemp), PChar(filename), True);
            DeleteFile(sTemp);
            Result := True;
         end;
      end;
   finally
      FreeAndNil(bmp);
      FreeAndNil(jpg);
      FreeAndNil(png);
   end;
end;
 
procedure TForm1.btn1Click(Sender: TObject);
begin
   CompressImageFile('d:\png\222.png', 200, 200);
end;

――――――――――――――――

原文链接：https://blog.csdn.net/lqena/article/details/78732255
 

相关阅读 >>

行为判断Delphi中窗体最大化与最小化事件

Delphi 主程序装载脚本

Delphi中的sha256算法

Delphi 快速获取文件大小（使用_lopen和fileseek，此函数可以快速获取文件大小，即使文件已经被其它程序锁定）

Delphi win10下message无法接收的问题

Delphi windows 编程[19] - 改变菜单项的状态: getmenustate、enablemenuitem

Delphi xe5复制粘贴操作

Delphi 2009 之 tstringbuilder 类[3]: replace

Delphi 跳出循环的几种方法

minsperday：一天中有多少分钟

更多相关阅读请进入《Delphi》频道 >>

转载请注明出处：木庄网络博客 » Delphi 压缩图片(BMP、JPG、PNG)