IPB
ЛогинПароль:

> ВНИМАНИЕ!

Прежде чем задать вопрос, смотрите FAQ.
Рекомендуем загрузить DRKB.

Наладить общение поможет, если вы подпишитесь по почте на новые темы в этом форуме.

2 страниц V  1 2 >  
 Ответить  Открыть новую тему 
> Графика в Delphi, Работа с Canvas.
сообщение
Сообщение #1


Бывалый
****

Группа: Пользователи
Сообщений: 318
Пол: Мужской

Репутация: -  0  +


Всем привет. Имеется следующая процедура...она полностью рабочая, но хочется ее изменить...в данный момент процедура выводит квадратики...а хотелось бы чтобы она выводила другую фигуру..или вместо фигуры отображалась маленькая картинка..

procedure TForm02.OnDraw(var Mes: TMessage);

var
rp, rn: TRect;
begin
with TProcess02(Mes.LParam) do begin
with rp, PrevPoint do begin
Left := Round(ScaleX * x);
Right := Left + CellWidth;
Top := Round(ScaleY * y);
Bottom := Top + CellHeight;
end;
with rn, NextPoint do begin
Left := Round(ScaleX * x);
Right := Left + CellWidth;
Top := Round(ScaleY * y);
Bottom := Top + CellHeight;
end;
with PaintBox.Canvas do begin
Brush.Color := color;// Теперь после потока появился шлейф
if brush.Color = clwhite then
brush.Color := clred;
FillRect(rp);
Brush.Color :=Color;
// После умирания потока остается синяя точка
if brush.Color = clwhite then
brush.Color := clblue;
FillRect(rn);
end;
end;
end;
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Злостный любитель
*****

Группа: Пользователи
Сообщений: 1 755
Пол: Мужской

Репутация: -  62  +


> или вместо фигуры отображалась маленькая картинка..

var B: TBitmap;

...
// в инициализации где-то, дёргать винт на каждую перерисовку не надо
B := TBitmap.Create;
B.LoadFromFile('kartinka.bmp');
...
// вывод картинки
Canvas.Draw(round(Scale*x), round(Scale*y), B);


--------------------
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Бывалый
****

Группа: Пользователи
Сообщений: 318
Пол: Мужской

Репутация: -  0  +


Спасибо)) что - то подобное я сделал))А что еще можно изменить в этой процедуре?
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


просто человек
******

Группа: Пользователи
Сообщений: 3 641
Пол: Женский
Реальное имя: Юлия

Репутация: -  55  +


dron4ik, изменить можно что угодно
ты определись, что хочешь получить


--------------------
Все содержимое данного сообщения (кроме цитат) является моим личным скромным мнением и на статус истины в высшей инстанции не претендует.
На вопросы по программированию, физике, математике и т.д. в аське и личке не отвечаю. Даже "один-единственный раз" в виде исключения!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Бывалый
****

Группа: Пользователи
Сообщений: 318
Пол: Мужской

Репутация: -  0  +


Менять точно не буду щас ничего.Проблемка возникла чуть-чуть иная..могу обьяснить на скрине.Кстате как скрин вставить сюда?)))
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #6


Злостный любитель
*****

Группа: Пользователи
Сообщений: 1 755
Пол: Мужской

Репутация: -  62  +


Через расширенный режим.


--------------------
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #7


Бывалый
****

Группа: Пользователи
Сообщений: 318
Пол: Мужской

Репутация: -  0  +


Вот скрин.

Добавлено через 1 мин.
Где находиться красные штрихи, туда почему-то процесс не попадает...будто PaintBox имеет больше размеры, чем размеры области где происходит прорисовка.


Эскизы прикрепленных изображений
Прикрепленное изображение
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #8


Злостный любитель
*****

Группа: Пользователи
Сообщений: 1 755
Пол: Мужской

Репутация: -  62  +


Ну я вижу, что попадают 9 штук из 10.
У тебя нумерации с 1 нигде нет?


--------------------
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #9


Гость






