Image "fade" in / out (Not opacity) - delphi

I want to "fade" in / out an image. But not opacity-wise.
Pictures say more than words:
Original image:
Desired image:
How can I do that programatically? Not the way like "use Bitmap.Canvas" but the mathematical approach. ("For dummies" if possible ... :D)
I want the image to have a fade-in / -out area, not linear increasing but "curvy". I guess it has something to do with Bezier curves? If yes, how would I setup the points to get a curve like that?
Or what would be your approach here?
Thanks for any help! :)

Here is roughly how you would go about doing it (as you said, you're looking for the logic and not the full implementation)
Create the basic shape outline: Create a partial sine-wave, such that the semi-period (half-wavelength: P1 = L/2) equals the length (x-coordinate size) of your image.
Add Overtones: Add to it another sine-function. This time with wavelength given by P2 = P1 / 2 + rnd where rnd is a random real number in the interval (-P1/4 , +P1 / 4)
Repeat: Now P2 becomes the new P1.
That way you can generate the 'wavy-waves' by modulating the main wave and you will get the top boundary.
You can change the sign and get the lower boundary.
The word you might be looking for (for the shape, i.e.) is Overtones. You could look up more on generating overtones for optics or acoustics.
This example for adding overtones to a straight line would give a better idea. The code above adds up these sinusoidal waves of randomly shortening periods to create the wave-on-wave effect (source)

Thanks again, hnk. You got me the right ideas. :)
I did a little work and ended up with this:
procedure GenerateOverlayEdges(ABitmap: TBitmap; ARadiusX, ARadiusY: Integer);
const
MAX_ANGLE = 90;
var
ShapePosition, ShapeIndex, ShapesCount,
Angle, X, Y, RadiusX, RadiusY, CenterY: Integer;
PolyPoints: Array of TPoint;
begin
ABitmap.Canvas.Pen.Color := clBlack;
ABitmap.Canvas.Brush.Color := clBlack;
//ABitmap.Canvas.Pen.Color := clWhite;
//ABitmap.Canvas.Brush.Color := clWhite;
RadiusX := ARadiusX;
RadiusY := ARadiusY;
CenterY := Round(ABitmap.Height / 2);
ShapesCount := Ceil(CenterY / RadiusY);
for ShapePosition := 1 to 4 do // 1 = TopLeft, 2 = BottomLeft, 3 = TopRight, 4 = BottomRight
for ShapeIndex := 0 to ShapesCount - 1 do // Index of current "stair"
begin
Finalize(PolyPoints);
SetLength(PolyPoints, MAX_ANGLE + 1);
for Angle := 0 to MAX_ANGLE do
begin
case ShapePosition of
1, 3:
begin
RadiusX := Abs(RadiusX);
RadiusY := Abs(RadiusY);
end;
2, 4:
begin
RadiusX := Abs(RadiusX);
RadiusY := -Abs(RadiusY);
end;
end;
X := Trunc(RadiusX * Cos(Angle * 2 * Pi / 360));
Y := Trunc(RadiusY * Sin(Angle * 2 * Pi / 360));
case ShapePosition of
1:
begin
X := X + ShapeIndex * RadiusX;
Y := Y + CenterY - RadiusY - ShapeIndex * RadiusY;
end;
2:
begin
X := X + ShapeIndex * RadiusX;
Y := Y + CenterY - RadiusY + ShapeIndex * Abs(RadiusY);
end;
3:
begin
X := ABitmap.Width - X - ShapeIndex * Abs(RadiusX);
Y := Y + CenterY - RadiusY - ShapeIndex * RadiusY;
end;
4:
begin
X := ABitmap.Width - X - ShapeIndex * Abs(RadiusX);
Y := Y + CenterY + Abs(RadiusY) + ShapeIndex * Abs(RadiusY);
end;
end;
// Add points as part of a Polyon
PolyPoints[Angle] := Point(X, Y);
end;
// Set Y to the Y borders for the very first and last point of the polygon so we will get a "closed" shape
case ShapePosition of
1, 3:
begin
PolyPoints[0] := Point(PolyPoints[0].X, 0);
PolyPoints[Angle - 1] := Point(PolyPoints[Angle - 1].X, 0);
end;
2, 4:
begin
PolyPoints[0] := Point(PolyPoints[0].X, ABitmap.Height);
PolyPoints[Angle - 1] := Point(PolyPoints[Angle - 1].X, ABitmap.Height);
end;
end;
// Draw the poly points ... and fill the background at the same time
ABitmap.Canvas.Polygon(PolyPoints);
end;
Finalize(PolyPoints);
end;
Usage:
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.LoadFromFile('C:\Temp\Osc 2.bmp'); // Original Oscilloscope Image
GenerateOverlayEdges(Bmp, 15, 20);
Bmp.SaveToFile('C:\Temp\Osc 3.bmp');
finally
Bmp.Free;
end;
end;
By changing the RadiusX and RadiusY parameters of the GenerateOverlayEdges function I can adjust the results:
8x8:
15x20:
20x10:

