Как рисовать на

← →
Prok12 (2002-12-04 10:38) [0]

Вчера сходный вопрос здесь уже обсуждался...
Проблема в следующем. Предположим, есть главная TForm. "Кладём" на неё компонент TScrollBar, а на него, например, TImage. Пусть размеры последнего заданы, скажем 2000x1200. Тогда на его Canvas"е свободно можно рисовать графические примитивы - линии,окружности, выводить картиники чтением их из файла (Draw, StretchDraw) и т.д. Если размеры TImage заданы больше размеров экрана (или формы) - двигаем картинку с помощью ScrollBar. Всё вроде бы ОК. Но ПОПРОБУЙТЕ задать размеры TImage, скажем, 6000x5000 (точнее - чтобы их произведение стало больше 26млн точек) - и на его Canvas"е не только ничего не нарисовать, но к нему даже не обратиться (например, чтобы проверить его размеры): сразу ошибка типа "Нехватка памяти...", или "Не хватает ресурсов...". Причём от памяти компьютеров это ограничение никак не зависит(Пробовал на разных, сейчас у меня опер.память 512Mb, файл подкачки 4Гб - то же самое ограничение 26млн точек на Canvas). Попробуйте сами- этот пример делать не долго.

Вопрос: как это лечить, и можно ли рисовать на большом Canvas (мне приходится работать с рисованием на сканированных топографических картах циклопических размеров).

← →
icWasya (2002-12-04 12:15) [1]

по умолчанию в TImage создаётся TBitmap у которого PixelFormat=pfDevice. При этом размер ограничен.

попробуй так

procedure TForm1.OnCreate(Sender:TObject); var Bitmap:TBitmap; begin Bitmap:=TBitmap.Create; Bitmap.PixelFormat=pf32Bit; Bitmap.Width:=Image1.Width; Bitmap.Height:=Image1.Height; Image1.Picture.Assign(Bitmap); Bitmap.Free; end;

← →
reonid (2002-12-04 14:06) [2]

Мне кажется, что рисовать на TImage огромного
размера особого смысла не имеет.

Тут, скорее, надо организовывать рисование самому
с возможностью загружать и выгружать из памяти
части изображения.

Я тут очень грубо прикинул, как это в принципе может выглядеть:

{--------------------------------------------------------------}

unit DrwMan;

interface

uses
Windows, Classes, Graphics;

const
ArLen = 100;

type
TCoordConverter = class
procedure LogToScr(LX, LY: Integer; var SX, SY: Integer); virtual; abstract;
procedure ScrToLog(SX, SY: Integer; var LX, LY: Integer); virtual; abstract;
end;

TDrawManager = class
private
FConverter: TCoordConverter;
FCanvas: TCanvas;
FScrViewPort: TRect;
FLogViewPort: TRect;
FFullLogRect: TRect;
public
property LogViewPort: TRect read FLogViewPort write FLogViewPort;
// ...

constructor Create;
destructor Destroy; override;
procedure Init(DestCanvas: TCanvas; AScrVP: TRect; ALogVP: TRect; AFullLogRect: TRect);
function IsRectVisible(ALogRect: TRect): Boolean;
procedure DrawBitmap(ABitmap: TBitmap; ALogDestRect: TRect);
end;

TDMCoordConverter = class(TCoordConverter)
private
FDrawManager: TDrawManager;
public
procedure CalcCoeffs(var DX, DY: Integer; var KX, KY: Double);
procedure LogToScr(LX, LY: Integer; var SX, SY: Integer); override;
procedure ScrToLog(SX, SY: Integer; var LX, LY: Integer); override;

constructor Create(ADrawManager: TDrawManager);
end;

// Карта разбивается на много (или хотя бы несколько) квадратных кусков
TBitmapArray = class
private
FArray: array[0..ArLen-1{??}, 0..ArLen-1{??}] of TBitmap; // или TList, дин. массив
// - внутреннее представление не важно
function GetBmp(I, J: Integer): TBitmap;
function GetBmpFileName(I, J: Integer): string;
procedure LoadBmp(I, J: Integer);
procedure ReleaseUnusedBmp;
public
property Bitmaps[I, J: Integer]: TBitmap read GetBmp;
end;

(*
Рисование подложки будет осужествляться примерно так:
(Рисование осуществлять, например, на PaintBox)

if RoughScale then
DrawManager.DrawBitmap(RoughFullBitmap, FullLogRect)
// в большом масштабе рисуется битмап плохого разрешения
else
for i := 0 to ArLen-1 do
for j := 0 to ArLen-1 do
begin
LogRectIJ := GetLogMapRect(i, j);
if DrawManager.IsVisibleRect(LogRectIJ) then
DrawManager.DrawBitmap(BitmapArray[i, j], LogRectIJ);
// в малом масштабе рисуются только видимые куски,
// а невидимые части просто не будут загружаться в память
// (или будут выгружаться из неё по мере загрузки видимых)
end;

Скроллинг придётся делать вручную - то есть просто сдвигать DrawManager.LogViewPort
Изменить масштаб тоже можно, меняя LogViewPort

Кстати, навигация не обязательно должна осуществляться в виде стандартного
скроллинга - может статься, перерисовка при скроллинге будет слишком тяжёлой.
Тогда лучше ввести специальные навигационные кнопки - чтобы навигация была
дискретной.

*)

