main.pas

JPG图片压缩,根据设定的图像质量有损压缩图像

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, jpeg, ShellAPI, ShlObj, ComCtrls, Math, StrUtils;

type
  TForm1 = class(TForm)
    btn1: TButton;
    btn2: TButton;
    lbl1: TLabel;
    btn3: TButton;
    edt1: TEdit;
    pb1: TProgressBar;
    StaticText1: TStaticText;
    Label3: TLabel;
    edt4: TEdit;
    StaticText2: TStaticText;
    procedure btn2Click(Sender: TObject);
    procedure btn3Click(Sender: TObject);
    procedure btn1Click(Sender: TObject);
    procedure FindSubDir(DirName: string; FileString: TStrings);
    procedure SearchFilename(const Dir, Ext: string; Files: TStrings);
    function MakeFileList(Path,FileExt:string):TStringList ;
  private
    { Private declarations }
    function IsValidDir(SearchRec: TSearchRec): Boolean;

  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Dir:string;
implementation

{$R *.dfm}



function BrowseDialogCallBack
  (Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM):
  integer stdcall;
var
  wa, rect: TRect;
  dialogPT: TPoint;
begin
  //center in work area
  if uMsg = BFFM_INITIALIZED then
  begin
    wa := Screen.WorkAreaRect;
    GetWindowRect(Wnd, Rect);
    dialogPT.X := ((wa.Right - wa.Left) div 2) -
      ((rect.Right - rect.Left) div 2);
    dialogPT.Y := ((wa.Bottom - wa.Top) div 2) -
      ((rect.Bottom - rect.Top) div 2);
    MoveWindow(Wnd,
      dialogPT.X,
      dialogPT.Y,
      Rect.Right - Rect.Left,
      Rect.Bottom - Rect.Top,
      True);
  end;

  Result := 0;
end; (*BrowseDialogCallBack*)


function BrowseDialog
  (const Title: string; const Flag: integer): string;
var
  lpItemID: PItemIDList;
  BrowseInfo: TBrowseInfo;
  DisplayName: array[0..MAX_PATH] of char;
  TempPath: array[0..MAX_PATH] of char;
begin
  Result := '';
  FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
  with BrowseInfo do
  begin
    hwndOwner := Application.Handle;
    pszDisplayName := @DisplayName;
    lpszTitle := PChar(Title);
    ulFlags := Flag;
    lpfn := BrowseDialogCallBack;
  end;
  lpItemID := SHBrowseForFolder(BrowseInfo);
  if lpItemId <> nil then
  begin
    SHGetPathFromIDList(lpItemID, TempPath);
    Result := TempPath;
    GlobalFreePtr(lpItemID);
  end;
end;

procedure TForm1.btn2Click(Sender: TObject);

begin
//  mmo1.Clear;
  pb1.Position := 0;
  StaticText1.Caption := '处理进度：';
  edt1.Text := BrowseDialog('请指定图片所在的文件夹！', 0);
  Dir := edt1.Text+'\';
end;

procedure TForm1.btn3Click(Sender: TObject);
begin
  close;
end;


procedure TForm1.btn1Click(Sender: TObject);
var
  bmp: TBitmap;
  jpg: TJpegImage;
  stemp: string;
  i: Integer;
  filelstJpg: TStringList;
  a: Integer;
