Entwickler-Ecke
Sonstiges (Delphi) - Farbwerte aller Pixel eines Bildes in einem String speichern
pmw - So 29.12.02 12:36
Titel: Farbwerte aller Pixel eines Bildes in einem String speichern
Hallo!
Ich möchte gerne alle Farbwerte aller Pixel eines Bildes in einem String speichern. Mein kleines Programm funkoniert auch, braucht aber leider für ein normales Bitmap (512x384 Pixel) mehrere Minuten! Kann ich die Farbwerte irgendwie schneller auslesen?
Quelltext
1:
2:
3:
4:
| for x := 0 to Image.Width-1 do begin
for y := 0 to Image.Height-1 do
sFileString := sFileString+Copy(ColorToString(Image.Canvas.Pixels[x,y]),4,6);
end; |
Viele Grüße
Martin Winandy
Anonymous - So 29.12.02 13:55
Mit ScanLine
pmw - So 29.12.02 14:11
Wie funktoniert dies?
pmw - So 29.12.02 18:59
Hallo!
Danke! Mein neues Programm ist jetzt deutlich schneller. Aber 5 Sekunden empfinde ich immer noch als zu langsam. Gibt es eine Möglichkeit dern Algorithmus noch ein wenig zu beschleunigen. Ich bräuchte eine Geschwindigkeit < 1 Sekunde.
Viele Grüße
Martin Winandy
Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
| procedure TForm1.EncodeClick(Sender: TObject);
type
PixArray = Array [1..3] of Byte;
var
p: ^PixArray;
x,y: integer;
begin
for y := 0 to Image.Height-1 do begin
p:= Image.Picture.Bitmap.ScanLine[y];
for x := 0 to Image.Width-1 do begin
sFileString := sFileString+Char(p^[1])+Char(p^[2])+Char(p^[3]);
Inc(p);
end;
end;
end; |
AXMD - Mo 30.12.02 14:19
Hi,
Soweit ich weiß, gibts nichts schnelleres als ScanLine
AXMD
Anonymous - Mo 30.12.02 14:47
Ich kann mir nicht vorstellen, daß es 5 Sekunden dauert. Wenn ich ohne ScanLine arbeite, dann dauert es nicht mal 5 Sekunden.
Udontknow - Mo 30.12.02 14:53
Dann setze dich doch mal an eine Maschine, die weniger als 3 GHz hat... :wink:
Ne im Ernst: Was habt ihr denn für Rechner?
Cu,
Udontknow
pmw - Mo 30.12.02 15:03
Hallo!
Ich besitze einen Pentium III mit 1GHz und 128MB SD-Ram (PC 133).
Viele Grüße
Martin Winandy
Anonymous - Mo 30.12.02 15:05
Das Problem durfte nicht ScanLine sein, sondern etwas anderes. Im Grunde genommen sind das nur noch zwei for-Schleifen. Die kosten doch keine Zeit.
Sowas kostet aber Zeit:
Quelltext
1:
| String := String + Char; |
Hier muß die Größe des Strings einige Tausend mal neu bestimmt werden. Das könnte die 5 Sekunden dauern.
Am besten ein String von der größe (Height-1 + Width-1) * 3 erstellen und dann nur noch mit String[x] arbeiten.
pmw - Mo 30.12.02 15:12
Hallo!
| Zitat: |
| Am besten ein String von der größe (Height-1 + Width-1) * 3 erstellen und dann nur noch mit String[x] arbeiten. |
Wie mache ich das ohne Schleifen?
Ich habe noch ein Problem: Ich kann die Procedure "EncodeClick" immer nur ein Mal durchlaufen lassen. Beim 2. AUfruf der Procedure reagiert das Programm nicht mehr. Es kommt aber keine Fehlermeldung.
Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
| var
Form1: TForm1;
sFileString: AnsiString;
implementation
{$R *.dfm}
function SaveStringToFile(sOutFile: String; sFileString: AnsiString): Boolean;
var
FileStream: TFileStream;
begin
Result := False;
FileStream := TFileStream.Create(sOutFile, fmCreate);
try
if Length(sFileString) <> 0 then begin
FileStream.Write(sFileString[1], Length(sFileString));
Result := True;
end;
finally FileStream.Free end;
end;
procedure TForm1.EncodeClick(Sender: TObject);
type
PixArray = Array [1..3] of Byte;
var
p: ^PixArray;
x,y: integer;
pic: TBitmap;
begin
pic := TBitmap.Create;
pic.LoadFromFile(bmp.Text);
pic.PixelFormat:= pf24Bit;
for y := 0 to pic.Height-1 do begin
p := pic.ScanLine[y];
for x := 0 to pic.Width-1 do begin
sFileString := sFileString+Char(p^[1])+Char(p^[2])+Char(p^[3]);
Inc(p);
end;
end;
try DeleteFile(spf.Text); except end;
SaveStringToFile(spf.Text,sFileString);
pic.Free;
end; |
Anonymous - Mo 30.12.02 17:06
Um die Länge des Strings festzulegen nimmst du:
SetLength(var S: string; NewLength: Integer);
Dannach ist der S String so lang wie in NewLength festgelegt. Du hast dann eine Art Stream.
pmw - Mo 30.12.02 18:18
Hallo!
Leider bringt dies auch keinen Geschwindikkeitsvorteil.Bis zur Fertig-Meldung sind es immer noch 5 Sekunden.
Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
| procedure TForm1.EncodeClick(Sender: TObject);
type
PixArray = Array [1..3] of Byte;
var
p: ^PixArray;
x,y: integer;
pic: TBitmap;
begin
pic := TBitmap.Create;
pic.LoadFromFile(bmp.Text);
pic.PixelFormat:= pf24Bit;
SetLength(sFileString,(pic.Height+pic.Width)*3);
ShowMessage('START!');
for y := 0 to pic.Height-1 do begin
p := pic.ScanLine[y];
for x := 0 to pic.Width-1 do begin
sFileString := sFileString+Char(p^[1])+Char(p^[2])+Char(p^[3]);
Inc(p);
end;
end;
ShowMessage('FERTIG!');
try DeleteFile(spf.Text); except end;
SaveStringToFile(spf.Text,sFileString);
pic.Free;
end; |
AndyB - Mo 30.12.02 23:10
Du hast ja nicht genau das gemacht, was Popov gemeint hat. Du baust den String immer noch mit + zusammen.
Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
| procedure TForm1.EncodeClick(Sender: TObject);
var
p: PByte;
x, y, i: Integer;
Pic: TBitmap;
Stream: TFileStream;
sFileString: string;
Width, Height: Integer;
ByteTable: array[0..255] of string[2];
F: PChar;
begin
// "Nachschau" Tabelle anlegen
for i := 0 to 255 do ByteTable[i] := IntToHex(i, 2);
Pic := TBitmap.Create;
try
Pic.LoadFromFile('c:\Test.bmp');
Pic.PixelFormat := pf24Bit;
Width := Pic.Width;
Height := Pic.Height;
{ genug Speicher reservieren: 3 Farbwerte mit je 2 Zeichen }
SetLength(sFileString, Height * Width * 3 * 2);
ShowMessage('START!');
F := PChar(sFileString);
for y := 0 to Height - 1 do
begin
p := Pic.ScanLine[y];
for x := 0 to (Width * 3) - 1 do
begin
PWord(F)^ := PWord(@ByteTable[p^][1])^;
{ ein wenig schneller als:
F[0] := ByteTable[p^][1];
F[1] := ByteTable[p^][2]; }
Inc(F, 2);
Inc(p);
end;
end;
finally
Pic.Free;
end;
ShowMessage('FERTIG!');
Stream := TFileStream.Create('C:\Test.txt', fmCreate);
try
if Length(sFileString) > 0 then
Stream.Write(sFileString[1], Length(sFileString));
finally
Stream.Free;
end;
end; |
Der Code brauch bei mir (650 MHz) 79 Millisekunden für ein 1024x768x24 Bild.
pmw - Di 31.12.02 12:01
Hallo!
Danke für den Quellcode. Der Ist wirklich schnell! Leider verstehe ich den nicht ganz richtig und es kommt auch nicht ganz das gewünschte Ergebnis raus.
Der Code braucht für jeden Farbwert 2 Bytes (30 45 30 41 30 35). Ich wollte aber jeden Farbwert in einen Byte (0E 0A 05) speichern.
Viele Grüße
Martin Winandy
pmw - Di 31.12.02 12:10
Hallo!
Ich habe jetzt die Lösung gefunden!
Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
| procedure TForm1.EncodeClick(Sender: TObject);
var
p: PByte;
x, y: Integer;
Pic: TBitmap;
sFileString: string;
F: PChar;
begin
Pic := TBitmap.Create;
try
Pic.LoadFromFile(bmp.Text);
Pic.PixelFormat := pf24Bit;
SetLength(sFileString, Pic.Height * Pic.Width * 3);
F := PChar(sFileString);
for y := 0 to Pic.Height - 1 do begin
p := Pic.ScanLine[y];
for x := 0 to (Width * 3) - 1 do begin
F^ := Char(p^);
Inc(F);
Inc(p);
end;
end;
finally
Pic.Free;
end;
try DeleteFile(spf.Text); except end;
SaveStringToFile(spf.Text,sFileString);
end; |
Vielen Dank an alle, die mir geholfen haben und ich wünsche eine guten Rutsch ins Jahr 2003!
Martin Winandy
pmw - Di 31.12.02 12:17
Hallo!
Ich sehe gerade, dass mein Quellcode doch nicht stimmt. Ab dem 576.000 Byte werde nur noch Nullen ausgegeben. Woran kann das liegen?
AndyB - Di 31.12.02 12:28
| pmw hat folgendes geschrieben: |
| Der Code braucht für jeden Farbwert 2 Bytes (30 45 30 41 30 35). Ich wollte aber jeden Farbwert in einen Byte (0E 0A 05) speichern. |
Also wenn du pro Pixel 3 Bytes (RGB = 3 * 1 Byte) verwenden willst, dann kann ich dir einen um einiges schnelleren Code geben:
Quelltext
1:
2:
3:
4:
5:
6:
| SetLength(sFileString, Pic.Height * Pic.Width * 3);
for y := 0 to Height - 1 do
begin
p := Pic.ScanLine[y];
Move(p^, sFileString[y * (Width * 3) + 1], Width * 3);
end; |
Mein Code (2 Bytes pro Farbwert) wandelt die Bytes in Hexadezimal-Strings um und schreibt diese dann in die Datei. Das was du da willst (1 Byte pro Farbwert) ist nichts anderes, als die Daten 1:1 kopieren.
pmw - Di 31.12.02 13:53
Hallo!
Danke! Jetzt funktioniert alles wies es soll! Dafür arbeitet aber meine DLL nicht mehr richtig mit dem String zusammen. Ich bekomme immer eine Fehlermeldung "External Error 80003".
Programm - Form1:
Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
| unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Spin;
type
TForm1 = class(TForm)
bmp: TEdit;
Label1: TLabel;
spf: TEdit;
Label2: TLabel;
Encode: TButton;
Label3: TLabel;
concolor: TComboBox;
Label4: TLabel;
filesize: TSpinEdit;
Button1: TButton;
procedure EncodeClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function convert(const filesize, color, pixelx,pixely: integer; picture: AnsiString): AnsiString; stdcall; external 'spf_en.dll';
function SaveStringToFile(sOutFile: String; sFileString: AnsiString): Boolean;
var
FileStream: TFileStream;
begin
Result := False;
FileStream := TFileStream.Create(sOutFile, fmCreate);
try
if Length(sFileString) <> 0 then begin
FileStream.Write(sFileString[1], Length(sFileString));
Result := True;
end;
finally FileStream.Free end;
end;
procedure TForm1.EncodeClick(Sender: TObject);
var
p: PByte;
y: Integer;
pic: TBitmap;
input, output: AnsiString;
begin
pic := TBitmap.Create;
try
Pic.LoadFromFile(bmp.Text);
Pic.PixelFormat := pf24Bit;
SetLength(input,pic.Height*pic.Width*3);
for y := 0 to pic.Height-1 do begin
p := pic.ScanLine[y];
Move(p^,input[y*(pic.Width*3)+1],pic.Width*3);
end;
finally pic.Free; end;
output := input;
output := convert(filesize.Value,concolor.ItemIndex,pic.Width,pic.Height,output); // Fehlermeldung!
try DeleteFile(spf.Text); except end;
SaveStringToFile(spf.Text,output);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(convert(0,0,30,55,'Hallo!')); // Funktioniert einwandfrei!
end;
end. |
DLL:
Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
| library spf_en;
uses
ShareMem, Dialogs, SysUtils, Classes;
{$R *.res}
function convert(const filesize, color, pixelx,pixely: integer; picture: AnsiString): AnsiString; stdcall;
var
header: String;
begin
result := picture;
end;
exports
convert;
begin
end. |
Viele Grüße
Martin Winandy
AndyB - Di 31.12.02 17:43
Hast du ShareMem auch in Hauptprogramm (.dpr-Datei) als erste Unit eingebunden?
pmw - Di 31.12.02 19:21
Hallo!
Ja, klar! Sonst würde die 2. Procedure ja auch nicht funktionieren, oder?
Programm:
Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
| program Encoder;
uses
ShareMem,
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end. |
DLL:
Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
| library spf_en;
uses
ShareMem, Dialogs, SysUtils, Classes;
{$R *.res}
( ... ) |
AndyB - Mi 01.01.03 14:58
Das es nicht funktioniert liegt daran, dass du Pic bereits freigegeben hast, und dann noch auf dessen Eigenschaften Width und Height zugreifst.
| Zitat: |
finally
pic.Free;
end;
output := input;
output := convert(filesize.Value,concolor.ItemIndex,pic.Width,pic.Height,output); // Fehlermeldung! |
Entwickler-Ecke.de based on phpBB
Copyright 2002 - 2011 by Tino Teuber, Copyright 2011 - 2026 by Christian Stelzmann Alle Rechte vorbehalten.
Alle Beiträge stammen von dritten Personen und dürfen geltendes Recht nicht verletzen.
Entwickler-Ecke und die zugehörigen Webseiten distanzieren sich ausdrücklich von Fremdinhalten jeglicher Art!