Как сделать прям-к для выделения части картинки, чтобы она не...

← →
Hatawa (2003-07-13 17:49) [0]

Как сделать прям-к для выделения части картинки, чтобы она не мигала при движении мыши????

Я использовала
http://www.delphimaster.ru/cgi-bin/faq.pl?look=1&id=988624269&n=21

но происходит мигание картинки, пока прямоугольник рисуется - ужас!!!

← →
Palladin (2003-07-13 17:56) [1]

Ужас, кашмар и пр эмоции
попробуй DoubleBuffered:=true

← →
Hatawa (2003-07-13 17:59) [2]

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

← →
Palladin (2003-07-13 18:01) [3]

что что, простите?

← →
Hatawa (2003-07-13 18:05) [4]

Я и делаю дабл-буферинг.
при попытке создания рисунка динамически всё грохается с exeptionом.

← →
DVM (2003-07-13 18:09) [5]

ImageList + CreateDragImage = ничего абсолютно не мигает

← →
DVM (2003-07-13 18:10) [6]

Сорри, это я, наверное, перепутал, мне показалось, что картинку перетаскивают.

← →
Hatawa (2003-07-13 18:11) [7]

объясни, плиз, поподробнее...

← →
Hatawa (2003-07-13 18:12) [8]

ничего страшного :)

← →
Семен Сорокин (2003-07-13 18:15) [9]

2Hatawa
код покажи.
Может стоить рисовать на битмапе, а потом copyrect на канву картинки?

← →
Hatawa (2003-07-13 18:23) [10]

при попытке динамически создать битмап все грохается

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

← →
Palladin (2003-07-13 18:27) [11]

У тебя код просят, или плохо просят?
Могу конкретно сказать, нужен тот участок который вызывает exception

← →
Hatawa (2003-07-13 18:38) [12]

procedure TMDIChild.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var tmp: TPicture; begin if crop_fl then begin if Captured then begin tmp.Create; tmp.bitmap.Width:=Image1.Width; tmp.bitmap.Height:=Image1.Height; tmp.Bitmap:=image1.Picture.Bitmap; tmp.bitmap.Canvas.Brush.Color:=clwhite; tmp.bitmap.Canvas.DrawFocusRect(MakeRect(StartPlace,EndPlace)); image1.Picture.Bitmap:=tmp.Bitmap; tmp.Destroy; end; StartPlace.x := X; StartPlace.y := Y; EndPlace.x := X; EndPlace.y := Y; tmp.Create; tmp.bitmap.Width:=Image1.Width; tmp.bitmap.Height:=Image1.Height; tmp.Bitmap:=image1.Picture.Bitmap; tmp.bitmap.Canvas.Brush.Color:=clwhite; tmp.bitmap.Canvas.DrawFocusRect(MakeRect(StartPlace,EndPlace)); image1.Picture.Bitmap:=tmp.Bitmap; tmp.Destroy; Capturing := true; Captured := true; end; end;

на Creat"е вываливается

← →
Palladin (2003-07-13 18:49) [13]

где тебя учили объекты так создавать? или сама придумала?

tmp:=TPicture.Create;
...
tmp.free;

← →
Семен Сорокин (2003-07-13 18:50) [14]

var
tmp: TBitmap;
...

tmp := tBitmap.Create;
try

finally
tmp.Free
end

← →
Palladin (2003-07-13 18:51) [15]

http://www.delphikingdom.com/helloworld/runtime_comp.htm

← →
Семен Сорокин (2003-07-13 18:54) [16]

чё-нить типа этого:
tmp := TBitmap.Create; with _tmp do try Width:=Image1.Width; Height:=Image1.Height; Canvas.CopyRect(Canvas.ClipRect, image1.Picture.Bitmap.Canvas, image1.Picture.Bitmap.Canvas.ClipRect); Canvas.Brush.Color:=clwhite; Canvas.DrawFocusRect(MakeRect(StartPlace,EndPlace)); StartPlace.x := X; StartPlace.y := Y; EndPlace.x := X; EndPlace.y := Y; Canvas.DrawFocusRect(MakeRect(StartPlace,EndPlace)); image1.Picture.Bitmap:=tmp; finally tmp.Free end