Цитата
будто PaintBox имеет больше размеры, чем размеры области где происходит прорисовка.
Показывай Example02.pas полностью.
Цитата
что - то подобное я сделал
- это очень хорошо, конечно, но тогда единственный ответ, который напрашивается - это "значит, что-то сделал неправильно". Ибо изначальный Example02 из Gala (точно так же, как и измененный, как в первом посте) заполняют всю область PaintBox-а:
Прикрепленное изображение

Откуда вывод: проблема в твоих исправлениях... Телепаты - в отпуске.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #10


Бывалый
****

Группа: Пользователи
Сообщений: 318
Пол: Мужской

Репутация: -  0  +


Я скорее всего не правильно выразился...имел ввиду...где у нас красные штрихи туда процессы не попадают...хотя закрашиваться и там должно где эти самые штрихи.

Добавлено через 3 мин.
unit Example02;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, Gala;

const
WIDTH_02 = 20;
HEIGHT_02 = 10;
GM_DRAW_02 = GM_USER;

type
TX_02 = 0..WIDTH_02 - 1;
TY_02 = 0..HEIGHT_02 - 1;

// Направление движения - приращения по X и Y
TDirection02 = record
X, Y: -1..1;
end;

TForm02 = class(TForm)
Panel: TPanel;
PaintBox: TPaintBox;
LabelCMaxProcess: TLabel;
LabelMaxProcess: TLabel;
ScrollBarMaxProcess: TScrollBar;
LabelCProcessCount: TLabel;
LabelProcessCount: TLabel;
LabelListCount: TLabel;
ButtonStart: TButton;
ButtonFinish: TButton;

procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ButtonStartClick(Sender: TObject);
procedure ButtonFinishClick(Sender: TObject);
procedure ScrollBarMaxProcessChange(Sender: TObject);

private
CellWidth,
CellHeight: Integer;
ScaleX,
ScaleY: Double;
Group: Integer;
Count,
MaxCount: Integer;
BMP: TBitmap;

procedure OnDraw(var Mes: TMessage); message GM_DRAW_02;
procedure OnStart(var Mes: TMessage); message GM_PROCESS_START;
procedure OnTermination(var Mes: TMessage); message GM_PROCESS_TERMINATE;
procedure ShowListCount;

public
function CanCreate: Boolean;
end;

TProcess02 = class(TGalaProcess)
private
DeathTick,
DivideTick: Cardinal;
Direction: TDirection02;
Speed: Integer;
PBMP: TBitmap;
protected
procedure Execute; override;
procedure OnNormalTermination; override;
procedure OnPrematureTermination; override;

public
PrevPoint,
NextPoint: TPoint;
Color: TColor;
CanChildCreate: Boolean;

constructor Create(aGroup: Integer; aParentForm: TForm; aPoint: TPoint;
aDirection: TDirection02; BMP: TBitmap);
end;

implementation

{$R *.DFM}

const
{$IFDEF RUSSIAN_VERSION}
SWindowCaption = 'Размножающиеся процессы';
SMaxCaption = 'Макс. процессов';
SCountCaption = 'Число процессов';
SStartCaption = 'Старт';
SFinishCaption = 'Финиш';
{$ELSE}
SWindowCaption = 'Process propagation';
SMaxCaption = 'Max. processes';
SCountCaption = 'Process count';
SStartCaption = 'Start';
SFinishCaption = 'Finish';
{$ENDIF}

var
FormX, FormY: Integer;

{ TForm02 }

procedure TForm02.FormCreate(Sender: TObject);
begin
Left := FormX mod (Screen.DesktopWidth - Width);
Top := FormY mod (Screen.DesktopHeight - Height);
FormX := FormX + 32;
FormY := FormY + 32;
Group := 0;
Count := 0;
MaxCount := 5;
with PaintBox do begin
CellWidth := Width div WIDTH_02;
CellHeight := Height div HEIGHT_02;
ScaleX := Width / WIDTH_02;
ScaleY := Height / HEIGHT_02;
end;
LabelMaxProcess.Caption := IntToStr(MaxCount);
ScrollBarMaxProcess.Position := MaxCount;
Caption := SWindowCaption;
LabelCMaxProcess.Caption := SMaxCaption;
LabelCProcessCount.Caption := SCountCaption;
ButtonStart.Caption := SStartCaption;
ButtonFinish.Caption := SFinishCaption;
ShowListCount;
BMP:=TBitmap.Create(); // Создаём картинку
BMP.LoadFromFile(GetCurrentDir()+'\new-1.bmp'); // Загружаем картинку из файла
end;