begin
  a := 0;
  pb1.Min := 0;
  bmp := TBitmap.Create;
  jpg := TJpegImage.Create;
  //filelstJpg := TStringList.Create;
  //SearchFilename(edt1.Text+'\','.jpg',filelstJpg);
  filelstJpg := MakeFileList(edt1.Text,'.jpg') ;
  try
     a := filelstJpg.Count;
    pb1.Max := filelstJpg.Count;
    if filelstJpg.Count <> 0 then
    begin

      for i := 0 to filelstJpg.Count - 1 do
      begin
        try

            jpg.LoadFromFile(filelstJpg.Strings[i]);
            bmp.height := jpg.Height;
            bmp.Width := jpg.Width;
            bmp.Canvas.StretchDraw(bmp.Canvas.ClipRect, jpg);
            jpg.Assign(bmp);
            jpg.CompressionQuality := StrToInt(edt4.Text); //StrToInt('75');
            jpg.Compress;
            sTemp := filelstJpg.Strings[i] + '.jpg';
            jpg.SaveToFile(sTemp);
            DeleteFile(filelstJpg.Strings[i]);
            CopyFile(PChar(sTemp), PChar(filelstJpg.Strings[i]), True);
            DeleteFile(sTemp);
            pb1.Position := pb1.Position + 1;
            StaticText1.Caption := '处理进度：' + inttostr(trunc((pb1.Position / pb1.Max) * 100)) + '%';
            StaticText2.Caption := '处理张数:'+ IntToStr(Trunc(i+1));
        except
            Application.MessageBox(PChar(filelstJpg.Strings[i]+'处理出错！'),'系统提示',mrOk);

        end;

      end;
      Application.MessageBox(PChar('共'+inttostr(a)+'个JPG格式图片处理完毕！'+#13#10),'系统提示',mrOk);
    end
    else
    begin
      ShowMessage('未发现JPG格式的图片文件！' + #13#10 )
    end;
  finally
    jpg.Free;
    bmp.Free;
    filelstJpg.free;
    MessageBox(0, PChar('共计处理图片：' + inttostr(a ) + '个！'), '提示', MB_OK)

  end;
end;

procedure TForm1.SearchFilename(const Dir, Ext: string; Files: TStrings);
var
  Found: TSearchRec;
  i: integer;
  Dirs: TStrings;
  Finished: integer;
  StopSearch: Boolean;
begin
  StopSearch := False;
  Dirs := TStringList.Create;
  Finished := FindFirst(Dir + '*.*', 63, Found);
  while (Finished = 0) and not (StopSearch) do
  begin
    if (Found.Name <> '.') then
    begin
      if (Found.Attr and faDirectory) = faDirectory then
        Dirs.Add(Dir + Found.Name)
      else
        if Pos(UpperCase(Ext), UpperCase(Found.Name)) > 0 then
          Files.Add(Dir + Found.Name);
    end;
    Finished := FindNext(Found);
  end;
  FindClose(Found);
  if not StopSearch then
    for i := 0 to Dirs.Count - 1 do
        SearchFilename(Dirs[i], Ext, Files);
  Dirs.Free;
end;

procedure TForm1.FindSubDir(DirName: string; FileString: TStrings);
var
 searchRec: TsearchRec;
begin
//找出所有下级子目录。
  if (FindFirst(DirName + '*.*', faDirectory, SearchRec) = 0) then
  begin
    if IsValidDir(SearchRec) then
      FileString.Add(DirName + SearchRec.Name);
    while (FindNext(SearchRec) = 0) do
    begin
      if IsValidDir(SearchRec) then
        FileString.Add(DirName + SearchRec.Name);
    end;
  end;
  FindClose(SearchRec);
end;

function TForm1.IsValidDir(SearchRec: TSearchRec): Boolean;
begin
  if (SearchRec.Attr = 16) and (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
    Result := True
  else
    Result := False;
end;

function TForm1.MakeFileList(Path,FileExt:string):TStringList ;
var
sch:TSearchrec;
begin
  Result:=TStringlist.Create;

  if rightStr(trim(Path), 1) <> '\' then
      Path := trim(Path) + '\'
  else
      Path := trim(Path);

  if not DirectoryExists(Path) then
  begin
      Result.Clear;
      exit;
  end;

  if FindFirst(Path + '*', faAnyfile, sch) = 0 then
  begin
      repeat
         Application.ProcessMessages;
         if ((sch.Name = '.') or (sch.Name = '..')) then Continue;
         if DirectoryExists(Path+sch.Name) then
         begin
           Result.AddStrings(MakeFileList(Path+sch.Name,FileExt));
         end
         else
         begin
           if (UpperCase(extractfileext(Path+sch.Name)) = UpperCase(FileExt)) or (FileExt='.*') then
           Result.Add(Path+sch.Name);
         end;
      until FindNext(sch) <> 0;
      SysUtils.FindClose(sch);
  end;
end;

end.