implementation

uses
SysUtils;

← →
reonid (2002-12-04 14:06) [3]

{------------------------------ TDrawManager ---------------------------------}

constructor TDrawManager.Create;
begin
inherited;
FConverter := TDMCoordConverter.Create(Self);
end;

destructor TDrawManager.Destroy;
begin
FConverter.Free;
inherited;
end;

function TDrawManager.IsRectVisible(ALogRect: TRect): Boolean;
var IntsRect, ScrRect: TRect;
begin
FConverter.LogToScr(ALogRect.Left, ALogRect.Top, ScrRect.Left, ScrRect.Top);
FConverter.LogToScr(ALogRect.Right, ALogRect.Bottom, ScrRect.Right, ScrRect.Bottom);
Result := IntersectRect(IntsRect, ScrRect, FScrViewPort);
end;

procedure TDrawManager.DrawBitmap(ABitmap: TBitmap; ALogDestRect: TRect);
var ScrDestRect: TRect;
BmpRect, IntsRect: TRect;
begin
FConverter.LogToScr(ALogDestRect.Left, ALogDestRect.Top, ScrDestRect.Left, ScrDestRect.Top);
FConverter.LogToScr(ALogDestRect.Right, ALogDestRect.Bottom, ScrDestRect.Right, ScrDestRect.Bottom);

BmpRect := Rect(0, 0, ABitmap.Width, ABitmap.Height);

if not IntersectRect(IntsRect, ScrDestRect, FScrViewPort) then Exit;

FCanvas.CopyRect(ScrDestRect, ABitmap.Canvas, BmpRect);
end;

procedure TDrawManager.Init(DestCanvas: TCanvas; AScrVP, ALogVP,
AFullLogRect: TRect);
begin
FLogViewPort := ALogVP;
FScrViewPort := AScrVP;
FFullLogRect := AFullLogRect;
FCanvas := DestCanvas;
end;

{--------------------------- TDMCoordConverter --------------------------------}

constructor TDMCoordConverter.Create(ADrawManager: TDrawManager);
begin
FDrawManager := ADrawManager;
end;

procedure TDMCoordConverter.CalcCoeffs(var DX, DY: Integer; var KX, KY: Double);
begin
with FDrawManager do
begin
KX := (FScrViewPort.Right - FScrViewPort.Left)/(FLogViewPort.Right - FLogViewPort.Left);
KY := (FScrViewPort.Bottom - FScrViewPort.Top)/(FLogViewPort.Bottom - FLogViewPort.Top);
DX := Round(FScrViewPort.Left - KX*FLogViewPort.Left);
DY := Round(FScrViewPort.Top - KX*FLogViewPort.Top);
end;
end;

procedure TDMCoordConverter.LogToScr(LX, LY: Integer; var SX, SY: Integer);
var DX, DY: Integer;
KX, KY: Double;
begin
CalcCoeffs(DX, DY, KX, KY);
SX := DX + Round(LX*KX);
SY := DY + Round(LY*KY);
end;

procedure TDMCoordConverter.ScrToLog(SX, SY: Integer; var LX, LY: Integer);
var DX, DY: Integer;
KX, KY: Double;
begin
CalcCoeffs(DX, DY, KX, KY);
LX := Round((SX - DX)/KX);
LY := Round((SY - DY)/KY);
end;

{-------------------------- TBitmapArray --------------------------------------}

function TBitmapArray.GetBmp(I, J: Integer): TBitmap;
begin
if FArray[I, J] = nil then LoadBmp(I, J);
Result := FArray[I, J];
end;

function TBitmapArray.GetBmpFileName(I, J: Integer): string;
begin
Result := Format("img\map%d%d.bmp", [i, j]); // ???
end;

procedure TBitmapArray.LoadBmp(I, J: Integer);
var Bmp: TBitMap;
begin
Bmp := TBitmap.Create;
Bmp.LoadFromFile(GetBmpFileName(I, J));
FArray[I, J] := Bmp;

ReleaseUnusedBmp; // общее число загруженных ограничено - на каждый
// загруженный бмп какой-ибудь другой выгружается из памяти
end;

procedure TBitmapArray.ReleaseUnusedBmp;
begin
//... - нужно вести статистику использования или
// просто брать наиболее дальний невидимый бмп.
end;

end.

Как рисовать на Найти похожие ветки