procedure TForm02.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Group <> 0 then begin
GalaTheater.DestroyGroup(Group);
Group := 0;
end;
Action := caFree;
end;

procedure TForm02.ButtonStartClick(Sender: TObject);
var
p: TPoint;
d: TDirection02;
begin
try
Group := GalaTheater.GetNewGroup;
p.x := (WIDTH_02 div 4) + Random(WIDTH_02 div 2);
p.y := (HEIGHT_02 div 4) + Random(HEIGHT_02 div 2);
d.x := 1;
d.y := -1;
ButtonStart.Enabled := False;
TProcess02.Create(Group, Self, p, d,bmp);

ButtonFinish.Enabled := True;
except
on E: EGalaObjectCreationFail do begin
Application.MessageBox(PChar(E.Message), 'GalaExample', MB_OK);
Group := 0;
end;
end;
end;

procedure TForm02.ButtonFinishClick(Sender: TObject);
begin
if GalaTheater.TryToDestroyGroup(Group) then begin
ButtonFinish.Enabled := False;
ButtonStart.Enabled := True;
end;
end;

procedure TForm02.ScrollBarMaxProcessChange(Sender: TObject);
begin
MaxCount := ScrollBarMaxProcess.Position;
LabelMaxProcess.Caption := IntToStr(MaxCount);
end;

procedure TForm02.OnDraw(var Mes: TMessage);
var
rp, rn: TRect;
begin
with TProcess02(Mes.LParam) do begin
with rp, PrevPoint do begin
Left := Round(ScaleX * x);
Right := Left + CellWidth;
Top := Round(ScaleY * y);
Bottom := Top + CellHeight;
end;
with rn, NextPoint do begin
Left := Round(ScaleX * x);
Right := Left + CellWidth;
Top := Round(ScaleY * y);
Bottom := Top + CellHeight;
end;
with PaintBox.Canvas do begin
Brush.Color := clWhite;
FillRect(rp);
Brush.Color := Color;
StretchDraw(rn,PBMP); // Рисуем картинку
if Brush.Color=clWhite then FillRect(rp); // Закрашиваем если процесс труп
end;
end;
end;

procedure TForm02.OnStart(var Mes: TMessage);
begin
ShowListCount;
Inc(Count);
LabelProcessCount.Caption := IntToStr(Count);
end;

procedure TForm02.OnTermination(var Mes: TMessage);
begin
ShowListCount;
Dec(Count);
LabelProcessCount.Caption := IntToStr(Count);
end;

procedure TForm02.ShowListCount;
begin
LabelListCount.Caption := Format('A:%d, T:%d',
[GalaTheater.AllActiveCount, GalaTheater.AllTerminatedCount]);
end;

function TForm02.CanCreate: Boolean;
begin
result := Count < MaxCount;
end;

{ TProcess02 }

procedure TProcess02.Execute;
var
p: TPoint;
d: TDirection02;
r: integer;
const
Border = 3;
begin
FFreeOnTerminate := True;
Priority := -1;
DivideTick := GetTickCount + 1000 + Cardinal(Random(2000));
Send(GM_PROCESS_START);
while (not Terminated) and (GetTickCount < DeathTick) do begin
with NextPoint do begin
x := PrevPoint.x + Direction.x;
y := PrevPoint.y + Direction.y;
if not (x <= Low(TX_02)) or (x >= High(TX_02)) and not (y <= Low(TY_02)) or (y >= High(TY_02)) then
begin
r:=random(2); // Обращаем направление по случайной оси
if r=0 then
Direction.x := -Direction.x
else
Direction.y := -Direction.y;
end;
if (x <= Low(TX_02)) or (x >= High(TX_02)) then
begin
Direction.x := -Direction.x;
NextPoint.x:=0; // Если улетит за стенку вылетит с обратной стороны
// Чтоб совсем не улетела
end;
if (y <= Low(TY_02)) or (y >= High(TY_02)) then
begin
Direction.y := -Direction.y;
NextPoint.y:=0; // Если улетит за стенку вылетит с обратной стороны
// Чтоб совсем не улетела
end;
end;
if (GetTickCount > DivideTick) then begin
DivideTick := GetTickCount + 1000 + Cardinal(Random(2000));
if (PrevPoint.x >= (Low(TX_02) + Border)) and
(PrevPoint.y >= (Low(TY_02) + Border)) and
(PrevPoint.x <= (High(TX_02) - Border)) and
(PrevPoint.y <= (High(TY_02) - Border)) and
((ParentForm as TForm02).CanCreate) then
begin
p := PrevPoint;
d := Direction;
d.x := -d.x;
try
TProcess02.Create(Group, ParentForm, p, d,pbmp);
except
on EGalaObjectCreationFail do
Beep;
end;
end;
end;
try
Send(GM_DRAW_02, Self, ParentForm, 200);
PrevPoint := NextPoint;
Pause(Speed);
except
on EGalaTimeout do
Terminate;
end;
end;
end;