← →
Hatawa (2003-07-13 19:07) [17]

Thanks за Create, что то я стормозила..

image1.Picture.Bitmap:=tmp.Bitmap;
не помогает..

CopyRect что-нибудь изменит?

← →
Hatawa (2003-07-13 19:12) [18]

2Семен Сорокин:

спасибо, дергается меньше, но дергается.. :(

← →
Семен Сорокин (2003-07-13 19:19) [19]

Hatawa (13.07.03 19:12)
можно попробовать отрисовывать только выделяемую область...
image1.Picture.Bitmap:=tmp;
надо тоже CopyRect использовать, попробуй - может еще лучше будет

← →
Hatawa (2003-07-13 19:37) [20]

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

← →
Семен Сорокин (2003-07-13 19:43) [21]

Hatawa (13.07.03 19:37)
как вариант: возьми TShape с Brush.Style = bsClear - вообще моргать не будет :))
и растягивай его - будет как выделение

← →
Hatawa (2003-07-13 19:47) [22]

поясни, плиз, как с ним работать?

← →
Семен Сорокин (2003-07-13 19:55) [23]

кидаешь на форму TShape, выставляешь Brush.Style = bsClear, делаешь Visible = false
отлавливаешь сообщение нажатия кнопки на рисунке - ставишь SetBounds TShape"а - в эту точку, и делаешь его видимым, по мере перетаскивания изменяешь его размеры (Left, Top, Width, Height) - ведешь за мышкой, как только кнопку отжали - скрываешь и все :)

← →
Hatawa (2003-07-13 20:02) [24]

спасибо, попробую :)

← →
Hatawa (2003-07-13 20:11) [25]

прикольно!!!!! :)

это лучше, вот только он периодически закрашивается...:(

← →
Семен Сорокин (2003-07-13 20:13) [26]

чем закрашивается?

← →
Hatawa (2003-07-13 20:17) [27]

черная граница => черным цветом периодически закрашивается при движении мыши..

← →
Семен Сорокин (2003-07-13 20:18) [28]

Application.ProcessMessages вставь после изменения размеров

← →
Hatawa (2003-07-13 20:25) [29]

не помогает..

← →
Hatawa (2003-07-13 20:35) [30]

блин, закрашивается и все тут.. что ни делай - не помогает :(

← →
Hatawa (2003-07-14 13:20) [31]

есть ли кроме Application.ProcessMessages еще какой-нить метод борьбы?

← →
Семен Сорокин (2003-07-14 13:49) [32]

Hatawa (14.07.03 13:20)
код покажи

← →
Hatawa (2003-07-14 14:10) [33]

Sh.SetBounds(StartPlace.X, StartPlace.Y, Endplace.X-StartPlace.X, Endplace.Y-StartPlace.Y); Application.ProcessMessages;

← →
Семен Сорокин (2003-07-14 14:14) [34]

Hatawa (14.07.03 14:10)
попробуй выполнять эту процедуру если:
if (Abs(StartPlace.X - Endplace.X) > 1) or (Abs(StartPlace.Y - Endplace.Y) > 1) then
может поможет

← →
Hatawa (2003-07-14 14:16) [35]

но мигает (закрашивается), когда рисуешь большие прямоуголиники...

← →
Семен Сорокин (2003-07-14 14:25) [36]

не поленился - накидал код - ничё не тормозит :))
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, jpeg; type TForm1 = class(TForm) Image1: TImage; Shape1: TShape; procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private OldX, OldY: integer; public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin OldX := X; OldY := Y; Shape1.SetBounds(X, Y, 1, 1); Shape1.Visible := true; end; procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var _rect: TRect; begin if X > OldX then begin _rect.Left := OldX; _rect.Right := X end else begin _rect.Left := X; _rect.Right := OldX end; if Y > OldY then begin _rect.Top := OldY; _rect.Bottom := Y end else begin _rect.Top := Y; _rect.Bottom := OldY end; Shape1.SetBounds(_rect.Left, _rect.Top, _rect.Right - _rect.Left, _rect.Bottom - _rect.Top); Application.ProcessMessages end; procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Shape1.Visible := false; end; end.

