Масштаб изображения

← →
V-A-V © (2006-11-13 10:43) [0]

Есть TImage, в него загружен некий рисунок.
Вопрос как, можно дать пользователю возможность увеличивать и уменьшать рисунок на экране.
Может кто даст пример кода или ссылку где это подсмотреть...

← →
KilkennyCat © (2006-11-13 10:45) [1]

StretchDraw или DrawStretch, не помню порядок...

← →
Percent (2006-11-13 10:48) [2]

Image.Stretch := true;

И, в ответ на действия пользователя мышью, изменять размеры.

← →
V-A-V © (2006-11-13 10:50) [3]

> StretchDraw или DrawStretch

да че-то нет таких методов у TImage...

← →
V-A-V © (2006-11-13 10:53) [4]

>Image.Stretch := true;
>И, в ответ на действия пользователя мышью, изменять размеры.

и каже, если не секрет эти размеры изменять...

Мне надо так, чтобы пользователь мог увеличить рисунок так, чтобы рассмотреть в нем мелкие детали...

← →
YOjik (2006-11-13 11:08) [5]

1)
procedure SetCanvasZoomFactor(Canvas: TCanvas; AZoomFactor: Integer);
var
i: Integer;
begin
if AZoomFactor = 100 then
SetMapMode(Canvas.Handle, MM_TEXT)
else
begin
SetMapMode(Canvas.Handle, MM_ISOTROPIC);
SetWindowExtEx(Canvas.Handle, AZoomFactor, AZoomFactor, nil);
SetViewportExtEx(Canvas.Handle, 100, 100, nil);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
bitmap: TBitmap;
begin
bitmap := TBitmap.Create;
try
bitmap.Assign(Form1.image1.Picture.Bitmap);
SetCanvasZoomFactor(bitmap.Canvas, 70);
Canvas.Draw(30, 30, bitmap);
finally
bitmap.Free
end;
end;
2)
Этот алгоритм увеличивает изображение в произвольное количество раз при помощи билинейной интерполяции. При создании нового изображения каждой его точке с целыми координатами (x,y) сопоставляется точка исходного изображения с дробными координатами (xo, yo), xo=x/dx, yo=y/dy (dx и dy – коэффициенты увеличения). Далее нужно провести поверхность через точки, лежащие вокруг (xo, yo). Цвет здесь рассматривается как третье измерение. На поверхности ищется точка с координатами (xo, yo) и ее цвет понимается за цвет точки (x,y) получаемого изображения.

Этот алгоритм хорошо работает при целых или больших коэффициентах увеличения. Но резкие границы размываются. Для уменьшения изображения этот алгоритм также не подходит.

procedure Interpolate(var bm: TBitMap; dx, dy: single);
var
bm1: TBitMap;
z1, z2: single;
k, k1, k2: single;
x1, y1: integer;
c: array [0..1, 0..1, 0..2] of byte;
res: array [0..2] of byte;
x, y: integer;
xp, yp: integer;
xo, yo: integer;
col: integer;
pix: TColor;
begin
bm1 := TBitMap.Create;
bm1.Width := round(bm.Width * dx);
bm1.Height := round(bm.Height * dy);
for y := 0 to bm1.Height - 1 do
begin
for x := 0 to bm1.Width - 1 do
begin
xo := trunc(x / dx);
yo := trunc(y / dy);
x1 := round(xo * dx);
y1 := round(yo * dy);

for yp := 0 to 1 do
for xp := 0 to 1 do
begin
pix := bm.Canvas.Pixels[xo + xp, yo + yp];
c[xp, yp, 0] := GetRValue(pix);
c[xp, yp, 1] := GetGValue(pix);
c[xp, yp, 2] := GetBValue(pix);
end;

for col := 0 to 2 do
begin
k1 := (c[1,0,col] - c[0,0,col]) / dx;
z1 := x * k1 + c[0,0,col] - x1 * k1;
k2 := (c[1,1,col] - c[0,1,col]) / dx;
z2 := x * k2 + c[0,1,col] - x1 * k2;
k := (z2 - z1) / dy;
res[col] := round(y * k + z1 - y1 * k);
end;
bm1.Canvas.Pixels[x,y] := RGB(res[0], res[1], res[2]);
end;
Form1.Caption := IntToStr(round(100 * y / bm1.Height)) + "%";
Application.ProcessMessages;
if Application.Terminated then
Exit;
end;
bm := bm1;
end;