procedure TProcess02.OnPrematureTermination;
begin
OnNormalTermination;
end;

procedure TProcess02.OnNormalTermination;
begin
Color := clWhite;
Send(GM_DRAW_02);
Send(GM_PROCESS_TERMINATE);
end;

constructor TProcess02.Create(aGroup: Integer; aParentForm: TForm;
aPoint: TPoint; aDirection: TDirection02; BMP: TBitmap);
begin
inherited Create(aGroup, aParentForm);
PBMP:=BMP;
PrevPoint := aPoint;
NextPoint := PrevPoint;
Direction := aDirection;
Color := TColor(Random(Integer(clYellow)));
DeathTick := GetTickCount + 5000 + Cardinal(Random(10000));
Speed := 80;
end;

initialization
FormX := 0;
FormY := 120;

end.


Добавлено через 3 мин.
Volvo, прав! Нужно чтобы закрашивалась вся область PaintBoxa.

Добавлено через 6 мин.
Пробовал менять это:
const
WIDTH_02 = 20;
HEIGHT_02 = 10;


Но оказалась, что меняется ширина или высота.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #11


Гость






И опять непонятно, что не так... Все закрашивается:


Эскизы прикрепленных изображений
Прикрепленное изображение
 К началу страницы 
+ Ответить 
сообщение
Сообщение #12


Бывалый
****

Группа: Пользователи
Сообщений: 318
Пол: Мужской

Репутация: -  0  +


Странно.....

Добавлено через 5 мин.
может это изза картинки которую я загрузил?
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #13


просто человек
******

Группа: Пользователи
Сообщений: 3 641
Пол: Женский
Реальное имя: Юлия

Репутация: -  55  +


размер у картинки такой же, как у "родного" прямоугольничка?


--------------------
Все содержимое данного сообщения (кроме цитат) является моим личным скромным мнением и на статус истины в высшей инстанции не претендует.
На вопросы по программированию, физике, математике и т.д. в аське и личке не отвечаю. Даже "один-единственный раз" в виде исключения!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #14


Бывалый
****

Группа: Пользователи
Сообщений: 318
Пол: Мужской

Репутация: -  0  +


метод который я использую он вроде сам "подгоняет " под нужный размер...но заметил что прямоугольники стали больше по сравнению с оригиналом.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #15


Гость






А можно присоединить сюда ту картинку, с которой ты работаешь? Я попробовал несколько штук - везде результаты одинаковые, вся поверхность заполняется. Какого размера твое изображение вообще?

Добавлено через 7 мин.
Так. Стоп. Вопрос отменяется, я скопировал твой код один в один - теперь действительно не заполняются крайние снизу и справа ряды. Когда я добавлял к оригинальному коду работу с битмапом - все было прекрасно. Сейчас посмотрю, в чем разница.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #16


Гость






Ну, чего и следовало ожидать. Ты что в TProcess02.Execute творишь? Было же нормальное поведение, зачем понадобилось на каждом шаге бегать в случайном направлении? Чтобы усложнить доступ к каким-то клеткам? Это первое. Второе:

Цитата
      if (x <= Low(TX_02)) or (x >= High(TX_02)) then
