Форум: "Начинающим";
Текущий архив: 2013.09.29;
Скачать: [xml.tar.bz2];
ВнизПомогите ускорить скорость перемещения "курсора". Найти похожие ветки
← →
yaproq (2013-01-14 08:36) [0]Нужно было сделать таблицу, как лист Excel, где есть возможность объединить ячейки, задавать формат отдельных ячеек. Так как еще не умею создавать компоненты, решил так. Динамически создаю двумерный массив компонентов TLabel и программно управляю их поведением и т.д. В качестве курсора пользуюсь компонентом TShape. В обработчике KeyDown формы перемещаю "курсор". Но скорость перемещения (перерисовки?) очень медленная по сравнении со скоростью того же курсора из Excel.
Посоветуйте, пожалуйста, как можно ускорить скорость перемещения (перерисовки) этого "курсора"?
Ниже упрошенный пример моего решения. Его нужно просто вставить в модуль пустого проекта.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
lbl = array of array of TLabel;
TForm1 = class(TForm)
procedure FormShow(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
FirstShow : boolean;
arrLbl : lbl;
shp : TShape;
n,m : byte;
cx,cy : integer;
procedure CreateLabels;
procedure resetcursorpos(cx,cy : integer);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.resetcursorpos(cx, cy : integer);
begin
shp.Left := arrLbl[cy,cx].Left+2;
shp.top := arrLbl[cy,cx].Top+2;
end;
procedure TForm1.CreateLabels;
var i,j : byte;
x,y,t : integer;
ww : integer;
begin
ww := 25;
n := 50; m:=50;
SetLength(arrlbl, n,m);
x := 0; y:=0; t:=0;
for i := 0 to n-1 do
begin
for j := 0 to m-1 do
begin
arrLbl[i,j] := TLabel.Create(Form1);
arrLbl[i,j].Top := y;
arrLbl[i,j].Left := x;
arrLbl[i,j].Width := ww;
arrLbl[i,j].Height := ww div 2;
arrLbl[i,j].AutoSize := False;
arrLbl[i,j].Font.Name := "Times New Roman";
arrLbl[i,j].Font.Size := 8;
arrLbl[i,j].Caption := inttostr(t);
arrLbl[i,j].Color := clLime;
arrLbl[i,j].Parent := Form1;
x:=x+ww +1;
Inc(t);
end;
x:=0;
y:=y+ww div 2 +1;
end;
cx := 0; cy := 0;
shp := TShape.Create(Form1);
shp.Shape := stCircle;
shp.Width := ww -2;
shp.Height := ww div 2 -2;
shp.Brush.Style := bsClear;
shp.Pen.Width := 4;
shp.Parent := Form1;
shp.BringToFront;
resetcursorpos(cx,cy);
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Form1.WindowState := wsMaximized;
if FirstShow then CreateLabels;
FirstShow := False;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FirstShow := True;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case key of
VK_RIGHT : begin
if not (cx = n-1) then
begin
cx:=cx+1;
resetcursorpos(cx,cy);
end;
end;
VK_DOWN : begin
if not (cy = m-1) then
begin
cy:=cy+1;
resetcursorpos(cx,cy);
end;
end;
VK_LEFT : begin
if not (cx = 0) then
begin
cx:=cx-1;
resetcursorpos(cx,cy);
end;
end;
VK_UP : begin
if not (cy = 0) then
begin
cy:=cy-1;
resetcursorpos(cx,cy);
end;
end;
end;
end;
end.
← →
O'ShinW © (2013-01-14 09:03) [1]Думаю, вариантов тут 2.
1. Скакать через ячейку. Т.е. после N перемещений начинать перемещать сразу на 2(два раза вызывать resetcursorpos() ).
2. Перемещает таймер.
Пока нажата кнопка курсора запускаем таймер, который вызывает resetcursorpos(). Пока кнопка курсора не отпущена, таймер убавляет свой интервал, и следующий вызов будет быстрее.
(и не забыть "съесть нажатие кнопки" )
← →
sniknik © (2013-01-14 09:53) [2]данный способ (двигая компонент) вызывает перерисовку формы после каждого нажатия. в ехселе перерисовывает только нужное (отрисовка самостоятельная). возможно в этом и разница скорости.
← →
sniknik © (2013-01-14 10:42) [3]чисто для пробы, замена (должно быть быстрее)
procedure TForm1.resetcursorpos(cx, cy : integer);
const
wx = 50;
hy = 20;
begin
with Canvas do begin
Pen.Style:= psDot;
Pen.Width:= 2;
Brush.Style:= bsClear;
Rectangle(cx*wx, cy*hy, cx*wx+50, cy*hy+20);
end;
end;
← →
brother © (2013-01-14 10:50) [4]> в ехселе перерисовывает только нужное (отрисовка самостоятельная)
после моих изысканий пришел к выводу - перерисовывается ВСЕ!
← →
sniknik © (2013-01-14 10:56) [5]> перерисовывается ВСЕ!
значит более быстро... у него там все таки матрица 50 * 50 из лейблов, а не 1... /пара, несколько(немного) компонентов.
← →
yaproq © (2013-01-14 11:06) [6]Думаю, добился. По подсказке sniknik копал в сторону Canvas.
Перемещение "курсора" осуществляю так:
1) В обработчике нажатия клавиши перерисовываю только текущий Label (Label.Repaint), чтобы удалить чертеж Канва.
2) Перемешаю Канва в нужное место (Canvas.MoveTo(x,y)).
3) Рисую нужную фигуру. Все.
Только одна проблема. Если свернуть окно и снова развернуть, то рисунок исчезает. В каком обработчике можно это устранить?
Вот измененный код:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
coord = record
x : integer;
y : integer;
end;
lbl = array of array of TLabel;
TForm1 = class(TForm)
procedure FormShow(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
FirstShow : boolean;
arrLbl : lbl;
shp : TShape;
n,m : byte;
cx,cy : integer;
procedure CreateLabels;
procedure resetcursorpos(cx,cy : integer);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.resetcursorpos(cx, cy : integer);
var x1,x2, y1, y2 : integer;
begin
x1 := arrLbl[cy,cx].Left+2;
x2 := arrLbl[cy,cx].Left + arrLbl[cy,cx].Width - 2;
y1 := arrLbl[cy,cx].Top + 2;
y2 := arrLbl[cy,cx].Top + arrLbl[cy,cx].Height - 2;
Canvas.MoveTo(x1, y1);
Canvas.Brush.Style := bsClear;
Canvas.Rectangle(x1, y1, x2, y2);
(* shp.Left := arrLbl[cy,cx].Left+2;
shp.top := arrLbl[cy,cx].Top+2;
*)
end;
procedure TForm1.CreateLabels;
var i,j : byte;
x,y,t : integer;
ww : integer;
begin
ww := 25;
n := 100; m:=100;
SetLength(arrlbl, n,m);
x := 0; y:=0; t:=0;
for i := 0 to n-1 do
begin
for j := 0 to m-1 do
begin
arrLbl[i,j] := TLabel.Create(Form1);
arrLbl[i,j].Top := y;
arrLbl[i,j].Left := x;
arrLbl[i,j].Width := ww;
arrLbl[i,j].Height := ww div 2;
arrLbl[i,j].AutoSize := False;
arrLbl[i,j].Font.Name := "Times New Roman";
arrLbl[i,j].Font.Size := 8;
arrLbl[i,j].Caption := inttostr(t);
arrLbl[i,j].Color := clLime;
arrLbl[i,j].Parent := Form1;
x:=x+ww +1;
Inc(t);
end;
x:=0;
y:=y+ww div 2 +1;
end;
cx := 0; cy := 0;
shp := TShape.Create(Form1);
shp.Shape := stCircle;
shp.Width := ww -2;
shp.Height := ww div 2 -2;
shp.Brush.Style := bsClear;
shp.Pen.Width := 4;
shp.Parent := Form1;
shp.BringToFront;
resetcursorpos(cx,cy);
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Form1.WindowState := wsMaximized;
if FirstShow then CreateLabels;
FirstShow := False;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FirstShow := True;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case key of
VK_RIGHT : begin
if not (cx = n-1) then
begin
arrLbl[cy,cx].Repaint;
cx:=cx+1;
resetcursorpos(cx,cy);
end;
end;
VK_DOWN : begin
arrLbl[cy,cx].Repaint;
if not (cy = m-1) then
begin
cy:=cy+1;
resetcursorpos(cx,cy);
end;
end;
VK_LEFT : begin
arrLbl[cy,cx].Repaint;
if not (cx = 0) then
begin
cx:=cx-1;
resetcursorpos(cx,cy);
end;
end;
VK_UP : begin
arrLbl[cy,cx].Repaint;
if not (cy = 0) then
begin
cy:=cy-1;
resetcursorpos(cx,cy);
end;
end;
end;
end;
end.
← →
sniknik © (2013-01-14 11:35) [7]> В каком обработчике можно это устранить?
onPaint. но вообще лучше изменить подход. даже стринггрид лучше чем куча лейблов.
← →
yaproq © (2013-01-14 11:40) [8]Спасибо, sniknik.
Страницы: 1 вся ветка
Форум: "Начинающим";
Текущий архив: 2013.09.29;
Скачать: [xml.tar.bz2];
Память: 0.51 MB
Время: 0.003 c