![]() |
Re: loadfile aus TMemoryStream
Danke schön :-D , ich werde das gleich morgen mal umsetzen und berichten.
Ich wusste ja, das mein Einlesen nicht so doll umgesetzt war. Und schon wieder was dazugelernt. :) Gruß, bluescreen //Edit: in meinerm Source hatte ich beim Einlesen der Filenames direkt in lowercase gesetzt habe und dann auch aFilename auf lowercase abgefragt, da einige Dateien nicht 100% identisch waren beim Vergleich. |
Re: loadfile aus TMemoryStream
ok Projekt eingestellt das wird so nix,der Kot von mir ist Müll
:coder2: |
Re: loadfile aus TMemoryStream
Liste der Anhänge anzeigen (Anzahl: 2)
//EDIT
Delphi-Quellcode:
Man sieht jetzt ganz deutlich 2 Schwachstellen,
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. 1. Wenn viele Unterverzeichnisse dursucht werden müssen und 2. das Anlegen grosser Bilder dauert sehr lange. |
Re: loadfile aus TMemoryStream
Moin,
hier ein Strukturansatz für das Ladeproblem:
Delphi-Quellcode:
Ich würde eine Klasse entwerfen, welche die hier gezeigte Funktionalität kapselt.
unit DemoFrm;
interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TDemoForm = class(TForm) SkinButton: TButton; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private SkinPath: string; SkinList: TStrings; SkinStream: TStream; end; var DemoForm: TDemoForm; implementation {$R *.dfm} uses FileCtrl; const SKIN_EXTENSIONS = '*.jpg;*.bmp'; type TSkinItem = class FOffset: Int64; FSize: Int64; public constructor Create(offset, size: Int64); property Offset: Int64 read FOffSet; property Size: Int64 read FSize; end; constructor TSkinItem.Create(offset, size: Int64); begin inherited Create; FOffset := offset; FSize := size; end; function GetFiles(const dir, masks: string; s: TStrings = nil): Integer; begin with TFileListBox.CreateParented(HWND(HWND_MESSAGE)) do try Mask := masks; Directory := dir; FileType := [ftArchive]; Result := Items.Count; if Assigned(s) then s.Assign(Items); finally Free; end; end; procedure LoadSkins(const SkinPath, Extensions: string; SkinList: TStrings; SkinStream: TStream); var i: Integer; totalSize: Int64; s: TStream; begin totalSize := 0; with SkinList do for i := 0 to Pred(Count) do Objects[i].Free; GetFiles(SkinPath, Extensions, SkinList); with SkinList do for i := 0 to Pred(Count) do begin s := TFileStream.Create(Strings[i], fmOpenRead or fmShareDenyWrite); try Objects[i] := TSkinItem.Create(totalSize, s.Size); SkinStream.CopyFrom(s, 0); Inc(totalSize, s.Size); finally s.Free; end; end; end; procedure TDemoForm.FormCreate(Sender: TObject); begin if (ParamCount = 0) or not FileExists(ParamStr(1)) then GetDir(0, SkinPath) else SkinPath := ParamStr(1); SkinPath := IncludeTrailingPathDelimiter(SkinPath); SkinList := TStringList.Create; SkinStream := TMemoryStream.Create; LoadSkins(SkinPath, SKIN_EXTENSIONS, SkinList, SkinStream); end; procedure TDemoForm.SkinButtonClick(Sender: TObject); begin if SelectDirectory('Select SkinPath', 'C:\', SkinPath) then LoadSkins(SkinPath, SKIN_EXTENSIONS, SkinList, SkinStream); end; end. Freundliche Grüße |
Re: loadfile aus TMemoryStream
Liste der Anhänge anzeigen (Anzahl: 2)
//Edit UpDate V1.31
Mensch bin ich blöd,hab den Wald vor lauter Bäumen nicht gesehen, Nach einigen Test musste ich feststellen,das es ca. 20% schneller ist, wenn man das Image direkt mit dem Filename und nicht über loadfromstream lädt,warum auch immer? :wiejetzt: Versucht es einfach selbst,wenn Ihr es nicht glaubt. Ich hab die Streams in dieser Version rausgeschmissen. Einen Stream sollte man aber verwenden,wenn z.B. die Ini-Datei zu groß werden würde. //Edit Programmabbruch gefixt Es scheint auch ungültige jpeg-dateien zu geben, die halt einen Fehler verursachen können, das sollte aber kein Bug meines Codes sein sondern TPicture rafft das irgendwie nicht. //Edit Die Umwandlung über ein TJPEGImage dauert aber ebenfalls seine Zeit(ca. 20%) und ist für JPEGs nicht mehr nötig, deswegen: weg damit. //Edit Die Megabremse (bei grösseren Bildern !) ist aber ein refresh vom Image nach dem laden. , also habe ich die Application.Prozessmessages begrenzt,und siehe da,Rakete!!!. Wenn Ihr etwas Zeit habt könnt Ihr das prozessmessages einschalten und dann zusehen(nur bei grossen) wie geladen wird Deswegen auch die Unterschiede in der Zeitmessung ,wenn die Form inaktiv ist.
Delphi-Quellcode:
leider ist die Zeitmessung stark davon abhängig,wieviele ungültige Dateien vorhanden sind
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; und ob das Program aktiv oder im Hintergrund läuft. Auf meinem gesamten Laufwerk c: (Bild6) waren es 10,die Zeit,bis die Fehler weggeklick werden wird mitgezählt. (könnte man fast ein Spiel draus machen) |
Re: loadfile aus TMemoryStream
So habe fertig,hoffe es hat geholfen,ich habe jetzt jedenfalls einiges über Streams und Images gelernt.
thx and bye! :coder2: |
Re: loadfile aus TMemoryStream
Liste der Anhänge anzeigen (Anzahl: 1)
Hehe, da soll noch einer meckern !
Das ist mit der exe,also ohne Compilermeldungen :mrgreen: |
Re: loadfile aus TMemoryStream
Liste der Anhänge anzeigen (Anzahl: 1)
Lol,wenn es mehr als 1000 Dateien sind und gleich nach Button1 ,
bzw. der Auswahl der Datei , Button2 gedrückt wird, überholt der loadar sogar den Button1 (Ich schätze mal das Assign/Refresh von Memo1) :shock: |
Re: loadfile aus TMemoryStream
Ich hab jetz mal das Image auf Vollbild gezoomt und muss sagen (ohne Eigenlob)
bei geigneten kleinen Vorlagen ist JurrasicPark nicht mehr weit.//Edit |
Alle Zeitangaben in WEZ +1. Es ist jetzt 01:46 Uhr. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz