Delphiben szeretnék írni egy képkonvertáló programot?

Eddig ez a programod kódja - Igaz Mondó Reloaded kedvéért:

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, SynGdiPlus, ExtCtrls, StdCtrls, ComCtrls, FileCtrl, Buttons;

type

TForm1 = class(TForm)

imgPrev: TImage;

rgSelectMode: TRadioGroup;

gbCompress: TGroupBox;

tbQuality: TTrackBar;

pnlStatus: TPanel;

gbDelay: TGroupBox;

tbDelay: TTrackBar;

gbSource: TGroupBox;

dlbSource: TDirectoryListBox;

dcbSource: TDriveComboBox;

pnlImage: TImage;

lblStatusSource: TLabel;

lblStatusTarget: TLabel;

gbTarget: TGroupBox;

dcbTarget: TDriveComboBox;

gbFiles: TGroupBox;

lbFiles: TListBox;

btnStart: TBitBtn;

lblStatusNow: TLabel;

procedure FormCreate(Sender: TObject);

procedure FormPaint(Sender: TObject);

procedure tbQualityChange(Sender: TObject);

procedure tbDelayChange(Sender: TObject);

procedure dcbSourceChange(Sender: TObject);

procedure btnStartClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

Gdip: TGDIPlus = nil;

SourceList: TStringList;

implementation

{$R *.dfm}

procedure FindFiles(FilesList: TStringList; StartDir, FileMask: string);

var

SR: TSearchRec;

DirList: TStringList;

IsFound: Boolean;

i: integer;

begin

if StartDir[length(StartDir)] <> '\' then

StartDir := StartDir + '\';

IsFound := FindFirst(StartDir+FileMask, faAnyFile-faDirectory, SR) = 0;

while IsFound do begin

FilesList.Add(StartDir + SR.Name);

IsFound := FindNext(SR) = 0;

Application.ProcessMessages;

Form1.gbFiles.Caption := ' Files: ' + IntToStr(FilesList.Count) + ' ';

end;

FindClose(SR);

DirList := TStringList.Create;

IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;

while IsFound do begin

if ((SR.Attr and faDirectory) <> 0) and

(SR.Name[1] <> '.') then

DirList.Add(StartDir + SR.Name);

IsFound := FindNext(SR) = 0;

end;

FindClose(SR);

for i := 0 to DirList.Count - 1 do

begin

FindFiles(FilesList, DirList[i], FileMask);

Application.ProcessMessages;

Form1.gbFiles.Caption := ' Files: ' + IntToStr(FilesList.Count) + ' ';

end;

DirList.Free;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Gdip.RegisterPictures;

DoubleBuffered := True;

gbCompress.Caption := ' JPG quality: ' + IntToStr(tbQuality.Position) + ' % ';

gbDelay.Caption := ' Delay: ' + IntToStr(tbDelay.Position) + ' ms ';

end;

procedure TiffToJpg(source, target: string; image: TImage; compress: integer);

var Pic: TSynPicture;

begin

Pic := TSynPicture.Create;

Pic.LoadFromFile(source);

SaveAs(Pic, target, gptJPG, compress);

image.Picture.Graphic := Pic;

Application.ProcessMessages;

Pic.Free;

end;

procedure TForm1.FormPaint(Sender: TObject);

var Row, Ht: Word;

begin

Ht := (ClientHeight + 255) div 256;

for Row := 0 to 255 do

with Canvas do

begin

Brush.Color := RGB(Row, 0, 0);

FillRect(Rect(0, Row * Ht, ClientWidth, (Row + 1) * Ht));

end;

Ht := (pnlImage.Height + 255) div 256;

pnlImage.Canvas.FloodFill(0, 0, clWhite, fsSurface);

for Row := 0 to 70 do

with pnlImage.Canvas do

begin

Brush.Color := RGB(0 , 0, Row * 2);

FillRect(Rect(0, Row * Ht, pnlImage.Width, (Row + 1) * Ht));

end;

pnlImage.Transparent := True;

pnlImage.SendToBack;

end;

procedure TForm1.tbQualityChange(Sender: TObject);

begin

gbCompress.Caption := ' JPG quality: ' + IntToStr(tbQuality.Position) + ' % ';

end;

procedure TForm1.tbDelayChange(Sender: TObject);

begin

gbDelay.Caption := ' Delay: ' + IntToStr(tbDelay.Position) + ' ms ';

end;

procedure TForm1.dcbSourceChange(Sender: TObject);

var dir: string;

begin

lblStatusSource.Caption := dlbSource.Directory;

dir := dlbSource.Directory;

Delete(dir, 1, 1);

lblStatusTarget.Caption := UpCase(dcbTarget.Drive) + dir;

end;

procedure TForm1.btnStartClick(Sender: TObject);

var i: integer;

tifpath, jpgname: string;

begin

lbFiles.Clear;

SourceList := TStringList.Create;

Screen.Cursor := crHourGlass;

FindFiles(SourceList, lblStatusSource.Caption, '*.tif');

Screen.Cursor := crDefault;

for i := 0 to SourceList.Count - 1 do

lbFiles.Items.Append(ExtractFileName(SourceList[i]));

Application.ProcessMessages;

for i := 0 to SourceList.Count - 1 do

begin

Application.ProcessMessages;

tifpath := ExtractFilePath(SourceList.Strings[i]);

tifpath[1] := dcbTarget.Drive;

if not DirectoryExists(tifpath) then ForceDirectories(PChar(tifpath));

if DirectoryExists(tifpath) then

begin

jpgname := ChangeFileExt(SourceList.Strings[i], '.jpg');

jpgname[1] := dcbTarget.Drive;

TiffToJpg(SourceList.Strings[i], jpgname, Form1.imgPrev, tbQuality.Position);

Application.ProcessMessages;

lblStatusNow.Caption := 'From ' + SourceList.Strings[i] + ' to ' + jpgname;

Sleep(tbDelay.Position);

end

else

ShowMessage('New directory add failed error');

end;

imgPrev.Picture := nil;

Application.ProcessMessages;

MessageDlg('End of the conversion !', mtInformation, [mbOk], 0);

end;

end.

Még átnézem és ha van benne szemét kitakarítom. Ez eddig már tudja a könyvtár kiválasztást, konvertálást, másolást, a törlést és a log file mentését még nem írtam bele, de az csak pár sor.

Megérted ?

Basszus, a SourceList.Free; lemaradt

...

MessageDlg('End of the conversion !', mtInformation, [mbOk], 0);

SourceList.Free;

end;