Related

How to print a string grid in the center of a page?

So I want to print a string grid in the middle/center of another printed page that already has a printed/header and footer, but I'm not sure how to print the string grid in the middle/center of the page?
Is there anything in the code below that I can change to do that? Or do I have to do something else completely?
Thanks in advance for all the help!
Example of the type of page I have to print on (In the open part of the page):
Code I've used for one of the other buttons that also prints:
procedure PrintGrid(sGrid: TStringGrid; sTitle: string);
var
X1, X2: Integer;
Y1, Y2: Integer;
TmpI: Integer;
F: Integer;
TR: TRect;
begin
Printer.Title := sTitle;
Printer.BeginDoc;
Printer.Canvas.Pen.Color := 0;
Printer.Canvas.Font.Name := 'Times New Roman';
Printer.Canvas.Font.Size := 12;
Printer.Canvas.Font.Style := [fsBold, fsUnderline];
Printer.Canvas.TextOut(0, 100, Printer.Title);
for F := 1 to sGrid.ColCount - 1 do
begin
X1 := 0;
for TmpI := 1 to (F - 1) do
X1 := X1 + 5 * (sGrid.ColWidths[TmpI]);
Y1 := 300;
X2 := 0;
for TmpI := 1 to F do
X2 := X2 + 5 * (sGrid.ColWidths[TmpI]);
Y2 := 450;
TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.Font.Style := [fsBold];
Printer.Canvas.Font.Size := 7;
Printer.Canvas.TextRect(TR, X1 + 50, 350, sGrid.Cells[F, 0]);
Printer.Canvas.Font.Style := [];
for TmpI := 1 to sGrid.RowCount - 1 do
begin
Y1 := 150 * TmpI + 300;
Y2 := 150 * (TmpI + 1) + 300;
TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.TextRect(TR, X1 + 50, Y1 + 50, sGrid.Cells[F, TmpI]);
end;
end;
Printer.EndDoc;
end;
Kind Regards
PrimeBeat
You can get printer width and height in pixel (Printer.PageWidth and Printer.PageHeight). You can get text with and height using Printer.Canvas.TextExtent. You have your grid so you know the number of rows and column. The rest is some easy computing. You can adapt the font size so that the grid fits in the given space.

Scan Line Out of Range Error for Bitmap. TJanDrawImage Component for a Paint-like Program

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;

How to draw a projectile following specific XY coordinates on a given bitmp under Delphi

