www.pudn.com > JPEG_Batch_Compress__V0.18beta.rar > Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, FileCtrl, ShellApi, Jpeg, ExtCtrls, ComCtrls, ShlObj;
type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
Image1: TImage;
Edit1: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
ProgressBar1: TProgressBar;
Button2: TButton;
Button3: TButton;
procedure StartButton(Sender: TObject);
procedure SelectDir(Sender: TObject);
procedure StopButton(Sender: TObject);
function SearchFile(sFileName, sRootDir: string; bFileOnly, bRecurse: boolean): TStringList;
function GetFileSize(const FileName: string):Integer;
procedure JpegCompress(sFileName1, sRootDir: string);
procedure DoSearchFile(sFileName, sRootDir: string; bFileOnly, bRecurse: boolean;var FileList: TStringList);
procedure FormCreate(Sender: TObject; var Action: TCloseAction);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Edit1Enter(Sender: TObject);
procedure Edit1Exit(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
FileNumber: Integer;
UserStop: Boolean;
implementation
{$R *.DFM}
//取文件大小 (此方法执行完成会自动关闭文件)
function TForm1.GetFileSize(const FileName: string):Integer;
var
f: TFileStream;
begin
if FileExists(FileName) then
begin
f:=TFileStream.Create(FileName,fmOpenRead or fmShareDenyNone);
Result:=f.Size;
F.Free;
end
else Result:=0;
end;
//将 JPEG文件压缩后覆盖原文件
procedure TForm1.JpegCompress(sFileName1, sRootDir: string);
var
JPEGImage1, JPEGImage2: TJPEGImage;
i : integer;
begin
JPEGImage1:=TJPEGImage.Create;
JPEGImage2:=TJPEGImage.Create;
Image1.Picture.Assign(nil);
JPEGImage1.LoadFromFile(sRootDir + '\' + sFileName1);
Form1.Image1.Hide;
//判断图片大小，是否按原比例缩小
if (JPEGImage1.Width>1024) and (JPEGImage1.Height>1024) then
begin
if JPEGImage1.Width <= JPEGImage1.Height then
begin
Image1.Width := Round(JPEGImage1.Width * (1024/JPEGImage1.Width));
Image1.Height:= Round(JPEGImage1.Height * (1024/JPEGImage1.Width));
end
else
begin
Image1.Height:= Round(JPEGImage1.Height * (768/JPEGImage1.Height));
Image1.Width := Round(JPEGImage1.Width * (768/JPEGImage1.Height));
end;
Image1.Proportional := True;
end
else
begin
Image1.Width := JPEGImage1.Width;
Image1.Height := JPEGImage1.Height;
//Image1.Left := Round((Image1.Parent.Width-JPEGImage1.Width)/2);//横向居中显示
Image1.Proportional := True;
ShowMessage('原图显示'+IntToStr(Image1.Width)+' X '+IntToStr(Image1.Height));
end;
Form1.Image1.Canvas.StretchDraw(Form1.Image1.ClientRect,JPEGImage1);
JPEGImage2.Assign(Form1.Image1.Picture.Graphic);
JPEGImage2.CompressionQuality:=75; //图片压缩率
JPEGImage2.Compress;
for i := 0 to 100 do
begin
Form1.ProgressBar1.Position := i;
Sleep(2);
end;
JPEGImage2.SaveToFile(sRootDir + '\' + sFileName1);
JPEGImage1.Free;
JPEGImage2.Free;
end;
//内嵌文件查找递归过程
procedure TForm1.DoSearchFile(sFileName, sRootDir: string; bFileOnly, bRecurse: boolean;var FileList: TStringList);
var
Found, FSize1, FSize2: Integer;
SearchRec: TSearchRec;
begin
//开始查找
Found := FindFirst(sRootDir + '\*.*', faAnyFile, SearchRec); //搜索成功则返回0
while (Found = 0) and (UserStop = False) do
begin
Application.ProcessMessages; //循环中接收按键
//遇到子目录时确定是否查找子目录和是否将符合条件的子目录加入查找结果 (SearchRec.Attr = faDirectory 表示为目录)
if (SearchRec.Attr = faDirectory) and (SearchRec.Name <> '.') and
(SearchRec.Name <> '..') then
begin
if (AnsiCompareText(sFileName, ExtractFileExt(SearchRec.Name)) = 0) and
((Form1.GetFileSize(sRootDir + '\' + SearchRec.Name)) > 488200) and not bFileOnly
then
FileList.Add(sRootDir + '\' + SearchRec.Name); // 如果扩展名相符AND不只找文件，就加到列表 ???
if bRecurse then // 如果bRecurse是TRUE就再查找子目录
Form1.DoSearchFile(sFileName,sRootDir+'\'+ SearchRec.Name,bFileOnly,bRecurse,FileList);
end
else if (AnsiCompareText(sFileName, ExtractFileExt(SearchRec.Name)) = 0)
and ((Form1.GetFileSize(sRootDir + '\' + SearchRec.Name)) > 488200) // 大于500KB
then
begin
FSize1 := Form1.GetFileSize(sRootDir + '\' + SearchRec.Name);
Form1.JpegCompress(SearchRec.Name, sRootDir);
FSize2 := Form1.GetFileSize(sRootDir + '\' + SearchRec.Name);
FileList.Add(sRootDir + '\' + SearchRec.Name + ' ' + IntToStr(FSize1)+ ' ' + IntToStr(FSize2)); // 如果扩展名相符AND不只找文件，就加到列表
FileNumber := FileNumber+1;
Form1.Label3.Caption := IntToStr(FileNumber);
Form1.refresh;
end;
Found := FindNext(SearchRec); //FindNext（） 搜索成功反回0
end;
FindClose(SearchRec);
end;
//选择目录
procedure TForm1.SelectDir(Sender: TObject);
var
TitleName : string;
lpItemID : PItemIDList;
BrowseInfo : TBrowseInfo;
DisplayName : array[0..MAX_PATH] of char;
TempPath : array[0..MAX_PATH] of char;
begin
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
BrowseInfo.hwndOwner := Form1.Handle;
BrowseInfo.pszDisplayName := @DisplayName;
TitleName := 'Please specify a directory';
BrowseInfo.lpszTitle := PChar(TitleName);
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
lpItemID := SHBrowseForFolder(BrowseInfo);
if lpItemId <> nil then
begin
SHGetPathFromIDList(lpItemID, TempPath);
Edit1.Text := TempPath;
GlobalFreePtr(lpItemID);
end;
end;
//文件查找函数 SearchFile
{---------------------------------------
参数说明:
sFileName: 要查找的文件名称
sRootDir: 指定在哪个目录中查找
bFileOnly: 是否只查找文件
bRecurse: 是否查找子目录
返回值:
FileList: 查找结果列表
----------------------------------------}
function TForm1.SearchFile(sFileName, sRootDir: string; bFileOnly, bRecurse: boolean): TStringList;
var
FileList: TStringList;
begin
FileList := TStringList.Create;
FileList.Clear;
Form1.DoSearchFile(sFileName, sRootDir, bFileOnly, bRecurse, FileList);
Result := FileList;
end;
procedure TForm1.StartButton(Sender: TObject);
{按Button时进行查找，结果显示到ListBox中}
begin
FileNumber := 0;
UserStop := False;
Button1.Enabled := False;
Button2.Enabled := True;
Form1.ListBox1.Items.Assign(Form1.SearchFile('.jpg', Edit1.Text, True, True));
Form1.ListBox1.Items.SaveToFile(ExtractFilePath(application.ExeName)+'LOG_'+Formatdatetime('yyyymmddhhmm',Now)+'.txt');
ShowMessage('Compress Finish!');
Button2.Enabled := False;
Button1.Enabled := True;
end;
procedure TForm1.StopButton(Sender: TObject);
begin
if application.messagebox('你真的要停止吗?','请确认对话',mb_yesno+mb_iconquestion)=mryes then
begin
UserStop := True;
ShowMessage('You has click STOP button! Program Stop!');
end;
end;
procedure TForm1.Edit1Enter(Sender: TObject);
begin
Edit1.Clear;
end;
procedure TForm1.Edit1Exit(Sender: TObject);
begin
Edit1.Text := 'Input Start Directory';
end;
procedure TForm1.FormCreate(Sender: TObject; var Action: TCloseAction);
begin
Button2.Enabled := False;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Button2.Enabled := False;
end;
end.