I developed an application in Delphi using graphics32 library. It involves adding layers to a ImgView32 control. It does all I want now, except that when the user adds more that 25-30 layers to the ImgView, the selected layer starts behaving badly. I mean,
- when there are 30+ layers on the ImgView32 and I click on a layer, it takes about 2.5-2 seconds to actually select it.
- Also when I try to move the layer, it moves abruptly
It appears that ImgViewChange is called way too many times when there are more layers. Same goes to PaintLayer. It gets called way too many times.
How can I stop that from happening? How can I make the layers move graciously even when there are more that 30 layers added?
My code is as follows:
procedure TMainForm.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
cronstart:=now;
if Sender <> nil then
begin
Selection := TPositionedLayer(Sender);
end
else
begin
end;
cronstop:=now;
Memo1.Lines.Add('LayerMouseDown:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.AddSpecialLineLayer(tip:string);
var
B: TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.SetSize(100,100);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
with ImgView.Bitmap do
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
B.OnPaint := PaintGeamOrizHandler
except
Free;
raise;
end;
Selection := B;
end;
procedure TMainForm.PaintGeamOrizHandler(Sender: TObject;Buffer: TBitmap32);
var
bmp32:TBitmap32;
R:TRect;
usa2:single;
latime,inaltime,usa:Single;
inaltime2, latime2:single;
begin
cronstart:=now;
if Sender is TBitmapLayer then
with TBitmapLayer(Sender).GetAdjustedLocation do
begin
bmp32:=TBitmap32.Create;
try
R := MakeRect(TBitmapLayer(Sender).GetAdjustedLocation);
bmp32.DrawMode:=dmblend;
bmp32.SetSize(Round(Right-Left), Round(Bottom-Top));
latime:=Round((Right-Left));
inaltime:=Round((Bottom-Top));
usa:=60;
usa2:=usa / 2;
with TLine32.Create do
try
EndStyle := esClosed;
JoinStyle := jsMitered;
inaltime2:=inaltime / 2;
latime2:=latime / 2;
SetPoints([FixedPoint(latime2-usa2,inaltime2), FixedPoint(latime2+usa2,inaltime2)]);
Draw(bmp32, 13, clWhite32);
SetPoints(GetOuterEdge);
Draw(bmp32, 1.5, clBlack32);
SetPoints([FixedPoint(latime2-usa2-3,inaltime2), FixedPoint(latime2-usa2,inaltime2)]);
Draw(bmp32, 5, clBlack32);
SetPoints([FixedPoint(latime2-usa2-3-7,inaltime2), FixedPoint(latime2-usa2-3,inaltime2)]);
Draw(bmp32, 7, clWhite32);
SetPoints(GetOuterEdge);
Draw(bmp32, 1.5, clBlack32);
SetPoints([FixedPoint(latime2+usa2,inaltime2), FixedPoint(latime2+usa2+3,inaltime2)]);
Draw(bmp32, 5, clBlack32);
SetPoints([FixedPoint(latime2+usa2+3+7,inaltime2), FixedPoint(latime2+usa2+3,inaltime2)]);
Draw(bmp32, 7, clWhite32);
SetPoints(GetOuterEdge);
Draw(bmp32, 1.5, clBlack32);
finally
Free;
end;
(Sender as TBitmapLayer).Bitmap.Assign(bmp32);
finally
bmp32.Free;
end;
end;
cronstop:=now;
Memo1.Lines.Add('PaintLayer:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.SetSelection(Value: TPositionedLayer);
begin
if Value<>nil then
begin
if Value <> FSelection then
begin
if RBLayer <> nil then
begin
RBLayer.ChildLayer := nil;
RBLayer.LayerOptions := LOB_NO_UPDATE;
end;
FSelection := Value;
if Value <> nil then
begin
if RBLayer = nil then
begin
RBLayer := TRubberBandLayer.Create(ImgView.Layers);
RBLayer.MinHeight := 1;
RBLayer.MinWidth := 1;
end
else
RBLayer.BringToFront;
RBLayer.ChildLayer := Value;
RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS or LOB_NO_UPDATE;
RBLayer.OnResizing := RBResizing;
end;
end;
end;
end;
procedure TMainForm.RBResizing(Sender: TObject;
const OldLocation: TFloatRect; var NewLocation: TFloatRect;
DragState: TRBDragState; Shift: TShiftState);
var
w, h, cx, cy: Single;
nw, nh: Single;
begin
cronstart:=now;
if DragState = dsMove then Exit; // we are interested only in scale operations
if Shift = [] then Exit; // special processing is not required
if ssCtrl in Shift then
begin
{ make changes symmetrical }
with OldLocation do
begin
cx := (Left + Right) / 2;
cy := (Top + Bottom) / 2;
w := Right - Left;
h := Bottom - Top;
end;
with NewLocation do
begin
nw := w / 2;
nh := h / 2;
case DragState of
dsSizeL: nw := cx - Left;
dsSizeT: nh := cy - Top;
dsSizeR: nw := Right - cx;
dsSizeB: nh := Bottom - cy;
dsSizeTL: begin nw := cx - Left; nh := cy - Top; end;
dsSizeTR: begin nw := Right - cx; nh := cy - Top; end;
dsSizeBL: begin nw := cx - Left; nh := Bottom - cy; end;
dsSizeBR: begin nw := Right - cx; nh := Bottom - cy; end;
end;
if nw < 2 then nw := 2;
if nh < 2 then nh := 2;
Left := cx - nw;
Right := cx + nw;
Top := cy - nh;
Bottom := cy + nh;
end;
end;
cronstop:=now;
Memo1.Lines.Add('RBResizing:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.ImgViewChange(Sender: TObject);
var
wid,hei:Integer;
begin
Edit1.Text:=IntToStr(StrToInt(Edit1.Text)+1);
cronstart:=now;
if Selection = nil then
begin
end
else
begin
wid:=Round(Selection.Location.Right-Selection.Location.Left);
hei:=Round(Selection.Location.Bottom-Selection.Location.Top);
// SelectLayerPan(Selection.Index);
end;
cronstop:=now;
Memo1.Lines.Add('ImgViewChange:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.ImgViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
Edit1.Text:='0';
cronstart:=now;
if Layer = nil then
begin
if Assigned(FSelection) then
begin
Selection := nil;
RBLayer.Visible:=false;
end;
end
else
begin
// SelectLayerPan(layer.Index);
end;
cronstop:=now;
Memo1.Lines.Add('imgViewMouseDown:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
StageNum: Cardinal);
const //0..1
Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
var
R: TRect;
I, J: Integer;
OddY: Integer;
TilesHorz, TilesVert: Integer;
TileX, TileY: Integer;
TileHeight, TileWidth: Integer;
begin
TileHeight := 13;
TileWidth := 13;
TilesHorz := Buffer.Width div TileWidth;
TilesVert := Buffer.Height div TileHeight;
TileY := 0;
for J := 0 to TilesVert do
begin
TileX := 0;
OddY := J and $1;
for I := 0 to TilesHorz do
begin
R.Left := TileX;
R.Top := TileY;
R.Right := TileX + TileWidth;
R.Bottom := TileY + TileHeight;
Buffer.FillRectS(R, Colors[I and $1 = OddY]);
Inc(TileX, TileWidth);
end;
Inc(TileY, TileHeight);
end;
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
Edit1.Text:='0';
MainForm.AddSpecialLineLayer('geams'); //orizontal
end;
So just click the button multiple times (30 times) and you will notice the eratic behaviour once you get to have 25-30 layers added.
(Of course use the base code from the layers example of the library and add the above procedures)
Maybe a solution would be to disable somewhere the ImgViewChange event from firing. But I do not know where to do that... Or maybe I'm wrong.
Please give me a solution for this problem... because I can't think of anything...
EDIT
Here is a screenshot that will explain better:
As you can see in the right side of the imgView, there are 3 editboxes. The first tells us that there are 25 layers added already. The other two are also self-explanatory.
In the left side of the picture you can see the layers drawn there. They are all the same, drawn with the paintHandler from the code. So all the layers are identical
Now consider this scenario: no layer is selected, then I start clicking layers, the first 3 clicks, show me ImgViewChange=52 and Paint=26, for each of them. Then on my fourth click on a layer the values are those in the image displayed here. This does not make any sense.
So ImgViewChanged is called 1952 times and the PaintHandler is called 976 times. There must be a bug somewhere...
Please help me figure this out. take into consideration that those editboxes get filled in the code above. Also in this test project there is no other code that might do this crazy behavior. I wrote this test project with only the code that was neccessary to make it work. So the code is above, the behavior is in the picture.
EDIT
After I added bmp32.BeginUpdate and bmp32.EndUpdate in the PaintHandler method, the number of repaints and imgViewChanges seem to have decreased, but not by much. Now I get ImgViewChange=1552 and PaintHandler=776.
I'm not even sure that it's because my change, because these numbers seem almost random. I mean I have no idea why it happens, who triggers those events for regular number of times, and what happens when they are triggered so many more times?
When I add the layers to the imgView, all 25 of them, I leave them where they are added: in the center of the View. After they are all added, I start click-in on each and I drag them away from the center so they would all be visible.
Now, the first 15-20 layers that I click on and drag from the center, the 2 numbers that I monitor (number of times those two events get fired) is a lot lower that the numbers I get after the 20th layer that I want to drag from the center. And after they are all dispersed in the view, it begins: some layers are click-able in real-time, others take a while to get selected and my count of event-fires are through the roof.
EDIT
I found my problem.
With this I reduced the number of events that get fired to the normal amount. So the solution was to add BeginUpdate and EndUpdate for the Assignment of the layer's bitmap...
So in the PaintHandler I changed the code to:
(Sender as TBitmapLayer).BeginUpdate;
(Sender as TBitmapLayer).Bitmap.Assign(bmp32);
(Sender as TBitmapLayer).EndUpdate;
And now my layers behave like they should. Thank you SilverWarrior for pointing me into the right direction. Please convert your comment into an answer so I can accept it.
The BeginUpdate/EndUpdate are beneficial to reduce the number of ImgViewChange events as documented here
OnChange is an abstract change notification event, which is called by
some of the descendants of TCustomPaintBox32 immediately after changes
have been made to their contents. In TCustomImage32, for example, this
includes redirection of change notification events from the contained
bitmap and from layers. This event, however, is not called by
TCustomPaintBox32 control itself, unless you call the Changed method
explicitly. Change notification may be disabled with BeginUpdate call
and re-enabled with EndUpdate call.
However, there are other problems in your code:
In AddSpecialLineLayer() you create a new TBitmapLayer, set the size and location of its Bitmap and set its OnPaint handler to PaintGeamOrizHandler(). This is not a problem in itself, but it's the first step towards the real problem.
In PaintGeamOrizHandler() the main idea seems to be to draw some shapes, but the way it is done is very time consuming for no benefit.
First you create a new TBitmap32. Then you draw the shapes on this bitmap. Then you assign it to the layers bitmap. Finally you free the bitmap just created.
All of the shape drawing could instead have been done directly to the layers bitmap. The "temporary" bitmap is just a waist of CPU resources.
But another question is, why are the shapes drawn every time the layer needs to be painted? The bitmap of the TBitmapLayer is perfectly capable of retaining the shapes until you specifically need to change them. Instead you could have drawn the shapes in a separate procedure as a one time effort when you created the layer (and/or when you need to change the shapes).
You may also want to explore the documentation for paint stages and perhaps repaint optimizer
Related
I am using the free JansDraw Components and when the executable runs, it throws AV error. I could locate the error to specifically the loop block of the code (not the initial block of assignment statements).
procedure TjanDrawImage.colorcircle(var bm:TBitmap;center:tpoint;radius,mode:integer);
var p,p0,p1:pbytearray;
dx,x,y,w,h,i,j,sum,c:integer;
cm,tm:tbitmap;
Rs,Rd:trect;
begin
x:=center.x;
y:=center.y;
w:=bm.width;
h:=bm.height;
cm:=tbitmap.create;
cm.width:=2*radius;
cm.height:=2*radius;
cm.PixelFormat :=FPixelFormat;
tm:=tbitmap.create;
tm.width:=2*radius;
tm.height:=2*radius;
tm.PixelFormat :=FPixelFormat;
tm.canvas.brush.color:=clblack;
tm.canvas.Ellipse (0,0,tm.width-1,tm.height-1);
tm.transparent:=true;
tm.TransparentColor :=clblack;
Rd:=rect(0,0,cm.width,cm.height);
Rs:=rect(x-radius,y-radius,x+radius,y+radius);
cm.canvas.CopyRect (Rd,bm.canvas,RS);
for j:=0 to cm.height-1 do begin
p:=cm.scanline[j];
if j>0 then p0:=cm.scanline[j-1];
if j<(h-1) then p1:=cm.scanline[j+1];
for i:=0 to cm.width-1 do begin
case mode of
0: //blue
begin
p[i*3+1]:=0;
p[i*3+2]:=0;
end;
1: //green
begin
p[i*3]:=0;
p[i*3+2]:=0;
end;
2: //red
begin
p[i*3]:=0;
p[i*3+1]:=0;
end;
3: //not blue
begin
p[i*3]:=0;
end;
4: //not green
begin
p[i*3+1]:=0;
end;
5: //not red
begin
p[i*3+2]:=0;
end;
6: //half blue
begin
p[i*3]:=p[i*3]*9 div 10;
end;
7: //half green
begin
p[i*3+1]:=p[i*3+1]*9 div 10;
end;
8: //half red
begin
p[i*3+2]:=p[i*3+2]*9 div 10;
end;
9:// darker
begin
p[i*3]:=round(p[i*3]*10 /11);
p[i*3+1]:=round(p[i*3+1]*10 / 11);
p[i*3+2]:=round(p[i*3+2]*10 /11);
end;
10:// lighter
begin
p[i*3]:=round(p[i*3]*11 / 10);
p[i*3+1]:=round(p[i*3+1]*11 / 10);
p[i*3+2]:=round(p[i*3+2]*11 / 10);
end;
11:// gray
begin
sum:=round((p[i*3]+p[i*3+1]+p[i*3+2])/ 3);
p[i*3]:=sum;
p[i*3+1]:=sum;
p[i*3+2]:=sum;
end;
12:// mix
begin
c:=p[i*3];
p[i*3]:=p[i*3+1];
p[i*3+1]:=p[i*3+2];
p[i*3+2]:=c;
end;
13://smooth
begin
if ((j>0) and (j<(h-1))and (i>0)and (i<(w-1))) then begin
p[i*3]:=round((p[(i-1)*3]+p[(i+1)*3]+p0[i*3]+p1[i*3]) /4);
p[i*3+1]:=round((p[(i-1)*3+1]+p[(i+1)*3+1]+p0[i*3+1]+p1[i*3+1]) /4);
p[i*3+2]:=round((p[(i-1)*3+2]+p[(i+1)*3+2]+p0[i*3+2]+p1[i*3+2]) / 4);
end;
end;
end;
end;
end;
cm.canvas.Draw (0,0,tm);
cm.transparent:=true;
cm.transparentcolor:=clwhite;
bm.Canvas.draw(x-radius,y-radius,cm);
cm.free;
tm.free;
end;
A linked question which is helpful is this - implementing scan line of bitmap corectly. It suggests to cast the pointers to NativeInt. The OP changed his code after answers, making it difficult to correlate old code with new code. I understand that my problem is due to some hard coded sequential access of pointers but I am really beginner to make sense of scan line or pointers. If you help me port this, these components will continue to be useful to everyone.
update after comment from #Renate Schaaf:
all the brush modes of the janDrawImage are working now, except for the below one. I was expecting a bigger problem but that didn't turn out to be the case. So modified the title of the question. #Renate Schaaf Can you please help fix the below one too. I tried but failed.
procedure TjanDrawImage.rimple(src,dst:tbitmap;amount:extended);
var ca,sa,a,dx,dy,r,rx,ry,sr,fr:extended;
w,h,x,y,cx,cy,i,j,c,ci:NativeInt;
p1,p2:pbytearray;
begin
w:=src.width;
h:=src.height;
cx:=w div 2;
cy:=h div 2;
if amount<1 then amount:=1;
fr:=cx/amount;
for y:=0 to h-1 do begin
p1:=src.ScanLine[y];
for x:=0 to w-1 do begin
dx:=x-cx;dy:=-(y-cx);
r:=sqrt(sqr(dx)+sqr(dy));
sr:=fr*sin(r/cx*amount*2*pi);
if (r+sr<cx) and (r+sr>0) then begin
a:=arctan2(dy,dx);
sincos(a,sa,ca);
i:=cx+round((r+sr)*ca);
j:=cy+round((r+sr)*sa);
p2:=dst.scanline[j];
c:=x*3;ci:=i*3;
p2[ci]:=p1[c];
p2[ci+1]:=p1[c+1];
p2[ci+2]:=p1[c+2];
end;
end;
end;
end;
When you do scanline operations, you always need to make sure that your pixel location is within the boundaries of your bitmap, particularly if you make geometric transformations.
So, in the last example you must clamp j to [0,h-1] and i to [0,w-1] using max(min(..)).
Also, you should set the size and pixelformat of src and dst to the same at the beginning.
I didn't really bother to find out what this ripple is supposed to do, but when I run an example it doesn't look like it's doing whatever it does right. For geometric transformations you need to work backwards, running through the pixels of the destination and figure out which pixel of the source needs to go there. Otherwise you end up with a destination that has holes, like here.
Edit:
Since I'm stuck with my project: I think this is the routine you really want to use. Note that I just switched the roles of src and dst and corrected some errors. It now adds a water ripple effect to the bitmap.
procedure rimple(src, dst: TBitmap; amount: extended);
var
ca, sa, a, dx, dy, r, sr, fr: extended;
w, h, x, y, cx, cy, i, j, c, ci: NativeInt;
p1, p2: pbytearray;
bits: integer;
begin
Assert(src.PixelFormat in [pf24bit, pf32bit],
'Device independent bitmap needed');
dst.PixelFormat := src.PixelFormat;
bits := 3;
if src.PixelFormat = pf32bit then
bits := 4;
w := src.width;
h := src.height;
dst.SetSize(w, h);
cx := w div 2;
cy := h div 2;
// in case somebody enters a negative amount
if abs(amount) < 1 then
amount := 1;
fr := cx / amount;
for y := 0 to h - 1 do
begin
// switched src and dst
p1 := dst.scanline[y]; // src.scanline[y];
for x := 0 to w - 1 do
begin
dx := x - cx;
// Corrected from dy:=-(y-cx)
dy := (y - cy);
r := sqrt(sqr(dx) + sqr(dy));
sr := fr * sin(r / cx * amount * 2 * pi);
// Omitted the following check
// if (r + sr < cx) and (r + sr > 0) then
begin
a := arctan2(dy, dx);
sincos(a, sa, ca);
i := max(min(cx + round((r + sr) * ca), w - 1), 0);
j := max(min(cy + round((r + sr) * sa), h - 1), 0);
// switched src and dst
p2 := src.scanline[j];
c := x * bits;
ci := i * bits;
p1[c] := p2[ci];
p1[c + 1] := p2[ci + 1];
p1[c + 2] := p2[ci + 2];
end;
end;
end;
end;
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 6 years ago.
Improve this question
I want to created a small application, which should move images smoothly into the desktop coordinates.
I was wondering how can I limit that the image remains inside the desktop?
I have try like that to move the image:
procedure TForm1.Timer1Timer(Sender: TObject);
Var
X, Y :Integer;
begin
X:= random(2+1);
Y:= random(2+1);
Image1.Left:= Image1.Left + X;
Image1.Top:= Image1.Top + Y;
Image1.Refresh;
end;
Any help is appreciated.
Thanks.
Is you image placed over Windows Desktop - or over you TForm1 ? I guess the latter. So you would have to care about the WINDOW size, not the DESKTOP size.
type TForm1=class(TForm)
....
private
ImageMovesLeft, ImageMovesUp: Boolean;
end;
.....
procedure TForm1.Timer1Timer(Sender: TObject);
Var
dX, dY, NewLeft, NewTop :Integer;
FormSize: TRect;
begin
dX := random(2+1); // did you really mean "random(3)" or "1+random(2)" ???
dY := random(2+1);
FormSize := Self.ClientRect;
FormSize.Bottom := FormSize.Bottom - Image1.Height - 1;
FormSize.Right := FormSize.Right - Image1.Width - 1;
// now we have the "box" in which the Image's topleft corner must be
If ImageMovesLeft then dX := -dX;
If ImageMovesUp then dY := -dY;
NewLeft := Image1.Left + dX;
NewTop := Image1.Top + dY;
if ( NewTop >= FormSize.Top ) and ( NewTop <= FormSize.Bottom ) then begin
Image1.Top := NewTop; // we fit into the allowed box
end else begin
ImageMovesUp := not ImageMovesUp; // we did not fit and have to bounce back
end;
if ( NewLeft >= FormSize.Left ) and ( NewLeft <= FormSize.Right ) then begin
Image1.Left := NewLeft; // we fit into the allowed box
end else begin
ImageMovesLeft := not ImageMovesLeft; // we did not fit and have to bounce back
end;
end;
PS. In an unlikely case you really do need the Windows DESKTOP coordinates and not your Form coordinates you can get them at
http://docwiki.embarcadero.com/Libraries/XE7/en/Vcl.Forms.TScreen.DesktopRect
But to use that information you would have to solve another problem - how to place your Image1 over desktop and not over the form, which is much more complex for you. So I do not think you really meant Desktop....
UPD. The code above if very simple and easy to understand, but it makes few implicit assumptions to work correctly. Those assumptions are:
The window(form) size is fixed once for all, it would never be resized.
The imagebox size is fixed once for all, it would never be resized.
The window is larger than an imagebox in both dimensions.
Only our procedure can move the imagebox, there is nothing else that can move it.
Given those assumptions ( natural for fixed screen size computers many many years ago ) there is no need to analyze if the moving object got too left o too right, too above or too below. It only matters if the new coordinate is correct or not - if it is no more correct, then "bouncing" - reversing the direction without looking which one it was - is enough. But if, for example, user can suddenly resize the window and make it so small that the imagebox would fall outside of it - then this method would stuck infinitely switching directions, because the coordinates would always be incorrect given those very small changes "smooth" movement allows to have.
To adapt to possible sudden and large changes in geometry there can be a number of approaches, but the most simple one would be to make two changes: distinction between two cases of wrong coordinates (too little or too large now would be different cases) and instant jumps of the image into the allowed box when needed, even if the jump would be large and not-smooth.
procedure TForm1.Timer1Timer(Sender: TObject);
var
dX, dY, NewLeft, NewTop :Integer;
FormSize: TRect;
begin
dX := random(2+1); // did you really mean "random(3)" or "1+random(2)" ???
dY := random(2+1);
FormSize := Self.ClientRect;
FormSize.Bottom := FormSize.Bottom - Image1.Height - 1;
FormSize.Right := FormSize.Right - Image1.Width - 1;
// now we have the "box" in which the Image's topleft corner must be
If ImageMovesLeft then dX := -dX;
If ImageMovesUp then dY := -dY;
NewLeft := Image1.Left + dX;
NewTop := Image1.Top + dY;
if NewLeft > FormSize.Right then begin
ImageMovesLeft := True;
NewLeft := FormSize.Right;
end;
if NewLeft < FormSize.Left then begin
ImageMovesLeft := False;
NewLeft := FormSize.Left;
end;
if NewTop > FormSize.Bottom then begin
ImageMovesUp := True;
NewTop := FormSize.Bottom;
end;
if NewTop < FormSize.Top then begin
ImageMovesUp := False;
NewTop := FormSize.Top;
end;
Image1.Top := NewTop;
Image1.Left := NewLeft;
end;
UPD. Several controls moving.
type TControlledObject = record
obj: TControl;
MovesLeft, MovesUp: Boolean;
end;
type TForm1=class(TForm)
....
private
images: array of TControlledObject;
end;
procedure TForm1.FormShow(....);
begin
SetLength(images, 3);
with images[0] do begin
obj := Self.Image1;
MovesLeft := random >= 0.5;
MovesUp := random >= 0.5;
end;
with images[1] do begin
obj := Self.Image2;
MovesLeft := random >= 0.5;
MovesUp := random >= 0.5;
end;
with images[2] do begin
obj := Self.Image3;
MovesLeft := random >= 0.5;
MovesUp := random >= 0.5;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
i: Integer
begin
for i := 0 to Length(images)-1 do
MoveImage(images[i]);
end;
procedure TForm1.MoveImage(var ImgRec: TControlledObject);
var .....
begin
dX := random(2+1); // did you really mean "random(3)" or "1+random(2)" ???
dY := random(2+1);
FormSize := Self.ClientRect;
FormSize.Bottom := FormSize.Bottom - ImgRec.obj.Height - 1;
FormSize.Right := FormSize.Right - ImgRec.obj.Width - 1;
// now we have the "box" in which the Image's topleft corner must be
If ImgRec.MovesLeft then dX := -dX;
If ImgRec.MovesUp then dY := -dY;
....and so on. Finish the conversion from one to many as your home task.
I draw a dotted line on a layer of an ImgView32. Later, I want to save each layer as transparent PNGs.
For any other layer that I have, the saving works just fine. But for the drawing layer, it does not.
In order to make the question simpler to understand, take the example code from the gr32 library, more specifically the Layers example. One of the options in its main menu is to add a custom drawing layer (New Custom Layer -> Simple Drawing Layer).
Then try to save that layer as a transparent PNG image and you will end up with a corrupted PNG file (you can't open it with any other picture viewer like for example Paint.net or Microsoft Photo Viewer). Same thing happens if you try to save the layer's bitmap32 as a bitmap as you can see in the bellow code...
I tried two approaches for saving Bitmap32 as a transparent PNG, so the first one is as follows:
procedure TMainForm.SavePNGTransparentX(bm32:TBitmap32; dest:string);
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
function IsBlack(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 0) and
(TColor32Entry(Color32).G = 0) and
(TColor32Entry(Color32).R = 0);
end;
function IsWhite(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 255) and
(TColor32Entry(Color32).G = 255) and
(TColor32Entry(Color32).R = 255);
end;
begin
bm32.ResetAlpha;
for Y := 0 to bm32.Height-1 do
for X := 0 to bm32.Width-1 do
begin
// if IsWhite(bm32.Pixel[X, Y]) then
// bm32.Pixel[X,Y]:=Color32(255,255,255, 0);
if IsBlack(bm32.Pixel[X, Y]) then
bm32.Pixel[X,Y]:=Color32( 0, 0, 0, 0);
end;
Png:= TPortableNetworkGraphic32.Create;
try
Png.Assign(bm32);
Png.SaveToFile(dest);
finally
Png.Free;
end;
end;
So the above method works if I have a PNG loaded into the layer like this:
mypng := TPortableNetworkGraphic32.Create;
mypng.LoadFromStream(myStream);
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
mypng.AssignTo(B.Bitmap);
...
But as soon as I try to save the layer created with the code from the Layers example, the result is corrupted.
Even if I try to save the layer as bitmap like this (though this is not my intention since I need them to be PNG):
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
the same corruption occurs.
So, it's not like I receive an exception or anything... it just gets saved corrupted somehow;
I also tried other ways to save the Bitmap32 as transparent PNG, like for instance the GR32_PNG approach:
function SaveBitmap32ToPNG (sourceBitmap: TBitmap32;transparent: Boolean;bgColor32: TColor32;filename: String;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): boolean;
var png: TPNGImage;
begin
result := false;
try
png := Bitmap32ToPNG (sourceBitmap,false,transparent,WinColor(bgColor32),compressionLevel,interlaceMethod);
try
png.SaveToFile (filename);
result := true;
finally
png.Free;
end;
except
result := false;
end;
end;
where
function Bitmap32ToPNG (sourceBitmap: TBitmap32;paletted, transparent: Boolean;bgColor: TColor;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): TPNGImage; // TPNGObject
var
bm: TBitmap;
png: TPNGImage;//TPngObject;
TRNS: TCHUNKtRNS;
p: pngImage.PByteArray;
x, y: Integer;
begin
Result := nil;
png := TPngImage.Create; // TPNGObject
try
bm := TBitmap.Create;
try
bm.Assign (sourceBitmap); // convert data into bitmap
// force paletted on TBitmap, transparent for the web must be 8bit
if paletted then
bm.PixelFormat := pf8bit;
png.interlaceMethod := interlaceMethod;
png.compressionLevel := compressionLevel;
png.Assign(bm); // convert bitmap into PNG
// this is where the access violation occurs
finally
FreeAndNil(bm);
end;
if transparent then begin
if png.Header.ColorType in [COLOR_PALETTE] then begin
if (png.Chunks.ItemFromClass(TChunktRNS) = nil) then png.CreateAlpha;
TRNS := png.Chunks.ItemFromClass(TChunktRNS) as TChunktRNS;
if Assigned(TRNS) then TRNS.TransparentColor := bgColor;
end;
if png.Header.ColorType in [COLOR_RGB, COLOR_GRAYSCALE] then png.CreateAlpha;
if png.Header.ColorType in [COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA] then
begin
for y := 0 to png.Header.Height - 1 do begin
p := png.AlphaScanline[y];
for x := 0 to png.Header.Width - 1
do p[x] := AlphaComponent(sourceBitmap.Pixel[x,y]); // TARGB(bm.Pixel[x,y]).a;
end;
end;
end;
Result := png;
except
png.Free;
end;
end;
but using this approach, I get an EAccessViolation when trying to save this particular layer. For any other layers (not drawing ones), it does not crash my project except for this custom drawing one.
The access violation occurs at this line:
png.Assign(bm);
inside the Bitmap32ToPNG function
Do you have any idea why that happens and how can I prevent this?
EDIT
I tried using TBitmapLayer instead, because the TPositionedLayer might lack the Bitmap32 for some reason.
So my code is like this:
// adding a BitmapLayer and setting it's onPaint event to my handler
procedure TMainForm.Mynewlayer1Click(Sender: TObject);
var
B: TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.SetSize(100,200);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
with ImgView.Bitmap do
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
OnPaint := PaintMy3Handler;
except
Free;
raise;
end;
Selection := B;
end;
// and the PaintHandler is as follows:
procedure TMainForm.PaintMy3Handler(Sender: TObject;Buffer: TBitmap32);
var
Cx, Cy: Single;
W2, H2: Single;
const
CScale = 1 / 200;
begin
if Sender is TBitmapLayer then
with TBitmapLayer(Sender).GetAdjustedLocation do
begin
// Five black pixels, five white pixels since width of the line is 5px
Buffer.SetStipple([clBlack32, clBlack32, clBlack32, clBlack32, clBlack32,
clWhite32, clWhite32, clWhite32, clWhite32, clWhite32]);
W2 := (Right - Left) * 0.5;
H2 := (Bottom - Top) * 0.5;
Cx := Left + W2;
Cy := Top + H2;
W2 := W2 * CScale;
H2 := H2 * CScale;
Buffer.PenColor := clRed32;
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-2,Top);
Buffer.LineToFSP(Cx-2 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-1,Top);
Buffer.LineToFSP(Cx-1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx,Top);
Buffer.LineToFSP(Cx , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+1,Top);
Buffer.LineToFSP(Cx+1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+2,Top);
Buffer.LineToFSP(Cx+2 , Bottom);
end;
end;
Keep in mind that I use the default layers demo application. So this is just added code. I did not remove nor change anything in the demo code.
So I create a new layer (TBitmapLayer) and onPaint I do my drawing. In the end I want to save the contents of that layer as PNG. But it seems like the onPaint might draw somewhere else instead of the actual layer. Otherwise I do not understand why the saved image is empty.
So this time the resulted PNG is not corrupted, but it is empty...
The error is in the fact that the examples create TPositionedLayer layers which do not hold a bitmap. You can not type cast this layer type into a TBitmapLayer and expect it to create a bitmap image of the layer, as you do in this code:
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
I assume you do something similar to save to .png file, although you did not show that code.
The examples (with TPositionedLayer layers) use ImgView.Buffer for drawing on the screen. You can save that to a .png file like this:
SavePNGTransparentX(ImgView.Buffer, 'c:\tmp\imgs\buffer.png');
but I don't expect that to work satisfactorily for your separate layer images.
What is the reason you don't use TBitmapLayers as you have done before?
Edit after comments by user1137313
Inspired by the solution you found yourself (ref. your comment) I suggest the following which paints the layer to the extra bitmap only when needed for saving.
Starting from a menu item
procedure TMainForm.mnFileSaveClick(Sender: TObject);
begin
SaveLayerToPng(ImgView.Layers[ImgView.Layers.Count-1], 'c:\tmp\imgs\buffer.png');
end;
You possibly want to call SaveLayerToPng() in a loop if you save several layers at the same time, and also change the file name(s) as needed.
Then the SaveLayerToPng() procedure
procedure TMainForm.SaveLayerToPng(L: TCustomLayer; FileName: string);
var
bm32: TBitmap32;
begin
bm32:= TBitmap32.Create;
try
bm32.SetSizeFrom(ImgView.Buffer);
PaintSimpleDrawingHandler(L, bm32);
SavePNGTransparentX(bm32, FileName);
finally
bm32.Free;
end;
end;
It calls the existing PaintSimpleDrawingHandler(Sender: TObject; buffer: TBitmap32) procedure to paint to bm32 which it then passes on to `SavePNGTransparentX() for actual saving.
I used the paint handler of the Graphics32 example, but your PaintMy3Handler() can be used just as well.
The end result is same as your solution, just that the extra TBitmap32 is only painted when the file is to be saved.
I have trouble keeping a TListbox in sync with a TList. Each time an item is added to a generic TList, OnNotify is called and the callback calls just one procedure: create_gradients. Its code is below:
procedure TColor_Dialog.create_gradients;
var Editor: TGradient_Editor;
eGradient: Int32;
y: single;
s: string;
begin
List_Names.Clear;
List_Gradients.Clear;
for eGradient := 0 to FColor_Editor.nGradients - 1 do
begin
List_Names.Items.Add (FColor_Editor [eGradient].Check_Rainbow.Text);
end; // for
List_Gradients.BeginUpdate;
try
for eGradient := 0 to FColor_Editor.nGradients - 1 do
begin
Editor := FColor_Editor [eGradient];
y := (eGradient + 1) * Editor.Height;
Editor.Position.Y := y;
s := Editor.Check_Rainbow.Text;
List_Gradients.AddObject (Editor);
end; // for
finally
List_Gradients.EndUpdate;
end; // try..finally
end; // create_gradients //
As you see it simply enumerates all items in the list. Each item in the list is a TGradient_Editor which in turn has TFrame as a parent. On the parent are some FMX controls as combolorboxes, an image and a checkbox (Check_Rainbow). Check_Rainbow.Text is used for identification purposes. When the gradient editor is created, it creates a unique name from frame_%s where %s is a sequence number that is incremented each time a gradient editor is created. Owner and Parent are both List_Gradients.
From the image above you can see what happens. the listbox on the right is added for checking and just shows the text's, which is the correct sequence by the way. When I use the debugger to follow the addition of the gradient editors to List_Gradient they are processed in the same order. But the order of the gradient editors is wrong. I have to mention that the aligment of the gradient editors is alTop. I added even some code to ensure that the editor is Positioned at the very bottom of the List_Gradients.
I appear not to understand something. I cannot imagine that sequential adding to a TListBox cannot result in the correct order. What am I doing wrong?
Try this instead:
procedure TColor_Dialog.create_gradients;
var
Editor: TGradient_Editor;
eGradient: Int32;
y: single;
begin
List_Names.Clear;
List_Gradients.Clear;
for eGradient := 0 to FColor_Editor.nGradients - 1 do
begin
List_Names.Items.Add (FColor_Editor[eGradient].Check_Rainbow.Text);
end;
List_Gradients.BeginUpdate;
try
y := 0.0; // or whatever value you want to start at...
for eGradient := 0 to FColor_Editor.nGradients - 1 do
begin
Editor := FColor_Editor[eGradient];
Editor.Position.Y := y;
List_Gradients.AddObject(Editor);
y := y + Editor.Height;
end;
finally
List_Gradients.EndUpdate;
end;
end;
As requested I moved the answer to this section. The correct code is:
procedure TColor_Dialog.create_gradients;
var Editor: TGradient_Editor;
eGradient: Int32;
y: single;
begin
List_Gradients.BeginUpdate;
try
List_Gradients.Clear;
y := 0;
for eGradient := 0 to FColor_Editor.nGradients - 1 do
begin
Editor := FColor_Editor [eGradient];
Editor.Position.X := 0;
Editor.Position.Y := y;
Editor.Width := List_Gradients.Width;
List_Gradients.AddObject (Editor);
y := y + Editor.Height;
end; // for
finally
List_Gradients.EndUpdate;
end; // try..finally
end; // create_gradients //
and not using any alignment anymore. Adding Objects to a TListBox is a real nice feature of FMX. However, be prepared that things sometimes work differently than you expect. For one thing: objects are not positioned in the same way as strings.
Ok, so I'm pretty new to Delphi (as you'll see from my code - try not to laugh too hard and hurt yourselves), but I've managed to make a little desktop canvas color picker. It works, kinda, and that's why I'm here :D
It seems to be leaking. It starts off using about 2 MB of memory, and climbs up about 2 kB per second until it reaches about 10 MB after 10 minutes or so. On my dual core 2.7 ghz cpu, it's using anywhere from 5% to 20% cpu power, fluctuating. My computer became unresponsive after running it for about 10 minutes without stopping the timer.
You can see in the source code below that I am freeing the TBitmap (or trying to, not sure if it's doing it, doesn't seem to be working).
procedure TForm1.Timer1Timer(Sender: TObject);
begin
GetCursorPos(MousePos);
try
Canvas1 := TCanvas.Create;
Canvas1.Handle := GetDC(0);
Pxl := TBitmap.Create;
Pxl.Width := 106;
Pxl.Height := 106;
W := Pxl.Width;
H := Pxl.Height;
T := (W div 2);
L := (H div 2);
Zoom := 10;
Rect1 := Rect(MousePos.X - (W div Zoom), MousePos.Y - (H div Zoom), MousePos.X + (W div Zoom), MousePos.Y + (H div Zoom));
Rect2 := Rect(0, 0, H, W);
Pxl.Canvas.CopyRect(Rect2, Canvas1, Rect1);
Pxl.Canvas.Pen.Color := clRed;
Pxl.Canvas.MoveTo(T, 0);
Pxl.Canvas.LineTo(L, H);
Pxl.Canvas.MoveTo(0, T);
Pxl.Canvas.LineTo(W, L);
Image1.Picture.Bitmap := Pxl;
finally
Pxl.Free;
end;
try
Pxl2 := TBitmap.Create;
Pxl2.Width := 1;
Pxl2.Height := 1;
Box1 := MousePos.X;
Box2 := MousePos.Y;
BitBlt(Pxl2.Canvas.Handle, 0, 0, 1, 1, GetDC(0), Box1, Box2, SRCCOPY);
C := Pxl2.Canvas.Pixels[0, 0];
Coord.Text := IntToStr(Box1) + ', ' + IntToStr(Box2);
DelColor.Text := ColorToString(C);
HexColor.Text := IntToHex(GetRValue(C), 2) + IntToHex(GetGValue(C), 2) + IntToHex(GetBValue(C), 2);
RGB.Text := IntToStr(GetRValue(C)) + ', ' + IntToStr(GetGValue(C)) + ', ' + IntToStr(GetBValue(C));
Panel1.Color := C;
finally
Pxl2.Free;
end;
end;
procedure TForm1.OnKeyDown(Sender: TObject; var Key: Char);
begin
if Key = #13 then
begin
if Timer1.Enabled then
begin
Timer1.Enabled := false;
Panel2.Caption := 'Got it! Press Enter to reset.';
end
else
begin
Timer1.Enabled := true;
Panel2.Caption := 'Press Enter to lock color.';
end;
end;
end;
Note: The timer is set to run every 10 ms, if that makes any difference.
ANY and all help figuring out why this is leaking and using so much resources would be greatly appreciated!
You can nab the project here if you want it (Delphi 2010): http://www.mediafire.com/file/cgltcy9c2s80f74/Color%20Picker.rar
Thanks!
You never free your Canvas1 object, leaking both process heap and GDI obj. handles.
As user said above, TCanvas instance which owns DC of desktop window never freed, not releasing DC. I found another DC leak here:
BitBlt(Pxl2.Canvas.Handle, 0, 0, 1, 1, GetDC(0), Box1, Box2, SRCCOPY);
^^^^^^^^
This not solves memory leak but explains why Windows becomes unresponsive after 20 minutes (assuming previous issue has been patched already)
Every GetDC call requires ReleaseDC counter-part. GDI objects in the fact are even more precious than memory.
Ok, I found the solution (finally) after tinkering around with it a bit and following a few of the pointers on here. No one really hit it right on the head, but everyone was on the right track. The problem was that I was calling GetDC() inside the FUNCTION (and in earlier versions the timer procedure as well). Moving it outside of "try ... finally" while keeping it in the function (as suggested) still didn't yield results, but it was getting close and gave me the idea that actually worked. So I moved it a bit further away - into the Form's OnCreate event.
Here's the final code:
function DesktopColor(const X, Y: Integer): TColor;
begin
Color1 := TCanvas.Create;
Color1.Handle := DC;
Result := GetPixel(Color1.Handle, X, Y);
Color1.Free;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
GetCursorPos(Pos);
Rect1 := Rect(Pos.X - (W div Zoom), Pos.Y - (H div Zoom), Pos.X + (W div Zoom), Pos.Y + (H div Zoom));
Rect2 := Rect(0, 0, H, W);
Pxl.Canvas.CopyRect(Rect2, Canvas1, Rect1);
Pxl.Canvas.Pen.Color := clRed;
Pxl.Canvas.MoveTo(T, 0);
Pxl.Canvas.LineTo(L, H);
Pxl.Canvas.MoveTo(0, T);
Pxl.Canvas.LineTo(W, L);
Image1.Picture.Bitmap := Pxl;
Coord.Text := IntToStr(Pos.X) + ', ' + IntToStr(Pos.Y);
C := DesktopColor(Pos.X, Pos.Y);
DelColor.Text := ColorToString(C);
HexColor.Text := IntToHex(GetRValue(C), 2) + IntToHex(GetGValue(C), 2) + IntToHex(GetBValue(C), 2);
RGB.Text := IntToStr(GetRValue(C)) + ', ' + IntToStr(GetGValue(C)) + ', ' + IntToStr(GetBValue(C));
Panel1.Color := C;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Pxl := TBitmap.Create;
Canvas1 := TCanvas.Create;
DC := GetDC(0);
Pxl.Width := 106;
Pxl.Height := 106;
Canvas1.Handle := DC;
W := Pxl.Width;
H := Pxl.Height;
T := (W div 2);
L := (H div 2);
Zoom := 10;
Timer1.Enabled := True;
end;
procedure TForm1.OnKeyDown(Sender: TObject; var Key: Char);
begin
if Key = #13 then
begin
if Timer1.Enabled then
begin
Timer1.Enabled := false;
Panel2.Caption := 'Got it! Press Enter to reset.';
end
else
begin
Timer1.Enabled := true;
Panel2.Caption := 'Press Enter to lock color.';
end;
end;
end;
procedure TForm1.OnDestroy(Sender: TObject);
begin
ReleaseDC(0, Canvas1.Handle);
ReleaseDC(0, Color1.Handle);
end;
And the final tally: drumroll CPU usage: 00% idle, 01% spikes if you move the mouse fast enough; Memory usage: ~3,500 kB solid, remaining unchanged. I even bumped the timer up from 10 ms to 5 ms and still get the same numbers.
Here's the final project with all the aforementioned fixes: http://www.mediafire.com/file/ebc8b4hzre7q6r5/Color%20Picker.rar
Thanks to everyone who helped, I greatly do appreciate it! I'm going to go ahead and open source the project for everyone who stumbles across this post and finds it useful. No license, do with it whatever you will. No credit necessary, but if you want to leave my name in there, that would be cool :D
Some comments on your code in DesktopColor
If the creation or GetDC fails, no resource will be locked and the unlock or free will generate an error, because you are trying to free a resource that does not exist.
The rule is that initialization should always be done before the try, because otherwise you will not know whether is is safe to deconstruct the entry.
In this case it's not a huge issue because GetxDC/ReleaseDC does not generate exceptions, it just gives back a 0 if unsuccesful.
Secondly I recommend putting in tests to make sure that your calls using DC's are succesful. When using Delphi objects you don't need that because the exceptions will take care of that, but Windows DC do not use exceptions, so you'll have to do your own testing. I recommend using assertions, because you can enable then in debug time and disable them when the program is debugged.
But because GetxDC never generates exceptions and to be consistent I'd recommend changing the code into:
{$C+} //enable assertions for debug purposes.
//or {$C-} //Disable assertions in production code
function DesktopColor(const X, Y: Integer): TColor;
var
Color: TCanvas;
Handle: THandle;
begin
Color := TCanvas.Create;
//If the create fails GetWindowsDC will not get stored anywhere
//and we cannot free it.
Handle:= GetWindowDC(GetDesktopWindow);
try
Assert(Handle <> 0);
Color.Handle := Handle; //Will generate an exception if create failed.
Handle := 0;
Result := GetPixel(Color.Handle, X, Y);
finally
//Free the handle if it wasn't transfered to the canvas.
if Handle <> 0 then ReleaseDC(0, Handle);
Color.Free; //TCanvas.Destroy will call releaseDC on Color.handle.
//If the transfer was succesful
end; {tryf}
end;
The same arguments apply to Timer1Timer.
Warning
When you disable assertions Delphi will remove the entire assert statement from your project, so don't put any code with side effects into an assert!
Links:
Assertions: http://beensoft.blogspot.com/2008/02/using-assert.html