In fact i want to draw an animated line from a given Tpoint coordinates to an other Tpoint on a Bitmap canvas for that i tried to read some open sources of OpenGl but task seems to be hard for my little competences in delphi i found this C++ source on github and its exactly what i want to do but under delphi 2009 if the line is animated it could be better for this personnal game prototype.
i tried some functions like -LineDDA- but its is very limited.
i look for somthing like this:
function Make_Projectile( canvas:tcanvas;Start,Target:Tpoint):boolean;
with canvas do
draw the animated_arc_line form start to trget;
if we toutch target then result= true else false...
end;
I tried this piece of code:
procedure ArcByStartEndAngle(Canvas:TCanvas;P0, P1: TPoint; Angle: Double; NSeg: Integer);
var
i: Integer;
len, dx, dy, mx, my, px, py, t, cx, cy, p0x, p0y, an: Double;
xx, yy: Integer;
begin
mx := (P0.x + P1.x) / 2;
my := (P0.y + P1.y) / 2;
dx := (P1.x - P0.x) / 2;
dy := (P1.y - P0.y) / 2;
len := Math.Hypot(dx, dy);
px := -dy / len;
py := dx / len;
if Angle = Pi then
t := 0
else
t := len / Math.Tan(Angle / 2);
cx := mx + px * t;
cy := my + py * t;
p0x := P0.x - cx;
p0y := P0.y - cy;
for i := 0 to NSeg + 1 do
begin
an := i * Angle / (NSeg + 1);
xx := Round(cx + p0x * Cos(an) - p0y * Sin(an));
yy := Round(cy + p0x * Sin(an) + p0y * Cos(an));
Canvas.Pen.Color:=clBlue;
Canvas.Brush.Color:=clRed;
Canvas.Ellipse(xx - 3, yy - 3, xx + 4, yy + 4);
end;
end;
and for these arguments it gives : this result
ArcByStartEndAngle(Form1.Image1.Canvas, Point(574,199),Point(62,202), Pi / 2, 8);
Please left a piece of code that can help or at list a translation of c code above for drawing the desired effect.
the following screenshoot could give an idea : ScreenShoot
enter image description here
**

Drawing oval path through four points

I have a four points that I want to draw oval that path through these four points
I do not want to use [UIBezierPath bezierPathWithOvalInRect:frame];
Because it can not work with rotated rectangle.
I suppose that your 4 points are not arbitrary ones, but middles of edges of rectangle around the ellipse.
You can build path from four Bezier curves to approximate zero-centered unit circle. Example of code here
Then apply to control points affine transformation that transform circle to rotated ellipse with semi-axes A and B, center (CX, CY) and rotation angle Alpha.
For your case, if points are P0..P3, then
A = |P0P2| (distance)
B = |P1P3|
CX = (P0.X + P2.X)/2
CY = (P0.Y + P2.Y)/2
Alpha = ArcTan2(P0.Y - P2.Y, P0.X - P2.X)
I have Delphi code for this problem, hope it could help. Note that closed Bezier path contains 13 points (the last is the same as the first).
procedure CalcRotatedEllipse(CX, CY, A, B: Integer; Alpha: Double; var BezPts: array of TPoint);
const
MP = 0.55228475;
var
CA, SA, ACA, ASA, BCA, BSA: Double;
i, CX2, CY2: Integer;
function TransformPoint(X, Y: Double): TPoint;
begin
Result.X := Round(CX + X * ACA + Y * BSA);
Result.Y := Round(CY - X * ASA + Y * BCA);
end;
begin
Assert(Length(BezPts) = 13);
CA:= Cos(Alpha); SA := Sin(Alpha);
ACA := A * CA; ASA := A * SA;
BCA := B * CA; BSA := B * SA;
CX2 := 2 * CX; CY2 := 2 * CY;
BezPts[0] := TransformPoint(1, 0);
BezPts[1] := TransformPoint(1, MP);
BezPts[2] := TransformPoint(MP, 1);
BezPts[3] := TransformPoint(0, 1);
BezPts[4] := TransformPoint(- MP, 1);
BezPts[5] := TransformPoint(-1, MP);
for i := 0 to 5 do
BezPts[i + 6] := Point(CX2 - BezPts[i].X, CY2 - BezPts[i].Y);
BezPts[12] := BezPts[0];
end;
procedure TForm1.Button3Click(Sender: TObject);
var
Pts: array[0..12] of TPoint;
begin
CalcRotatedEllipse(200, 200, 200, 70, Pi/6, Pts);
Canvas.PolyBezier(Pts);
end;

Delphi 7 : Center form position on multiple monitors

