unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls,
ExtCtrls,JPEG,ClipBrd;
type
PSkinDateien=^TStringList;
TForm1 =
class(TForm)
{ Button1: TButton;
Memo1: TMemo;
Label1: TLabel;
OpenDialog1: TOpenDialog;
Button2: TButton;
Label2: TLabel;
Image1: TImage;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;}
procedure Button2Click(Sender: TObject);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
Procedure Streamini;
Procedure Streamfree;
{ Private declarations }
public
SkinDateien:TStringList;
SkinDateienP:PSkinDateien;
SkinListe: TList;
ErrorCode:integer;
procedure LoadMemory;
procedure FindFiles(
Var DList_:TStringList);
procedure resetDatas(
Var DList_:TStringList);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
Var
AnzSkinDateien:Longint;
Search :Boolean;
SkinPfad:
String;
Extensions:TStringList;
Imgcnt:integer;
SizeofAll:int64;
StrtTick,Tick:Cardinal;
const
FileFilter = '
*.bmp;*.jpg;*.jpeg;*.png;|'+
'
*.bmp;*.jpg;*.jpeg;';
procedure TForm1.LoadMemory;
begin
try
Search := True;
AnzSkinDateien:=0;
if (SkinDateien=nil)
then
SkinDateien:=TStringlist.Create;
SkinDateien.Clear;
FindFiles(SkinDateien);
//zu Testzwecken um zu sehen ob bis hier alles klappt:
Memo1.Lines.Assign(SkinDateien);
//<---Bremse !!!
except SkinDateien.Free;
end;
end;
//Diese super Function und Teile dieses Codes sind von anderen Usern ,
//z.B. bluescreen25, der diesen Thread begonnen hat,
//,bitte meldet Euch,wenn ihr erwähnt werden wollt.
function MyGetFileSize(
const FileName:
String):int64;
var FileHandle: Cardinal;
var Data: WIN32_FIND_DATA;
begin
FileHandle := FindFirstFile(PChar(FileName), Data);
try
if FileHandle > 0
then
begin
Int64Rec(Result).Hi := Data.nFileSizeHigh;
Int64Rec(Result).Lo := Data.nFileSizeLow;
end;
finally Windows.FindClose(FileHandle);
end;
end;
procedure TForm1.FindFiles(
Var DList_:TStringList);
Var
S:
String;
FS:int64;
procedure DoSearch(
const Path:
String);
var SR : TSearchRec;
begin
If Findfirst(Path + '
*.*',faAnyFile,SR) = 0
then
try
repeat
if GetTickCount >= Tick
then
begin
Tick:= GetTickCount +100;
Application.ProcessMessages;
end;
If (SR.Attr
and faDirectory <> 0)
and (SR.
Name <> '
.')
and (SR.
Name <> '
..')
and (SR.
Name <> '
')
then
DoSearch(Path + SR.
Name + '
\')
else
if Extensions.IndexOf(ExtractFileExt(SR.
Name)) >= 0
then //Bug: nur jpeg-Dateien gefixt
begin
S:=Path + SR.
Name;
FS:=MyGetFileSize(S);
//Provisorisch Speicherüberlauf verhindern
while (SizeofAll+FS>200000000)
do
begin
ErrorCode:=1;
exit;
end;
SizeofAll:=SizeofAll+FS;
//In Liste aufnehmen
SkinDateienP^.Add(S);
//DList_.Add(S);
end;
until FindNext(SR) <> 0;
finally
FindClose(SR);
end;
end;
begin
try
Tick := GetTickCount + 100;
DOSearch(SkinPfad);
except DList_.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
Var Filename_:
String;
cnt1,L1:integer;
begin with Opendialog1
do
begin
Filter:=FileFilter;
if execute
then
begin
Filename_:=Filename;
SkinPfad:= extractfilepath(Filename_);
Label1.Caption:='
';
SizeofAll:=0;
StrtTick:=Gettickcount;
LoadMemory;
//Dateien suchen und in Stringliste laden
Label1.Caption:=inttostr(SkinDateien.Count)+ '
Dateinamen';
Label2.Caption:=inttostr(SizeofAll
div 1000000)+'
MB' ;
Label3.Caption:='
in ' +inttostr((Gettickcount-StrtTick)
div 1000 )+'
Sek.' ;
end;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
Var L1,cnt1_:integer;
cnt1: Integer;
FN_:
String;
begin
L1:=SkinDateienP^.Count;
StrtTick:=Gettickcount;
imgCnt:=0;
for cnt1 := 0
to L1- 1
do
begin
//Antifreeze;
if GetTickCount >= Tick
then
begin
Tick:= GetTickCount +10;
//hier kann man rumspielen,wenn's einem zu langsam, oder zu schnell geht
//MEGABREMSE
Application.ProcessMessages;
end;
//Alle Pics in Image1 oder wahlweise nur bestimmte
try
if Fileexists(SkinDateien[cnt1])
then
Image1.Picture.LoadFromFile(SkinDateien[cnt1]);
inc(imgCnt);
//Update V1.31
except;
end;
end;
Label4.Caption:= inttostr(imgcnt)+'
Bilder';
showmessage('
Erfolgreich: '+Label4.Caption);
Label5.Caption:='
in ' +inttostr((Gettickcount-StrtTick)
div 1000 )+'
Sek.' ;
end;
procedure TForm1.resetDatas(
Var DList_:TStringList);
begin
DList_.Clear;
Memo1.Clear;
end;
Procedure TForm1.Streamini;
begin
Image1.Stretch:=True;
//EDIT
SkinPfad:='
C:\Windows\';
Extensions:=TStringList.Create;
with Extensions
do
try
Add('
.bmp');
Add('
.jpg');
Add('
.jpeg');
// Add('.png');
except Extensions.Free;
end;
with Memo1
do
begin
Clear;
Align:=alRight;
ScrollBars:=ssBoth;
end;
//Pointer
GetMem(SkinDateienP, SizeOf(TStringlist));
SkinDateienP^ := TStringList.Create;
SkinDateien:=TStringList.Create;
SkinDateienP^:=SkinDateien;
SkinListe:=TList.Create;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ErrorCode:=0;
Streamini;
end;
Procedure TForm1.Streamfree;
begin
SkinDateien.Free;
freeandnil(Extensions);
end;
procedure TForm1.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Streamfree;
end;