unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls,
ExtCtrls,JPEG;
type
TSkindatei=Record
skSize,skPosition:integer;
skFilename:
String;
skPic:TPicture;
end;
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:
Array of TSkinDatei;
ErrorCode:integer;
// function AddSkindatei(Var DList:TStringList;SkinDatei_:TSkindatei):Boolean;
// function LoadPicture(aFileName:String):Boolean;
Function AddSkindatei(
Var DList_:TStringList;SkinDatei_:TSkindatei):Boolean;
procedure LoadMemory;
procedure FindFiles(
Var DList_:TStringList);
// procedure CreateBackGround(Filename_:String;Skinwidth,Skinheight:integer;Owner_:TWinControl);
procedure CreateBackGround(Dateiindex_:integer;Skinwidth,Skinheight:integer;Owner_:TWinControl);
procedure resetDatas(
Var DList_:TStringList);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
Var
lFile :TMemoryStream;
//Gesamtstream aller Files
pFile :TMemoryStream;
//Stream EinzelFile
AnzSkinDateien:Longint;
Search :Boolean;
SkinPfad:
String;
TestS:
String;
Testi1:integer;
TempJpeg :TBitmap;
Extensions:TStringList;
Imgcnt:integer;
var StrtTick,Tick:Cardinal;
const
FileFilter = '
*.bmp;*.jpg;*.jpeg;*.png;|'+
'
*.bmp;*.jpg;*.jpeg;';
Procedure TForm1.CreateBackGround(Dateiindex_:integer;Skinwidth,Skinheight:integer;Owner_:TWinControl);
Var ex_:
String; TempJpeg:TJpegImage;
L1:integer;
TmpImg:TImage;
begin
with SkinDateien[Dateiindex_]
do
begin
skPic:=TPicture.Create;
try
skPic.RegisterFileFormat('
jpg;*.bmp; *.jpeg;*.bmp','
JPEG',TBitmap);
ex_:=Lowercase(ExtractFileExt(skFilename));
skPic.Bitmap.Width:=SkinWidth;
skPic.Bitmap.Height:=SkinHeight;
if (Ex_ = '
.jpg')
or (Ex_='
jpeg')
then
begin
TempJpeg := TJPEGImage.Create;
lfile.Position:=skPosition;
TempJpeg.LoadFromStream(lFile);
skPic.Bitmap.Assign(TempJpeg);
TempJpeg.Free;
end
else
if (Ex_ = '
.png')
then
begin
{ TempPng := TPNGObject.Create;
TempPng.LoadFromStream(pFile);
Picture.Bitmap.Assign(TempJpeg);
TempPng.Free;
}
end
else
if (Ex_='
.bmp')
then
begin
lfile.Position:=skPosition;
skPic.Bitmap.LoadFromStream(lFile);
end;
except showmessage('
Dateiindex: '+inttostr(Dateiindex_));
end;
end;
end;
procedure TForm1.LoadMemory;
var DList:TStringList;
lCount: Integer;
begin
DList := TStringList.Create;
//Hilfsliste
try
resetDatas(DList);
Search := True;
AnzSkinDateien:=0;
SetLength(SkinDateien,AnzSkinDateien);
FindFiles(DList);
//Dateien finden und in Stringlist
//zu Testzwecken um zu sehen ob bis hier alles klappt:
Memo1.Lines.Assign(DList);
//<---Bremse !!!
finally DList.Free;
end;
end;
Function TForm1.AddSkindatei(
Var DList_:TStringList;SkinDatei_:TSkindatei):Boolean;
Var L1:integer;
begin
//Setlength verbraucht viel zeit deswegen gleich ein paar mehr
while AnzSkinDateien>Length(SkinDateien)-1
do
Setlength(SkinDateien,AnzSkinDateien+100);
Skindateien[AnzSkinDateien]:=SkinDatei_;
inc(AnzSkinDateien);
DList_.Add(SkinDatei_.skFilename);
end;
procedure TForm1.FindFiles(
Var DList_:TStringList);
Var TmpSkinDatei:TSkinDatei;
S:
String;
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 <> '
..')
then
DoSearch(Path + SR.
Name + '
\')
else
if Extensions.IndexOf(ExtractFileExt(SR.
Name)) >= 0
then
with TmpSkinDatei
do
begin
S:=Path + SR.
Name;
pFile.Clear;
pFile.LoadFromFile(S);
skSize:=pFile.Size;
while (Length(SkinDateien)>200)
or (lfile.size>160000000)
do
begin
ErrorCode:=1;
exit;
end;
skPosition:=lFile.Position;
skFilename:=S;
AddSkindatei(DList_,TmpSkinDatei);
pFile.Position := 0;
lFile.CopyFrom(pFile,pFile.Size);
end;
until FindNext(SR) <> 0;
finally
FindClose(SR);
end;
end;
begin
try
Tick := GetTickCount + 100;
AnzSkinDateien:=0;
lFile.Position:=0;
pFile.Position:=0;
resetDatas(DList_);
DOSearch(SkinPfad);
Setlength(SkinDateien,AnzSkinDateien);
//Tatsächliche Länge setzen
except Setlength(SkinDateien,0);
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:='
';
StrtTick:=Gettickcount;
LoadMemory;
//Dateien suchen und in Hauptstream laden
Label1.Caption:=inttostr(Length(SkinDateien))+ '
Bilder';
Label2.Caption:=inttostr(lfile.Size
div 1000000)+'
MB' ;
Label3.Caption:='
in ' +inttostr((Tick-StrtTick)
div 1000 )+'
Sek.' ;
end;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
Var L1,cnt1_:integer;
cnt1: Integer;
begin
L1:=Length(SkinDateien);
StrtTick:=Gettickcount;
imgCnt:=0;
for cnt1 := 0
to L1- 1
do
begin
//Zeitmessung und Antifreeze;
if GetTickCount >= Tick
then
begin
Tick:= GetTickCount +100;
Application.ProcessMessages;
end;
//Alle Bilder in skPic
CreateBackGround(cnt1,100,100,Form1);
//Alle skPic in Image1
with SkinDateien[cnt1]
do
begin
Image1.Picture.Bitmap.Assign(skPic.Bitmap);
inc(imgCnt);
end;
end;
Label4.Caption:= inttostr(imgcnt)+'
Bilder';
showmessage('
Erfolgreich: '+Label4.Caption);
Label5.Caption:='
in ' +inttostr((Tick-StrtTick)
div 1000 )+'
Sek.' ;
end;
procedure TForm1.resetDatas(
Var DList_:TStringList);
begin
DList_.Clear;
Memo1.Clear;
lFile.Clear;
pFile.Clear;
end;
Procedure TForm1.Streamini;
begin
lFile := TMemoryStream.Create();
//Gesamtstream aller Files
pFile := TMemoryStream.Create();
//Stream EinzelFile
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;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ErrorCode:=0;
Streamini;
end;
Procedure TForm1.Streamfree;
begin
Setlength(Skindateien,0);
freeandnil(lFile);
freeandnil(pFile);
freeandnil(Extensions);
end;
procedure TForm1.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Streamfree;
end;
end.