begin
Direction.x := -Direction.x;
NextPoint.x:=0; // Если улетит за стенку вылетит с обратной стороны
// Чтоб совсем не улетела
end;
То есть, неважно, куда вылетело - влево или вправо, влетит всегда слева? Как-то не очень правильно это. Тебе надо не менять направление движения (если вылетело справа ,значит двигалось слева направо, после того как появится с другой стороны - должно продолжать двигаться в том же направлении), а проверять, с какой стороны показывать картинку.

В общем, ты сначала расскажи, чего ты хочешь добиться такими магическими изменениями в Execute, а потом посмотрим, как это лучше исправить.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #17


Бывалый
****

Группа: Пользователи
Сообщений: 318
Пол: Мужской

Репутация: -  0  +


В принципе может лучше взять процедуру Execute с оригинала GALA.

Добавлено через 5 мин.
взял с оригинала...не сработало вышла ошибка....

Добавлено через 4 мин.
в общем процедуру Execute такой сделал--теперь PaintBox закрашивается вся область.

procedure TProcess02.Execute;
var
p: TPoint;
d: TDirection02;
const
Border = 3;
begin
FFreeOnTerminate := True;
Priority := -1;
DivideTick := GetTickCount + 1000 + Cardinal(Random(2000));
Send(GM_PROCESS_START);
while (not Terminated) and (GetTickCount < DeathTick) do begin
with NextPoint do begin
x := PrevPoint.x + Direction.x;
y := PrevPoint.y + Direction.y;
if (x <= Low(TX_02)) or (x >= High(TX_02)) then
Direction.x := -Direction.x;
if (y <= Low(TY_02)) or (y >= High(TY_02)) then
Direction.y := -Direction.y;
end;
if (GetTickCount > DivideTick) then begin
DivideTick := GetTickCount + 1000 + Cardinal(Random(2000));
if (PrevPoint.x >= (Low(TX_02) + Border)) and
(PrevPoint.y >= (Low(TY_02) + Border)) and
(PrevPoint.x <= (High(TX_02) - Border)) and
(PrevPoint.y <= (High(TY_02) - Border)) and
((ParentForm as TForm02).CanCreate) then
begin
p := PrevPoint;
d := Direction;
d.x := -d.x;
try
TProcess02.Create(Group, ParentForm, p, d,pbmp);
except
on EGalaObjectCreationFail do
Beep;
end;
end;
end;
try
Send(GM_DRAW_02, Self, ParentForm, 200);
PrevPoint := NextPoint;
Pause(Speed);
except
on EGalaTimeout do
Terminate;
end;
end;
end;


Добавлено через 2 мин.
Но двигаются щас они...как-то одинаково симметрично...и однообразно...что то не то((
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #18


Гость






Цитата
взял с оригинала...не сработало вышла ошибка....
Естественно, вызов TProcess02.Create должен быть соответствующим (надо добавить еще один параметр). Это единственное, что надо изменить.

Добавлено через 2 мин.
Цитата
Но двигаются щас они...как-то одинаково симметрично...и однообразно...
Повторяю вопрос - чего ты хочешь получить? Ты ж молчишь, откуда я знаю, что для тебя НЕ симметрично и НЕ однообразно? Значит, пока были не картинки - все было нормально, а как только поменял на изображения - не то? Или все-таки тебе надо чего-то другое, свое, а разработчики Gala тебе не это предоставили? Может, они тоже не телепаты?
 К началу страницы 
+ Ответить 
сообщение
Сообщение #19


Бывалый
****

Группа: Пользователи
Сообщений: 318
Пол: Мужской

Репутация: -  0  +


когда не было картинок...движение процессов было хаотичное...а когда я поменял щас процедуру Execute на оригинал...движение стало предсказуемо...
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #20


Гость






Цитата
когда не было картинок...движение процессов было хаотичное...а когда я поменял щас процедуру Execute на оригинал...движение стало предсказуемо...
Неправда. Точно такое же движение и осталось. Никакой хаотичностью и не пахло, направления движения были точно такие же, просто скорость была разная. Ты же в конструкторе процесса сбросил всем скорость на 80, теперь сам жалуешься.
 К началу страницы 
+ Ответить 

2 страниц V  1 2 >
 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 29.03.2024 1:15
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name