I have a procedure which takes a screenshot of a monitor and optionally includes the mouse cursor in the snapshot. The original function was only for one monitor. When drawing the mouse cursor, it currently shows properly only on the Main Monitor. But, I can't figure out how to position it on any other monitor. See the comments towards the end of this procedure.
procedure ScreenShot(var Bitmap: TBitmap; const MonitorNum: Integer;
const DrawCursor: Boolean; const Quality: TPixelFormat);
var
DC: HDC;
C: TCanvas;
R: TRect;
CursorInfo: TCursorInfo;
Icon: TIcon;
IconInfo: TIconInfo;
M: TMonitor;
CP: TPoint;
begin
M:= Screen.Monitors[MonitorNum];
DC:= GetDC(GetDesktopWindow);
try
C:= TCanvas.Create;
try
C.Handle:= DC;
R:= M.BoundsRect;
Bitmap.Width:= R.Width;
Bitmap.Height:= R.Height;
Bitmap.PixelFormat:= Quality;
Bitmap.Canvas.CopyRect(Rect(0,0,R.Width,R.Height), C, R);
finally
C.Free;
end;
finally
ReleaseDC(GetDesktopWindow, DC);
end;
if DrawCursor then begin
R:= Bitmap.Canvas.ClipRect;
Icon:= TIcon.Create;
try
CursorInfo.cbSize:= SizeOf(CursorInfo);
if GetCursorInfo(CursorInfo) then
if CursorInfo.Flags = CURSOR_SHOWING then
begin
Icon.Handle:= CopyIcon(CursorInfo.hCursor);
if GetIconInfo(Icon.Handle, IconInfo) then
begin
CP:= CursorInfo.ptScreenPos;
//Transition mouse position...?
CP.X:= CP.X + M.Left;
CP.Y:= CP.Y + M.Top; //No difference?
Bitmap.Canvas.Draw(
CP.X - Integer(IconInfo.xHotspot) - R.Left,
CP.Y - Integer(IconInfo.yHotspot) - R.Top,
Icon);
end;
end;
finally
Icon.Free;
end;
end;
end;
How do I transition the mouse position properly depending on which monitor I'm using?
You are mapping screen coord MonitorRect.Left to bitmap coord 0. And likewise, MonitorRect.Top to 0. So, if the cursor's screen position is CursorPos then you map that to CursorPos.X - MonitorRect.Left and CursorPos.Y - MonitorRect.Top. And then you also need to account for the hot spot, but you already seem to know how to do that.
The mapping above applies equally to all monitors.
Note that I used my own notation because I found your single letter variables mis-leading. Not to mention that fact that the meaning of these variables changes during the function. I'm look at you, R. That's always a recipe for pain.
Also, don't you need to delete the bitmap handles that are handed to you when you call GetIconInfo? And some error checking wouldn't go amiss.
Related
I am trying to define an area in the shape of a triangle and check if the mouse is in it. I can find if the mouse is in a certain square area using the code below. My program needs to detect the mouse in a triangle or a more complex shape.
if (Mouse.CursorPos.X < 20) or (50 > tbmn.Left + tbmn.Width) or (Mouse.CursorPos.Y < 20) or (Mouse.CursorPos.Y > tbmn.Top + 60) then
begin
end;
So basically, what I want to do is have a shape anywhere on the screen and check if the mouse is in it.
Is there a way to easily calculate a region of the screen and detect if the mouse is present in it?
Asuming you have a component where you draw a triangle inside and only want to have the component detect mouse hit when the cursor is over the visible part of the shape then you could do something like this:
Have an alpha layer on the component being drawn. Then intercept the Windows CM_HITTEST message. in the hit test message procedure you then check if the alpha value is 0. If it is 0 then the mouse is over an area with some visible color value.
Type
TSomeComponent = class(TGraphicControl)
private
FPNG : TGraphic;
procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; Override;
end;
procedure Register;
implementation
uses
GR32, GR32_Brushes,Winapi.Windows;
procedure TSomeComponent.CMHitTest(var Message: TCMHitTest);
var
colorEntry: TColor32Entry;
bmp : TBitmap32;
begin
bmp := TBitmap32.Create();
try
try
bmp.Assign(FPNG);
colorEntry := TColor32Entry(bmp.Pixels[Message.XPos,Message.YPos]);
if colorEntry.A <> 0 then
Message.Result := HTCLIENT
else
Message.Result := HTNOWHERE;
except
Message.Result := HTCLIENT;
end;
finally
bmp.Free;
end;
end;
You can use region functions from WinApi.
Here are example for simple triangle:
function PtInTriangle(ptX,ptY,X1,Y1,X2,Y2,X3,Y3:integer):Boolean;
var rgn:THandle; pts:array [0..2] of TPoint;
begin
pts[0].X:=X1; pts[0].Y:=Y1;
pts[1].X:=X2; pts[1].Y:=Y2;
pts[2].X:=X3; pts[2].Y:=Y3;
rgn := CreatePolygonRgn( pts[0], 3, WINDING);
Result := PtInRegion(rgn, ptX, ptY);
DeleteObject(rgn);
end;
This function takes about ~30..40us on my machine, and PtInRegion() takes only ~10% of this time (so, you can optimize it by caching Region object). Here are code with simple bencmark:
function PtInTriangle(ptX,ptY,X1,Y1,X2,Y2,X3,Y3:integer):Boolean;
var rgn:THandle; pts:array [0..2] of TPoint;
t,t1,t2,t3:Int64;
begin
// Create region
QueryPerformanceCounter(t);
pts[0].X:=X1; pts[0].Y:=Y1;
pts[1].X:=X2; pts[1].Y:=Y2;
pts[2].X:=X3; pts[2].Y:=Y3;
rgn := CreatePolygonRgn( pts[0], 3, WINDING);
QueryPerformanceCounter(t1); Dec(t1,t);
// Check point
QueryPerformanceCounter(t);
Result := PtInRegion(rgn, ptX, ptY);
QueryPerformanceCounter(t2); Dec(t2,t);
// Delete region
QueryPerformanceCounter(t);
DeleteObject(rgn);
QueryPerformanceCounter(t3); Dec(t3,t);
// Debug output
QueryPerformanceFrequency(t);
OutputDebugString(PChar(Format('All:%d(%.1fus) Create:%d PtInRect:%d(%.1f%%) Delete:%d',
[t1+t2+t3,(t1+t2+t3)/t*1E6,t1,t2,t2*100/(t1+t2+t3),t3])));
end;
Also, you can create complex regions with CreatePolyPolygonRgn() or CombineRgn().
I am trying to build an avionic attitude indicator with Delphi XE2.
I am using tRotateimage for the horizon
http://www.delphiarea.com/products/delphi-components/rotateimage/
This is behind a regular image which has transparent section in the middle.
Being able to rotate the image for roll and move the tRotateimage.top for pitch works well but I am getting a lot of flickering event with double buffered turned on my form. It flickers when I rotate the image or when I move it up via .top
Is there something else I can do to eliminate this flickering?
if tryStrToFloat(GetHashtag('#ROLL',',',Memo1.Lines.Text),MyDouble) then
Begin
rtAttitudeNeedle.Angle := 0- MyDouble;
rtAttitude.Angle :=0- MyDouble;
end;
if tryStrToFloat(GetHashtag('#PITCH',',',Memo1.Lines.Text),MyDouble) then
Begin
rtAttitude.Top := Round(iAttitudeTop + MyDouble);
end;
Double buffering a form is not always the magic trick to solve all your flicker problems.
you need to understand why you are having that flicker in the first place.
if you use the canvas object directly a lot in the paint routine, then you are doing nothing.
Most the time to solve this problem and reduce the flicker, you need to draw on a memory bitmap then at last CopyRect that to your canvas object.
Something like this for your component (Replace the Paint procedure with this code)
procedure TRotateImage.Paint;
var
SavedDC: Integer;
PaintBmp: TBitmap;
begin
PaintBmp := TBitmap.Create;
try
PaintBmp.SetSize(Width, Height);
if not RotatedBitmap.Empty then
begin
if RotatedBitmap.Transparent then
begin
PaintBmp.Canvas.StretchDraw(ImageRect, RotatedBitmap);
end
else
begin
SavedDC := SaveDC(PaintBmp.Canvas.Handle);
try
SelectClipRgn(PaintBmp.Canvas.Handle, ImageRgn);
IntersectClipRect(PaintBmp.Canvas.Handle, 0, 0, Width, Height);
PaintBmp.Canvas.StretchDraw(ImageRect, RotatedBitmap);
finally
RestoreDC(PaintBmp.Canvas.Handle, SavedDC);
end;
end;
end;
if csDesigning in ComponentState then
begin
PaintBmp.Canvas.Pen.Style := psDash;
PaintBmp.Canvas.Brush.Style := bsClear;
PaintBmp.Canvas.Rectangle(0, 0, Width, Height);
end;
Canvas.CopyRect(ClientRect, PaintBmp.Canvas, PaintBmp.Canvas.ClipRect);
finally
PaintBmp.Free;
end;
end;
if this does not solve the problem entirely then you could take a look at this flicker free set of components and try to adapt the rotating code you have on one of his components or inherit from it (I'm not the author and he is the one claiming flicker free functionality).
the FreeEsVclComponents GitHub repository
Edit: after debugging I found a lot of problems with that control, so I decided to go with my recommendation to you.
I created the following control for you
All what I did is that inheriting from TEsImage and doing some changes to the way it work. From the old control I used the routine below to do the rotation transformation.
function CreateRotatedBitmap(Bitmap: TBitmap; const Angle: Extended; bgColor: TColor): TBitmap;
As you can see in the gif above the rotation routine is not perfect. I suggest you look for an alternative.
I also forked the repository of FreeEsVclComponents and added the TAttitudeControl to the Es.Images unit, so you have all what you need to install the control in your system. Click here
At last I tested this on Tokyo and from the readme of the repository it should work on XE2 without problems.
Edit2: I changed the CreateRotatedBitmap with a better one (based on the GDI+), this is the result:
I already pushed the changes to Github so you can git the code from there.
I'm adding the code here as well in case Github goes down (highly unlikely :))
uses
WinApi.Windows, WinApi.GDIPApi, WinApi.GDIPObj, Vcl.Graphics, System.Types;
function RotateImage(Source: TBitmap; Angle: Extended; AllowClip: Boolean): TBitmap;
var
OutHeight, OutWidth: Integer;
Graphics: TGPGraphics;
GdiPBitmap: TGPBitmap;
begin
if AllowClip then
begin
OutHeight := Source.Height;
OutWidth := Source.Width;
end
else
begin
if (Source.Height > Source.Width) then
begin
OutHeight := Source.Height + 5;
OutWidth := Source.Height + 5;
end
else
begin
OutHeight := Source.Width + 5;
OutWidth := Source.Width + 5;
end;
end;
Result := TBitmap.Create;
Result.SetSize(OutWidth, OutHeight);
GdiPBitmap := nil;
Graphics := TGPGraphics.Create(Result.Canvas.Handle);
try
Graphics.SetSmoothingMode(SmoothingModeDefault);
Graphics.SetPixelOffsetMode(PixelOffsetModeHalf);
Graphics.SetInterpolationMode(InterpolationModeLowQuality);
Graphics.TranslateTransform(OutWidth / 2, OutHeight / 2);
Graphics.RotateTransform(Angle);
Graphics.TranslateTransform(-OutWidth / 2, -OutHeight / 2);
GdiPBitmap := TGPBitmap.Create(Source.Handle, Source.Palette);
try
Graphics.DrawImage(GdiPBitmap, 0, 0);
finally
GdiPBitmap.Free;
end;
finally
Graphics.Free;
end;
end;
Need a component derived from TMemo (not TSyn components)
I need a line to the left(inside or outside) of a TMemo whose thickness(optional) and color can be controlled just for the purposes of indication. It need not be functional as a gutter but looks like one especially like that of a SynMemo as shown in the image. The problem with SynMemo is that it doesn't support variable width fonts like Tahoma but the TMemo does.
I tried making a few composite components with CustomContainersPack by combining a TShape with TMemo, even superimposing a TMemo on top of TSynMemo but didn't succeed as the paint while dragging made it look disassembled and CCPack is not that robust for my IDE.
KMemo, JvMemo and many other Torry.net components were installed and checked for any hidden support for achieving the same but none worked.
Grouping of components together is also not a solution for me since many mouse events are tied to the Memo and calls to FindVCLWindow will return changing components under the mouse. Furthermore many components will be required so grouping with TPanel will up the memory usage.
You can use the WM_Paint message and a hack to do this without creating a new component,
Otherwise create a descendant of TMemo and apply the same changes below
TMemo = class(Vcl.StdCtrls.TMemo)
private
FSidecolor: TColor;
FSideColorWidth: Integer;
FAskForAttention: Boolean;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure SetSideColorWidth(const Value: Integer);
procedure SetSideColor(const Value: TColor);
procedure SetAskForAttention(const Value: Boolean);
published
property SideColor: TColor read FSideColor write SetSideColor default clRed;
property SideColorWidth: Integer read FSideColorWidth write SetSideColorWidth default 2;
property AskForAttension: Boolean read FAskForAttention write SetAskForAttention;
end;
{ TMemo }
procedure TMemo.SetAskForAttention(const Value: Boolean);
begin
FAskForAttention := Value;
Invalidate;
end;
procedure TMemo.SetSideColor(const Value: TColor);
begin
FSideColor := Value;
Invalidate;
end;
procedure TMemo.SetSideColorWidth(const Value: Integer);
begin
FSideColorWidth := Value;
Invalidate;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
var
DC: HDC;
Pen: HPen;
R,G,B: Byte;
begin
inherited;
if FAskForAttention then
begin
DC := GetWindowDC(Handle);
try
B := Byte(FSidecolor);
G := Byte(FSidecolor shr 8);
R := Byte(FSidecolor shr 16);
Pen := CreatePen(PS_SOLID, FSideColorWidth, RGB(R,G,B));
SelectObject(DC, Pen);
SetBkColor(DC, RGB(R,G,B));
Rectangle(DC, 1, 1, FSideColorWidth, Height - 1);
DeleteObject(Pen);
finally
ReleaseDC(Handle, DC);
end;
end;
end;
And you can use it like this
procedure TForm15.Button1Click(Sender: TObject);
begin
memo1.SideColor := ColorBox1.Selected;
memo1.SideColorWidth := 2;
memo1.AskForAttension := True;
end;
and you get this result
Limitations:
As this is merely another hack to draw a simple rectangle on the side, do not expect it to be perfect on all situations. I did notice the following when testing:
If the border is too thick you get the following effect
When on mouse move the line sometimes disappear and don't get painted (I think it is because of drawing focus rect).
Note: I see the guys in comments suggested to create a custom component with panel and memo put together, If you want to try this, take a look at my answer to
Creating a new components by combining two controls (TEdit and TTrackBar) in Delphi VCL
It is basically the same Ideas.
Edit:
Ok I took into consideration what is mentioned in comments and adapted my answer,
I also changed the way I'm getting the canvas of the component. The new implementation becomes this
{ TMemo }
procedure TMemo.SetAskForAttention(const Value: Boolean);
var
FormatRect: TRect;
begin
if FAskForAttention <> Value then
begin
FAskForAttention := Value;
if not FAskForAttention then
begin
Perform(EM_SETRECT, 0, nil);
end
else
begin
FormatRect := GetClientRect;
if IsRightToLeft then
FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
else
FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;
Perform(EM_SETRECT, 0, FormatRect);
end;
Invalidate;
end;
end;
procedure TMemo.SetSideColor(const Value: TColor);
begin
if FSideColor <> Value then
begin
FSideColor := Value;
Invalidate;
end;
end;
procedure TMemo.SetSideColorWidth(const Value: Integer);
var
FormatRect: TRect;
begin
if FSideColorWidth <> Value then
begin
FSideColorWidth := Value;
FormatRect := GetClientRect;
if IsRightToLeft then
FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
else
FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;
Perform(EM_SETRECT, 0, FormatRect);
end;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
var
Canvas: TControlCanvas;
CRect: TRect;
begin
inherited;
if FAskForAttention then
begin
Canvas := TControlCanvas.Create;
try
Canvas.Control := Self;
Canvas.Font.Assign(Self.Font);
CRect := GetClientRect;
if IsRightToLeft then
CRect.Left := CRect.Right - FSideColorWidth
else
CRect.Width := FSideColorWidth;
Canvas.Brush.Color := FSidecolor;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(CRect);
finally
Canvas.Free;
end;
end;
end;
There is no limitations for the size and it does not overlap the scrollbars.
Final result:
References I used to write this answer:
MSDN Painting and Drawing Functions
MSDN Using the WM_PAINT Message
Creating Colored Pens and Brushes example
Vcl.Controls TWinControl WM_Paint message implementation
EM_SETRECT message
How can I get a TEdit's canvas in Delphi? (Kobik's answer)
Instead of writing a custom control, put a panel or a shape beside the standard memo and give it any colour you like.
If this is too tedious to repeat many times, then put the memo and the shape on a frame and put that in the repository. Set the anchors to make sure they resize correctly. You don't even need to write code for that and you have an instant "imitation custom control".
Much better and simpler than writing, installing and testing a custom control, IMO.
Now if you want to put text or numbers or icons in the gutter, then it would pay out to write a custom control. Use EM_SETRECT to set the internal formatting rectangle, and custom draw the gutter in the overridden Paint method. Do not forget to call inherited.
I am developing an application on Embarcadero XE where i receive real time data from the ethernet port and display on a teechart chart on the screen.
The application works like an osciloscope, that is, there is a time window (10 seconds for example) of data that the chart displays, and each new incoming point overwrites what already is on screen.
I would like your help to make a code that puts a marker on only the newest point added, so the user can keep track of which of the points on the screen is the most recent point. I don´t want all of the points with a marker, i want only the newest.
The series being used is a fastline.
Here is the code i'm using to add data to the chart:
//Delete already existing point
if (Oscilografia.Series[0].Count>1) then
begin
Oscilografia.Series[0].Delete(cont);
end;
//Write point
Oscilografia.Series[0].addxy(cont,data, '', clblue);
You have several options. The simplest is to make a new TPointSeries to display the current point. If you wish to not show this series in the legend then simply set :
Oscilografia.Series[n].ShowInLegend := false;
where n is the index of the series you wish to exclude from the legend.
Alternatively, you can custom-draw any relevant items in the OnAfterDraw handler. For example :
procedure TForm1.Chart1AfterDraw(Sender: TObject);
var
xPos, yPos : integer;
begin
Chart1.Canvas.Pen.Color := clRed;
Chart1.Canvas.Pen.Style := psSolid;
Chart1.Canvas.Pen.Width := 1;
Chart1.Canvas.Pen.Mode := pmCopy;
xPos := Chart1.BottomAxis.CalcPosValue(CurrentXValue);
yPos := Chart1.LeftAxis.CalcPosValue(CurrentYValue);
// Parameters are
// X-Coord, Y-Coord, X-Radius, Y-Radius, Start Angle, End Angle, Hole%
Chart1.Canvas.Donut(xPos, yPos, 3, 3, 0, 360, 0);
end;
This produces, for example :
Custom drawing lets you do other things also, like add markers, etc. For example :
procedure TForm1.Chart1AfterDraw(Sender: TObject);
var
xPos, yPos : integer;
yMax, yMin : integer;
begin
Chart1.Canvas.Pen.Color := clRed;
Chart1.Canvas.Pen.Style := psSolid;
Chart1.Canvas.Pen.Width := 1;
Chart1.Canvas.Pen.Mode := pmCopy;
xPos := Chart1.BottomAxis.CalcPosValue(CurrentXValue);
yPos := Chart1.LeftAxis.CalcPosValue(CurrentYValue);
Chart1.Canvas.Donut(xPos, yPos, 3, 3, 0, 360, 0);
Chart1.Canvas.Pen.Color := clGreen;
Chart1.Canvas.Pen.Style := psDash;
yMax := Chart1.LeftAxis.CalcPosValue(Chart1.LeftAxis.Maximum);
yMin := Chart1.LeftAxis.CalcPosValue(Chart1.LeftAxis.Minimum);
Chart1.Canvas.DoVertLine(xPos, yMax, yMin);
end;
Which gives a dashed vertical line that follows the current point :
Note that the CalcPosValue function is exposed by the chart axes and allows you to translate a point in the axis-space to an integer (screen) coordinate in the chart's canvas space.
As an alternative to J's proposal of using custom drawing techniques to draw a pointer, you could change the TFastLineSeries to use a TLineSeries and make its Pointer Visible. Then, you can use OnGetPointerStyle event to hide all the pointers except the last one:
uses Series;
var Series1: TLineSeries;
procedure TForm1.FormCreate(Sender: TObject);
var i: Integer;
begin
Chart1.View3D:=false;
Series1:=Chart1.AddSeries(TLineSeries) as TLineSeries;
for i:=0 to 360 do
Series1.Add(Sin(PI*i/180));
Series1.Pointer.Visible:=true;
Series1.OnGetPointerStyle:=SeriesGetPointerStyle;
end;
function TForm1.SeriesGetPointerStyle(Sender:TChartSeries; ValueIndex:Integer):TSeriesPointerStyle;
begin
result:=(Sender as TLineSeries).Pointer.Style;
if (ValueIndex<>Sender.Count-1) then
result:=psNothing;
end;
And as a complement, if you want to show the Mark of the last point in the series, you can make the series' Marks Visible and use OnGetMarkText event to hide all the Marks except the last one:
uses Series;
var Series1: TLineSeries;
procedure TForm1.FormCreate(Sender: TObject);
var i: Integer;
begin
Chart1.View3D:=false;
Series1:=Chart1.AddSeries(TLineSeries) as TLineSeries;
for i:=0 to 360 do
Series1.Add(Sin(PI*i/180));
Series1.Pointer.Visible:=true;
Series1.OnGetPointerStyle:=SeriesGetPointerStyle;
Series1.Marks.Visible:=true;
Series1.OnGetMarkText:=SeriesGetMarkText;
end;
function TForm1.SeriesGetPointerStyle(Sender:TChartSeries; ValueIndex:Integer):TSeriesPointerStyle;
begin
result:=(Sender as TLineSeries).Pointer.Style;
if (ValueIndex<>Sender.Count-1) then
result:=psNothing;
end;
procedure TForm1.SeriesGetMarkText(Sender:TChartSeries; ValueIndex:Integer; var MarkText:String);
begin
if (ValueIndex<>Sender.Count-1) then
MarkText:='';
end;
Note I'm using a TLineSeries here also, but if you are only interested on showing the Marks and not the Pointer, you can still use a TFastLineSeries.
This dialog shows exactly under button, but in Windows 8 dialog is shifted to the left and upward. How to get the same results in all Windows versions?
procedure TForm1.Button3Click(Sender: TObject);
var p: TPoint;
begin
p := Button3.ClientToScreen(Point(0, Button3.Height));
MessageDlgPos('', mtInformation, [mbOK], 0, p.X, p.Y);
end;
update:
In case we open Form instead of Dialog, and if that Form has BorderStyle bsSizeable or bsSizeToolWin, then everything is OK. Otherwise (bsDialog, bsSingle, bsToolWindow), Form opens shifted as Dialog from the example above.
Running the exact code you have shown on Windows 7, I am not able to reproduce the same dialog positioning you have shown in your Windows 7 screnshot. The MessageDlgPos window is offset up and to the left in the same manner as your Windows 8 screenshot:
That being said, I notice you are positioning your MessageDlg window relative to the button's client area:
If you want the dialog positioned relative to its actual bottom edge, you need to call ClientToScreen() on the button's Parent rather than on the button itself:
p := Button3.Parent.ClientToScreen(Point(Button3.Left, Button3.Top+Button3.Height));
The end result is about the same, though:
Now, why is the overlap occurring in the first place? Because the window is being positioned such that the top-left corner of its non-client area falls at the specified coordinates:
You can adjust the window coordinates to account for that:
p := Button3.Parent.ClientToScreen(Point(Button3.Left, Button3.Top + Button3.Height));
Inc(p.X, GetSystemMetrics(SM_CXFIXEDFRAME) + GetSystemMetrics(SM_CXBORDER));
Inc(p.Y, GetSystemMetrics(SM_CYFIXEDFRAME) + GetSystemMetrics(SM_CYBORDER));
Which gets you much closer to the desired position:
Note that Aero "tweaks" system metrics a bit, so you might need to use things like DwmGetWindowAttribute(DWMWA_EXTENDED_FRAME_BOUNDS) and/or GetThemeSysSize() to get more accurate metrics.
After your answers and comments and some additional research, I came to this solution. Tested on Windows 8, 7 with Aero, 7 without Aero and XP. I was hoping for something more simple and stable but ...
uses DwmApi;
type
TNonClientMetricsX = packed record
cbSize: UINT;
iBorderWidth: Integer; iScrollWidth: Integer;
iScrollHeight: Integer; iCaptionWidth: Integer;
iCaptionHeight: Integer; lfCaptionFont: TLogFontA;
iSmCaptionWidth: Integer; iSmCaptionHeight: Integer;
lfSmCaptionFont: TLogFontA; iMenuWidth: Integer;
iMenuHeight: Integer; lfMenuFont: TLogFontA;
lfStatusFont: TLogFontA; lfMessageFont: TLogFontA;
iPaddedBorderWidth: Integer; // not defined in Delphi 2007
end;
function GetExtendedFrameOffset(BorderStyle: TFormBorderStyle): integer;
var
IsEnabled: BOOL;
NCM: TNonClientMetricsX;
begin
Result := 0;
if (DwmIsCompositionEnabled(IsEnabled) = S_OK) and IsEnabled and
(BorderStyle in [bsdialog, bsSingle, bsToolWindow]) then
begin
NCM.cbSize := SizeOf(NCM);
SystemParametersInfo(SPI_GETNONCLIENTMETRICS, SizeOf(NCM), #NCM, 0);
Result := NCM.iBorderWidth + NCM.iPaddedBorderWidth;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
var p: TPoint; offset: integer;
begin
p := Button3.ClientToScreen(Point(0, Button3.Height));
offset := GetExtendedFrameOffset(bsDialog);
MessageDlgPos('', mtInformation, [mbOK], 0, p.X + offset, p.Y + offset);
end;
update: D2007 includes DwmApi, so no need for complications with LoadLibrary