转换一批.bmp 文件为 .jpg
unit BMP2JPG_Unit;
interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls ,jpeg, ComCtrls, filectrl, Menus;
type TForm1 = class(TForm) SourceB: TButton; Source: TLabel; Target: TLabel; targetB: TButton; ConvertB: TButton; CQ: TTrackBar; CQL: TLabel; ListBox: TListBox; BRB: TButton; NOW: TCheckBox; Button1: TButton; USD: TCheckBox; StatusBar: TStatusBar; Label1: TLabel; Label2: TLabel; PopupMenu1: TPopupMenu; Addfiles1: TMenuItem; Remove1: TMenuItem; Convertthis1: TMenuItem; Batchrun1: TMenuItem; Removeall1: TMenuItem; procedure SourceBClick(Sender: TObject); procedure targetBClick(Sender: TObject); procedure ConvertBClick(Sender: TObject); procedure CQChange(Sender: TObject); procedure BRBClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Addfiles1Click(Sender: TObject); procedure Batchrun1Click(Sender: TObject); procedure Convertthis1Click(Sender: TObject); procedure Remove1Click(Sender: TObject); procedure ListBoxClick(Sender: TObject); procedure Removeall1Click(Sender: TObject); private { Private declarations } outputdir:string; total:word; public { Public declarations } procedure bmp2jpg(FromBMP,ToJPG:string;Quality:byte); end;
var Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.SourceBClick(Sender: TObject); var op:topendialog; count:integer; begin op:=topendialog.Create(nil); op.Options:=[ofAllowMultiSelect,ofReadOnly,ofPathMustExist,ofFileMustExist]; op.Filter:=''''*.bmp|*.bmp''''; op.Execute; if op.Files.Count>0 then begin listbox.Items.AddStrings(op.Files); source.Caption:=listbox.Items[0]; total:=listbox.Items.Count; statusbar.Panels[0].Text:=''''Total file ''''+inttostr(total); end; op.Free; end;
procedure TForm1.targetBClick(Sender: TObject); var op:tsavedialog; begin op:=tsavedialog.Create(nil); op.Options:=[ofReadOnly,ofPathMustExist]; op.DefaultExt:=''''jpg''''; op.Filter:=''''*.jpg|*.jpg''''; op.Execute; target.Caption:=op.FileName; op.Free; end;
procedure TForm1.ConvertBClick(Sender: TObject); var s:string; begin if now.Checked and fileexists(target.Caption) then exit; statusbar.Panels[0].Text:=''''Converting...''''; statusbar.Panels[1].Text:=''''Current file :''''+extractfilename(source.Caption); sourceb.Enabled:=false; targetb.Enabled:=false; cq.Enabled:=false; convertb.Enabled:=false; if not directoryexists(target.Caption) then begin s:=source.Caption; target.Caption:=extractfilepath(s); s:=extractfilename(s); s:=copy(s,1,pos(''''.'''',s)); target.Caption:=target.Caption+s+''''jpg''''; end; bmp2jpg(source.Caption,target.Caption,cq.Position); sourceb.Enabled:=true; targetb.Enabled:=true; cq.Enabled:=true; convertb.Enabled:=true; statusbar.Panels[0].Text:=''''Ready''''; statusbar.Panels[1].Text:=''''''''; end;
procedure TForm1.CQChange(Sender: TObject); begin cql.Caption:=''''Compress Qualify ''''+ inttostr(cq.Position); end;
procedure TForm1.BRBClick(Sender: TObject); var count:integer; s:string; begin if listbox.Items.Count=0 then exit; SourceB.Enabled:=false; TargetB.Enabled:=false; ConvertB.Enabled:=false; if BRB.Caption=''''Cancel'''' then begin BRB.Caption:=''''Batch Run''''; SourceB.Enabled:=true; TargetB.Enabled:=true; ConvertB.Enabled:=true; total:=listbox.Items.Count; statusbar.Panels[1].Text:=''''Total file ''''+inttostr(total); statusbar.Panels[0].Text:=''''Total file ''''+inttostr(total); end else BRB.Caption:=''''Cancel''''; for count:=0 to listbox.Items.Count-1 do begin S:=listbox.Items[0]; Source.Caption:=s; if (usd.Checked) or (outputdir='''''''') then target.Caption:=extractfilepath(s) else begin if not directoryexists(outputdir) then exit; if length(outputdir)=3 then target.Caption:=outputdir else target.Caption:=outputdir+''''\''''; end; s:=extractfilename(s); s:=copy(s,1,pos(''''.'''',s)); target.Caption:=target.Caption+s+''''jpg''''; if now.Checked and fileexists(target.Caption) then continue; Application.ProcessMessages; if BRB.Caption=''''Batch Run'''' then exit; statusbar.Panels[0].Text:=''''Converting...''''+'''' (''''+inttostr(count+1)+''''/''''+inttostr(total)+'''')''''; statusbar.Panels[1].Text:=''''Current file :''''+extractfilename(source.Caption); bmp2jpg(source.Caption,target.Caption,cq.Position); listbox.Items.Delete(0); end; SourceB.Enabled:=true; TargetB.Enabled:=true; ConvertB.Enabled:=true; BRB.Caption:=''''Batch Run''''; statusbar.Panels[0].Text:=''''Ready''''; statusbar.Panels[1].Text:=''''''''; end;
procedure TForm1.bmp2jpg(FromBMP, ToJPG: string;Quality:byte); var jpg:tjpegimage;bmp:tbitmap; begin if not fileexists(FromBMP) then exit; try bmp:=tbitmap.Create; bmp.LoadFromFile(FromBMP); jpg:=tjpegimage.Create; jpg.Assign(bmp); jpg.CompressionQuality:=Quality; jpg.Compress; jpg.SaveToFile(ToJPG); finally bmp.Free; jpg.Free; end; end;
procedure TForm1.FormCreate(Sender: TObject); begin cql.Caption:=''''Compress Qualify ''''+ inttostr(cq.Position); outputdir:=''''''''; statusbar.Panels[0].Text:=''''Ready''''; end;
procedure TForm1.Button1Click(Sender: TObject); begin selectdirectory(''''Select a output directory'''','''''''',outputdir); target.caption:=outputdir; if directoryexists(outputdir) then usd.Checked:=true else usd.Checked:=false; end;
procedure TForm1.Addfiles1Click(Sender: TObject); begin SourceBClick(nil); end;
procedure TForm1.Batchrun1Click(Sender: TObject); begin BRBClick(nil); end;
procedure TForm1.Convertthis1Click(Sender: TObject); begin ConvertBClick(nil); end;
procedure TForm1.Remove1Click(Sender: TObject); begin Listbox.DeleteSelected; statusbar.Panels[0].Text:=''''Total file ''''+inttostr(total); end;
procedure TForm1.ListBoxClick(Sender: TObject); begin if listbox.SelCount>0 then begin Source.Caption:=ListBox.Items[Listbox.ItemIndex]; Statusbar.Panels[1].Text:=''''Current select file ''''+Extractfilename(Source.Caption); end; end;
procedure TForm1.Removeall1Click(Sender: TObject); begin listbox.Clear; statusbar.Panels[0].Text:=''''Ready''''; end;
end.
|