← →
Hatawa (2003-07-14 14:29) [37]

Спасибки большое!!! :)
сейчас попробую!..

← →
Hatawa (2003-07-14 17:31) [38]

2Семен Сорокин:
Ты будешь смеяться, но мигает по-прежнему...

← →
Семен Сорокин (2003-07-14 17:33) [39]

Hatawa (14.07.03 17:31)
буду :)), мыль - посмотрю

← →
Hatawa (2003-07-14 18:41) [40]

Лови!

← →
Hatawa (2003-07-14 19:13) [41]

Поймал???

← →
Fenik (2003-07-14 19:29) [42]

Мне бы ваши проблемы..

← →
Hatawa (2003-07-14 19:32) [43]

2Fenik:

а у тебя что??

← →
Fenik (2003-07-14 21:28) [44]

У меня сегодня кошка родила вчера котят.

unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm) Button1: TButton; ScrollBox1: TScrollBox; OpenDialog1: TOpenDialog; PaintBox1: TPaintBox; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure PaintBox1Paint(Sender: TObject); procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private FDown: Boolean; fx, fy, oldx, oldy: Integer; FBitmap: TBitmap; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin if OpenDialog1.Execute then begin FBitmap.LoadFromFile(Opendialog1.FileName); PaintBox1.Width := FBitmap.Width; PaintBox1.Height := FBitmap.Height; end; end; procedure TForm1.FormCreate(Sender: TObject); begin FBitmap := TBitmap.Create; end; procedure TForm1.FormDestroy(Sender: TObject); begin FBitmap.Free; end; procedure TForm1.PaintBox1Paint(Sender: TObject); begin PaintBox1.Canvas.Draw(0, 0, FBitmap); end; procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin fx := x; fy := y; oldx := x; oldy := y; FDown := True; with PaintBox1.Canvas do begin Pen.Color := clBlue; Pen.Style := psDot; Pen.Mode := pmNotXor; Brush.Style := bsClear; end; end; procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if FDown then begin PaintBox1.Canvas.Rectangle(fx, fy, oldx, oldy); PaintBox1.Canvas.Rectangle(fx, fy, x, y); oldx := x; oldy := y; end; end; procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FDown := False; end; end.

dfm: object Form1: TForm1 Left = 177 Top = 107 Width = 696 Height = 480 Caption = "Open" Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = "MS Sans Serif" Font.Style = [] OldCreateOrder = False OnCreate = FormCreate OnDestroy = FormDestroy PixelsPerInch = 96 TextHeight = 13 object Button1: TButton Left = 20 Top = 12 Width = 75 Height = 25 Caption = "Button1" TabOrder = 0 OnClick = Button1Click end object ScrollBox1: TScrollBox Left = 0 Top = 56 Width = 688 Height = 397 Align = alBottom TabOrder = 1 object PaintBox1: TPaintBox Left = 0 Top = 0 Width = 105 Height = 105 OnMouseDown = PaintBox1MouseDown OnMouseMove = PaintBox1MouseMove OnMouseUp = PaintBox1MouseUp OnPaint = PaintBox1Paint end end object OpenDialog1: TOpenDialog Filter = "Bitmap|*.bmp" Left = 108 Top = 12 end end

Как сделать прям-к для выделения части картинки, чтобы она не... Найти похожие ветки