const
dx = 5.5;
dy = 5.5;

procedure TForm1.Button1Click(Sender: TObject);
const
w = 50;
h = 50;
var
bm: TBitMap;
can: TCanvas;
begin
bm := TBitMap.Create;
can := TCanvas.Create;
can.Handle := GetDC(0);
bm.Width := w;
bm.Height := h;
bm.Canvas.CopyRect(Bounds(0, 0, w, h), can, Bounds(0, 0, w, h));
ReleaseDC(0, can.Handle);
Interpolate(bm, dx, dy);
Form1.Canvas.Draw(0, 0, bm);
Form1.Caption := "x: " + FloatToStr(dx) +
" y: " + FloatToStr(dy) +
" width: " + IntToStr(w) +
" height: " + IntToStr(h);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
bm: TBitMap;
begin
if OpenDialog1.Execute then
bm.LoadFromFile(OpenDialog1.FileName);
Interpolate(bm, dx, dy);
Form1.Canvas.Draw(0, 0, bm);
Form1.Caption := "x: " + FloatToStr(dx) +
" y: " + FloatToStr(dy) +
" width: " + IntToStr(bm.Width) +
" height: " + IntToStr(bm.Height);
end;

← →
YOjik (2006-11-13 11:10) [6]

procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect);
//scanline implementation of Stretchblt/Delete_Scans
//about twice as fast
//Stretches Src to Dest, rs is source rect, rd is dest. rect
//The stretch is centered, i.e the center of rs is mapped to the center of rd.
//Src, Dest are assumed to be bottom up

implementation

uses Classes, math;

type
TRGBArray = array[0..64000] of TRGBTriple;
PRGBArray = ^TRGBArray;

TQuadArray = array[0..64000] of TRGBQuad;
PQuadArray = ^TQuadArray;

procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect);
var
xsteps, ysteps: array of Integer;
intscale: Integer;
i, x, y, x1, x2, bitspp, bytespp: Integer;
ts, td: PByte;
bs, bd, WS, hs, w, h: Integer;
Rows, rowd: PByte;
j, c: Integer;
pf: TPixelFormat;
xshift, yshift: Integer;
begin
WS := rs.Right - rs.Left;
hs := rs.Bottom - rs.Top;
w := rd.Right - rd.Left;
h := rd.Bottom - rd.Top;
pf := Src.PixelFormat;
if (pf <> pf32Bit) and (pf <> pf24bit) then
begin
pf := pf24bit;
Src.PixelFormat := pf;
end;
Dest.PixelFormat := pf;
if not (((w <= WS) and (h <= hs)) or ((w >= WS) and (h >= hs))) then
//we do not handle a mix of up-and downscaling,
//using threadsafe StretchBlt instead.
begin
Src.Canvas.Lock;
Dest.Canvas.Lock;
try
SetStretchBltMode(Dest.Canvas.Handle, STRETCH_DELETESCANS);
StretchBlt(Dest.Canvas.Handle, rd.Left, rd.Top, w, h,
Src.Canvas.Handle, rs.Left, rs.Top, WS, hs, SRCCopy);
finally
Dest.Canvas.Unlock;
Src.Canvas.Unlock;
end;
Exit;
end;

