Долго бился над проблемой, чтобы добится результата не намного хуже, чем в специализированных программах. Делал почти то же самое, что и nJIaKca.spb и сразу скажу вот что...
| Цитата | | компонент типа TreeView к которому прицеплен ImageList (100x100) |
Тут есть подводные грабли  Попробуй загрузи больше чем 1200 картинок... Что получишь? А ничего хорошего! После 1000-какой-то у тебя добавляться в ImageList ничего не будер  . Решение - убирай ImageList и делай массив битмапок плюс делай собственную прорисовку. Если будут проблемы - могу дать свой код прорисовки. Дальше по сабжу. При генерации предпросмотров для JPEG есть одна хитрость, которую я прочитал как-то, и которая не часто афишируется... Вот функция, которой я обрабатываю на всякий случай загружаемые изображения:
| Код |
procedure JPEGScale(Graphic : TGraphic; Width, Height: Integer);
Var
ScaleX, ScaleY, Scale :Extended;
begin
If (Graphic Is TJpegImage) Then
begin
ScaleX:=Graphic.Width/Width;
ScaleY:=Graphic.Height/Height;
Scale:=Min(ScaleX,ScaleY);
If Scale<2 then
(Graphic As TJpegImage).Scale:=jsFullSize;
If (Scale>=2) and (Scale<4) then
(Graphic As TJpegImage).Scale:=jsHalf;
If (Scale>=4) and (Scale<8) then
(Graphic As TJpegImage).Scale:=jsQuarter;
If Scale>=8 then
(Graphic As TJpegImage).Scale:=jsEighth;
end;
end;
|
При загрузке JPEG файлов теперь времени тратится будет во мнооого раз меньше. С BMP и другими так не проходит 8(. Остальные файлы придётся всё равно грузить сначала полностью, прорисовывать на битмапе и потом уменьшать. В связи с этим вот ешё несколько функций для "качественного уменьшения":
| Код |
procedure StretchCool(Width, Height : integer; var S,D : TBitmap);
var
i, j, h, k, p, w : Integer;
p1 : PARGB;
col, r, g, b, Sheight1, MSh : Integer;
Sh, Sw : Extended;
pk,pp: PInteger;
Xp : array of PARGB;
begin
If Width=0 then exit;
If Height=0 then exit;
S.PixelFormat:=pf24bit;
D.PixelFormat:=pf24bit;
D.Width:=Width;
D.Height:=Height;
Sh:=S.height/height;
Sw:=S.width/width;
Sheight1:=S.height-1;
SetLength(Xp,S.height);
for i:=0 to Sheight1 do
Xp[i]:=s.ScanLine[i];
for i:=0 to Height-1 do
begin
p1:=D.ScanLine[i];
for j:=0 to Width-1 do
begin
col:=0;
r:=0;
g:=0;
b:=0;
for k:=Round(Sh*i) to Min(Round(Sh*(i+1))-1,Sheight1) do
begin
for p:=Round(Sw*j) to Min(Round(Sw*(j+1))-1,S.Width-1) do
begin
inc(col);
inc(r,Xp[k,p].r);
inc(g,Xp[k,p].g);
inc(b,Xp[k,p].b);
end;
end;
if col<>0 then
begin
p1[j].r:=r div col;
p1[j].g:=g div col;
p1[j].b:=b div col;
end;
end;
end;
end;
procedure QuickReduce(NewWidth, NewHeight : integer; BmpIn, BmpOut : TBitmap);
var
x, y, xi1, yi1, xi2, yi2, xx, yy, lw1 : integer;
bufw, bufh, outw, outh : integer;
sumr, sumb, sumg, pixcnt : dword;
adrIn, adrOut, adrLine0, deltaLine, deltaLine2 : DWORD;
begin
BmpOut.Width := NewWidth;
BmpOut.Height := NewHeight;
BmpIn.PixelFormat := pf24bit;
BmpOut.PixelFormat := pf24bit;
bufw := BmpIn.Width;
bufh := BmpIn.Height;
outw := BmpOut.Width;
outh := BmpOut.Height;
adrLine0 := DWORD(bmpIn.ScanLine[0]);
deltaLine := DWORD(BmpIn.ScanLine[1]) - adrLine0;
yi2 := 0;
for y := 0 to outh-1 do
begin
adrOut := DWORD(BmpOut.ScanLine[y]);
yi1 := yi2 {+ 1};
yi2 := ((y+1) * bufh) div outh - 1;
if yi2 > bufh-1 then yi2 := bufh;
xi2 := 0;
for x := 0 to outw-1 do
begin
xi1 := xi2 {+ 1};
xi2 := ((x+1) * bufw) div outw - 1;
if xi2 > bufw-1 then xi2 := bufw-1; //
lw1 := xi2-xi1+1;
deltaLine2 := deltaLine - lw1*3;
sumb := 0;
sumg := 0;
sumr := 0;
adrIn := adrLine0 + yi1*deltaLine + xi1*3;
for yy := yi1 to yi2 do
begin
for xx := 1 to lw1 do
begin
Inc(sumb, PByte(adrIn+0)^);
Inc(sumg, PByte(adrIn+1)^);
Inc(sumr, PByte(adrIn+2)^);
Inc(adrIn, 3);
end;
Inc (adrIn, deltaLine2);
end;
pixcnt := (yi2-yi1+1)*lw1;
if pixcnt<>0 then
begin
PByte(adrOut+0)^ := sumb div pixcnt;
PByte(adrOut+1)^ := sumg div pixcnt;
PByte(adrOut+2)^ := sumr div pixcnt;
end;
Inc(adrOut, 3);
end;
end;
end;
|
Первая хороша при небольших размерах картинки, там лучше происходит уменьшение и по быстродействию она не отличается от второй (при малых картинках, т.е. до 1000х1000). Вторая хороша при большом коэффициенте уменьшения и быстрее на больших картинках (при маленьких происходит значительное размытие конечной картинки). Поэтому в конце концов я это использовал практически так:
| Код |
Procedure QuickReduceWide(Width, Height : integer; Var S,D : TBitmap);
begin
if S.Width div Width>=8 then
QuickReduce(Width,Height,S,D) else
StretchCool(Width,Height,S,D)
end;
|
Прошу ваши комментарии и поправки.
Добавлено @ 12:36
Да:
| Код |
Type
ARGB=array [0..1] of TRGB;
PARGB=^ARGB;
|
|
(правда сам файл под 200 Метров весит и открыается жутко долго, но все же.
.