Всем привет. Имеется следующая процедура...она полностью рабочая, но хочется ее изменить...в данный момент процедура выводит квадратики...а хотелось бы чтобы она выводила другую фигуру..или вместо фигуры отображалась маленькая картинка..
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;
TarasBer
18.10.2010 13:11
> или вместо фигуры отображалась маленькая картинка..
var B: TBitmap;
... // в инициализации где-то, дёргать винт на каждую перерисовку не надо B := TBitmap.Create; B.LoadFromFile('kartinka.bmp'); ... // вывод картинки Canvas.Draw(round(Scale*x), round(Scale*y), B);
dron4ik
18.10.2010 14:19
Спасибо)) что - то подобное я сделал))А что еще можно изменить в этой процедуре?
мисс_граффити
18.10.2010 15:03
dron4ik, изменить можно что угодно ты определись, что хочешь получить
dron4ik
18.10.2010 15:50
Менять точно не буду щас ничего.Проблемка возникла чуть-чуть иная..могу обьяснить на скрине.Кстате как скрин вставить сюда?)))
TarasBer
18.10.2010 16:04
Через расширенный режим.
dron4ik
18.10.2010 16:30
Вот скрин.
Добавлено через 1 мин. Где находиться красные штрихи, туда почему-то процесс не попадает...будто PaintBox имеет больше размеры, чем размеры области где происходит прорисовка.
TarasBer
18.10.2010 17:05
Ну я вижу, что попадают 9 штук из 10. У тебя нумерации с 1 нигде нет?
volvo
18.10.2010 17:09
Цитата
будто PaintBox имеет больше размеры, чем размеры области где происходит прорисовка.
Показывай Example02.pas полностью.
Цитата
что - то подобное я сделал
- это очень хорошо, конечно, но тогда единственный ответ, который напрашивается - это "значит, что-то сделал неправильно". Ибо изначальный Example02 из Gala (точно так же, как и измененный, как в первом посте) заполняют всю область PaintBox-а: Нажмите для просмотра прикрепленного файла
Откуда вывод: проблема в твоих исправлениях... Телепаты - в отпуске.
dron4ik
18.10.2010 17:09
Я скорее всего не правильно выразился...имел ввиду...где у нас красные штрихи туда процессы не попадают...хотя закрашиваться и там должно где эти самые штрихи.
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.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.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;
Добавлено через 3 мин. Volvo, прав! Нужно чтобы закрашивалась вся область PaintBoxa.
Добавлено через 6 мин. Пробовал менять это:
const WIDTH_02 = 20; HEIGHT_02 = 10;
Но оказалась, что меняется ширина или высота.
volvo
18.10.2010 17:34
И опять непонятно, что не так... Все закрашивается:
dron4ik
18.10.2010 17:39
Странно.....
Добавлено через 5 мин. может это изза картинки которую я загрузил?
мисс_граффити
18.10.2010 18:16
размер у картинки такой же, как у "родного" прямоугольничка?
dron4ik
18.10.2010 18:21
метод который я использую он вроде сам "подгоняет " под нужный размер...но заметил что прямоугольники стали больше по сравнению с оригиналом.
volvo
18.10.2010 18:47
А можно присоединить сюда ту картинку, с которой ты работаешь? Я попробовал несколько штук - везде результаты одинаковые, вся поверхность заполняется. Какого размера твое изображение вообще?
Добавлено через 7 мин. Так. Стоп. Вопрос отменяется, я скопировал твой код один в один - теперь действительно не заполняются крайние снизу и справа ряды. Когда я добавлял к оригинальному коду работу с битмапом - все было прекрасно. Сейчас посмотрю, в чем разница.
volvo
18.10.2010 19:20
Ну, чего и следовало ожидать. Ты что в TProcess02.Execute творишь? Было же нормальное поведение, зачем понадобилось на каждом шаге бегать в случайном направлении? Чтобы усложнить доступ к каким-то клеткам? Это первое. Второе:
Цитата
if (x <= Low(TX_02)) or (x >= High(TX_02)) then begin Direction.x := -Direction.x; NextPoint.x:=0; // Если улетит за стенку вылетит с обратной стороны // Чтоб совсем не улетела end;
То есть, неважно, куда вылетело - влево или вправо, влетит всегда слева? Как-то не очень правильно это. Тебе надо не менять направление движения (если вылетело справа ,значит двигалось слева направо, после того как появится с другой стороны - должно продолжать двигаться в том же направлении), а проверять, с какой стороны показывать картинку.
В общем, ты сначала расскажи, чего ты хочешь добиться такими магическими изменениями в Execute, а потом посмотрим, как это лучше исправить.
dron4ik
18.10.2010 21:03
В принципе может лучше взять процедуру 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 мин. Но двигаются щас они...как-то одинаково симметрично...и однообразно...что то не то((
volvo
18.10.2010 21:18
Цитата
взял с оригинала...не сработало вышла ошибка....
Естественно, вызов TProcess02.Create должен быть соответствующим (надо добавить еще один параметр). Это единственное, что надо изменить.
Добавлено через 2 мин.
Цитата
Но двигаются щас они...как-то одинаково симметрично...и однообразно...
Повторяю вопрос - чего ты хочешь получить? Ты ж молчишь, откуда я знаю, что для тебя НЕ симметрично и НЕ однообразно? Значит, пока были не картинки - все было нормально, а как только поменял на изображения - не то? Или все-таки тебе надо чего-то другое, свое, а разработчики Gala тебе не это предоставили? Может, они тоже не телепаты?
dron4ik
18.10.2010 21:22
когда не было картинок...движение процессов было хаотичное...а когда я поменял щас процедуру Execute на оригинал...движение стало предсказуемо...
volvo
18.10.2010 21:36
Цитата
когда не было картинок...движение процессов было хаотичное...а когда я поменял щас процедуру Execute на оригинал...движение стало предсказуемо...
Неправда. Точно такое же движение и осталось. Никакой хаотичностью и не пахло, направления движения были точно такие же, просто скорость была разная. Ты же в конструкторе процесса сбросил всем скорость на 80, теперь сам жалуешься.
dron4ik
18.10.2010 21:39
про скорость:
Speed := 80;
я помню что было написано
Speed:= 40+ Random(200);
Добавлено через 3 мин. поставил прежнюю скорость..теперь красота!
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.