I have a TForm and I set the "Position" to poMainFormCenter.
When I open that form, it is displayed correctly in the center of the Main Form.
But, on multiple screens (2 monitors), when I put the application in the secondary monitor, that form is not displayed in the center of the Main Form.
It is displayed still in the primary monitor, positioned in in the edge of the screen.
There is nothing fancy on my app, I only set that Position property.
Anyone know how to fix this?
I am using Delphi 7 and Windows XP SP3.
Jlouro has the right idea except for looking at the mouse. Screen.Monitors[] contains information on each screen.
I have a standard procedure that goes through the list of monitors and figures out where the upper left corner is to decide what monitor to put it on. While my code does not center (I was simply after ensuring that the window is entirely within whatever monitor it came up on) the idea remains the same. Note that you must consider the case where the window shows up not on ANY monitor--I handle that by throwing it to the first monitor. (This would come about when the saved position is on a monitor that doesn't exist anymore--either removed or running on a different machine.)
It's been a long time since I messed with this, it hasn't given me any trouble in ages and so I haven't tested it on anything more recent than XP/Delphi 7.
Note that this is only about ensuring that the form is visible and entirely on one monitor, there is no attempt to center it.
Function PointInBox(x, y, x1, y1, x2, y2 : Integer) : Boolean;
Begin
Result := (X >= X1) And (X <= X2) And (Y >= Y1) And (Y <= Y2);
End;
Function Overlapping(x11, y11, x12, y12, x21, y21, x22, y22 : Integer) : Boolean;
Var
tx1, ty1, tx2, ty2 : Integer;
Begin
Tx1 := Max(x11, x21);
Tx2 := Min(x12, x22);
Ty1 := Max(y11, y21);
Ty2 := Min(y12, y22);
Result := (Tx1 < Tx2) And (Ty1 < Ty2);
End;
Function GetWhere(Form : TForm) : Integer;
Var
Loop : Integer;
Where : Integer;
Begin
Where := -1;
For Loop := 1 to Screen.MonitorCount do
With Screen.Monitors[Loop - 1] do
If PointInBox(Form.Left, Form.Top, Left, Top, Left + Width - 1, Top + Height - 1) then
Where := Loop - 1;
If Where = -1 then // Top left corner is wild, check for anything
For Loop := 1 to Screen.MonitorCount do
With Screen.Monitors[Loop - 1] do
If Overlapping(Form.Left, Form.Top, Form.Left + Form.Width - 1, Form.Top + Form.Height - 1, Left, Top, Left + Width - 1, Top + Height - 1) then
Where := Loop - 1;
Result := Where;
End;
Procedure GetLimits(Where : Integer; var X, Y, WWidth, WHeight : Integer);
Var
R : TRect;
Begin
If Where < 0 then
Begin
SystemParametersInfo(Spi_GetWorkArea, 0, #R, 0);
X := R.Left;
Y := R.Top;
WWidth := R.Right - R.Left + 1;
WHeight := R.Bottom - R.Top + 1;
End
Else With Screen.Monitors[Where] do
Begin
X := Left;
Y := Top;
WWidth := Width;
WHeight := Height;
End;
End;
Procedure EnsureValidDisplay(Form : TForm);
Var
Left : Integer;
Top : Integer;
Width : Integer;
Height : Integer;
Where : WindowPlacement;
Begin
GetLimits(GetWhere(Form), Left, Top, Width, Height);
Where.Length := SizeOf(Where);
Where.Flags := 0;
GetWindowPlacement(Form.Handle, #Where);
If Form.Left < Left then
Where.rcNormalPosition.Left := Left
Else If Form.Left + Form.Width > Left + Width then
Where.rcNormalPosition.Left := Left + Width - Form.Width;
If Form.Top < Top then
Where.rcNormalPosition.Top := Top
Else If Form.Top + Form.Height > Top + Height then
Where.rcNormalPosition.Top := Top + Height - Form.Height;
If Form.Width > Width then
Where.rcNormalPosition.Right := Where.rcNormalPosition.Left + Width
Else
Where.rcNormalPosition.Right := Where.rcNormalPosition.Left + Form.Width;
If Form.Height > Height then
Where.rcNormalPosition.Bottom := Where.rcNormalPosition.Top + Height
Else
Where.rcNormalPosition.Bottom := Where.rcNormalPosition.Top + Form.Height;
SetWindowPlacement(Form.Handle, #Where);
End;
None of the other answers here mention the cause of the problem in the first place, which is a bug in the VCL. From forms.pas on my system, with some snipping for brevity:
procedure TCustomForm.CMShowingChanged(var Message: TMessage);
var
X, Y: Integer;
NewActiveWindow: HWnd;
CenterForm: TCustomForm;
begin
if (FPosition = poScreenCenter) or
((FPosition = poMainFormCenter) and (FormStyle = fsMDIChild)) then
begin
if FormStyle = fsMDIChild then
begin
X := (Application.MainForm.ClientWidth - Width) div 2;
Y := (Application.MainForm.ClientHeight - Height) div 2;
end else
begin
X := (Screen.Width - Width) div 2;
Y := (Screen.Height - Height) div 2;
end;
if X < 0 then X := 0;
if Y < 0 then Y := 0;
SetBounds(X, Y, Width, Height);
if Visible then SetWindowToMonitor;
end
else if FPosition in [poMainFormCenter, poOwnerFormCenter] then
begin
CenterForm := Application.MainForm;
if (FPosition = poOwnerFormCenter) and (Owner is TCustomForm) then
CenterForm := TCustomForm(Owner);
if Assigned(CenterForm) then
begin
X := ((CenterForm.Width - Width) div 2) + CenterForm.Left;
Y := ((CenterForm.Height - Height) div 2) + CenterForm.Top;
end else
begin
X := (Screen.Width - Width) div 2;
Y := (Screen.Height - Height) div 2;
end;
if X < 0 then X := 0;
if Y < 0 then Y := 0;
SetBounds(X, Y, Width, Height);
if Visible then SetWindowToMonitor;
end
else if FPosition = poDesktopCenter then
begin
if FormStyle = fsMDIChild then
begin
X := (Application.MainForm.ClientWidth - Width) div 2;
Y := (Application.MainForm.ClientHeight - Height) div 2;
end else
begin
X := (Screen.DesktopWidth - Width) div 2;
Y := (Screen.DesktopHeight - Height) div 2;
end;
if X < 0 then X := 0;
if Y < 0 then Y := 0;
SetBounds(X, Y, Width, Height);
end;
The key to this bug seems to be the following snippets, repeated several times in the function:
if X < 0 then X := 0;
if Y < 0 then Y := 0;
So, if you try to center the form on a monitor to the left or above the primary monitor (remember that origin is at upper-left corner of primary monitor), it will get snapped to the primary monitor from this check. It seems that this code wasn't updated when VCL was updated to support multiple monitors. Which is amusing, since two lines later are calls to SetWindowToMonitor.
The code was probably there from when only single monitors were supported in Windows 95 / Windows NT 4.0. In a single-monitor environment, negative coordinates are always off-screen, and it makes sense to snap to onscreen coordinates, which are always positive. However, the code fails miserably in the presence of multiple monitors, which allows for negative onscreen coordinates.
Working around this bug is left as an exercise to the reader. There are a number of possible solutions.
I use this on the create event:
C_FollowMouse :BOOLEAN=TRUE; // Global Const - Follow mouse. Opens App in the monitor where the mouse is.
C_Monitor :BYTE=0; // Default Monitor
Procedure TfrmMain.ScreenPOS;
Var pt:tpoint;
_lMonitor :BYTE;
Begin
if NOT Screen.MonitorCount > 1 then Begin
Position := poScreenCenter;
Exit;
End;
_lMonitor := C_Monitor;
if C_FollowMouse then Begin
_lMonitor := 0;
getcursorpos(pt);
if pt.X < 0 then
_lMonitor := 1;
End;
Left:= Screen.Monitors[_lMonitor].Left + Round( (Screen.Monitors[_lMonitor].Width - Width ) / 2);
Top:=Screen.Monitors[_lMonitor].Top + Round( (Screen.Monitors[_lMonitor].Height - Height ) / 2)
End;
Just tested it with 2 monitors. Is all I have.
If you have more, post back the changes.
I was able to workaround this by using the code below on the Form OnActivate:
Self.Left := MainForm.Left + ((MainForm.Width div 2) - (Self.Width div 2));
Self.Top := MainForm.Top + ((MainForm.Height div 2) - (Self.Height div 2));
MainForm is the "main" form of the application.
Hey David you can use poOwnerFormCenter Instead of poMainFormCenter. It will Solve your problem. Read this post.
I know this is an old thread but I was just trying to fix this problem with regards to modal dialog forms and found the following to work (after reading the above post by James Johnson)
On OnActivate:
X := (Application.MainForm.ClientWidth - Width) div 2;
Y := (Application.MainForm.ClientHeight - Height) div 2;
self.SetBounds(x,y,self.width,self.height);

Resources