if pf = pf24bit then
begin
bitspp := 24;
bytespp := 3;
end
else
begin
bitspp := 32;
bytespp := 4;
end;
bs := (Src.Width * bitspp + 31) and not 31;
bs := bs div 8; //BytesPerScanline Source
bd := (Dest.Width * bitspp + 31) and not 31;
bd := bd div 8; //BytesPerScanline Dest
if w < WS then //downsample
begin
//first make arrays of the skipsteps
SetLength(xsteps, w);
SetLength(ysteps, h);
intscale := round(WS / w * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to w - 1 do
begin
xsteps[i] := (x2 - x1) * bytespp;
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if i = w - 2 then
c := x1;
end;
xshift := min(max((WS - c) div 2, - rs.Left), Src.Width - rs.Right);
intscale := round(hs / h * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to h - 1 do
begin
ysteps[i] := (x2 - x1) * bs;
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if i = h - 2 then
c := x1;
end;
yshift := min(max((hs - c) div 2, - rs.Top), Src.Height - rs.Bottom);
if pf = pf24bit then
begin
Rows := @PRGBArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift];
rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to h - 1 do
begin
ts := Rows;
td := rowd;
for x := 0 to w - 1 do
begin
pRGBTriple(td)^ := pRGBTriple(ts)^;
Inc(td, bytespp);
Inc(ts, xsteps[x]);
end;
Dec(rowd, bd);
Dec(Rows, ysteps[y]);
end;
end
else
begin
Rows := @PQuadArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift];
rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to h - 1 do
begin
ts := Rows;
td := rowd;
for x := 0 to w - 1 do
begin
pRGBQuad(td)^ := pRGBQuad(ts)^;
Inc(td, bytespp);
Inc(ts, xsteps[x]);
end;
Dec(rowd, bd);
Dec(Rows, ysteps[y]);
end;
end;
end
else
begin
//first make arrays of the steps of uniform pixels
SetLength(xsteps, WS);
SetLength(ysteps, hs);
intscale := round(w / WS * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to WS - 1 do
begin
xsteps[i] := x2 - x1;
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if x2 > w then
x2 := w;
if i = WS - 1 then
c := x1;
end;
if c < w then //>is now not possible
begin
xshift := (w - c) div 2;
yshift := w - c - xshift;
xsteps[WS - 1] := xsteps[WS - 1] + xshift;
xsteps[0] := xsteps[0] + yshift;
end;
intscale := round(h / hs * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to hs - 1 do
begin
ysteps[i] := (x2 - x1);
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if x2 > h then
x2 := h;
if i = hs - 1 then
c := x1;
end;
if c < h then
begin
yshift := (h - c) div 2;
ysteps[hs - 1] := ysteps[hs - 1] + yshift;
yshift := h - c - yshift;
ysteps[0] := ysteps[0] + yshift;
end;
if pf = pf24bit then
begin
Rows := @PRGBArray(Src.Scanline[rs.Top])^[rs.Left];
rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to hs - 1 do
begin
for j := 1 to ysteps[y] do
begin
ts := Rows;
td := rowd;
for x := 0 to WS - 1 do
begin
for i := 1 to xsteps[x] do
begin
pRGBTriple(td)^ := pRGBTriple(ts)^;
Inc(td, bytespp);
end;
Inc(ts, bytespp);
end;
Dec(rowd, bd);
end;
Dec(Rows, bs);
end;
end
else
begin
Rows := @PQuadArray(Src.Scanline[rs.Top])^[rs.Left];
rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to hs - 1 do
begin
for j := 1 to ysteps[y] do
begin
ts := Rows;
td := rowd;
for x := 0 to WS - 1 do
begin
for i := 1 to xsteps[x] do
begin
pRGBQuad(td)^ := pRGBQuad(ts)^;
Inc(td, bytespp);
end;
Inc(ts, bytespp);
end;
Dec(rowd, bd);
end;
Dec(Rows, bs);
end;
end;
end;
end;

end.

← →
KilkennyCat © (2006-11-13 11:30) [7]

и это позволит рассмотреть мелкие детали? :)))

← →
ANB © (2006-11-13 11:42) [8]

> V-A-V © (13.11.06 10:43)

Самый тупорылый способ, практически без кодирования.
1. Кидаешь на форму ScrollBox
2. На бокс кидаешь Image.
3. Грузишь в Image картинку
4. Подгоняешь размер Image под размер картинки, в результате имеешь изображение 1:1
5. Включаешь растягивание изображения в Image (можно заранее, если размеры картинки и имаджа совпадают - картинка не портится)
6. При увеличении/уменьшении масштаба (можно повесить кнопочки) меняешь размеры имаджа, можно заодно его и двигать на скроллбоксе, чтобы координаты просматриваемого места сохранялись.
В результате у тебя изображение меняет масштаб отображения, при этом собственно картинка преобразованию не подвергается (и не портится).

> 4. Подгоняешь размер Image под размер картинки, в результате
> имеешь изображение 1:1

не факт.

> KilkennyCat (13.11.2006 11:43:09) [9]

А что факт?

Масштаб изображения Найти похожие ветки