Home |
Search |
Today's Posts |
#1
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]() FYI & FWIW, It's easy to get a RangeFromPoint but to get the RECT or POINTAPI for a range is far less straightforward. I've had a look at Chip Pearson's FormPositioning demo. No luck there. His code is struggling when he must determine the range's rectangle. It comes close, but is not exact (look closely and it's off by a few pixels) and it doesnt take much to throw his code offtrack by inches. Use outlines...,Use zoom...Use a 120 DPI monitor setting.. oops again. He's adjusting left and top for commandbars caption heights etc, but missed the trick! I've googled but couldn't find how it should be done. So I tried .. and tried.. and found the EXACT way to do it. Basically it's very simple. the cell's LEFT converted to pixels. PLUS application.screenpixelsX(0).. to give you the starting PT.X of the 'clientrect' et voila! I wrapped it in a sub rather then a function to be compatible with api syntax (plus for the purists.. it's slightly faster). Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function GetDC Lib "user32" ( _ ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" ( _ ByVal hwnd As Long, ByVal hDC As Long) As Long Private Declare Function GetSystemMetrics Lib "user32.dll" ( _ ByVal nIndex As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" ( _ ByVal hDC As Long, ByVal nIndex As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" ( _ ) As Long 'additional for demo only Private Declare Function SetCursorPos Lib "user32.dll" ( _ ByVal x As Long, ByVal y As Long) As Long Private Declare Sub Sleep Lib "kernel32.dll" ( _ ByVal dwMilliseconds As Long) Private Function ScreenDPI(bVert As Boolean) As Long 'in most cases this simply returns 96 Static lDPI&(1), lDC& If lDPI(0) = 0 Then lDC = GetDC(0) lDPI(0) = GetDeviceCaps(lDC, 88&) 'horz lDPI(1) = GetDeviceCaps(lDC, 90&) 'vert lDC = ReleaseDC(0, lDC) End If ScreenDPI = lDPI(Abs(bVert)) End Function Private Function PTtoPX(Points As Single, bVert As Boolean) As Long PTtoPX = Points * ScreenDPI(bVert) / 72 End Function Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT) Dim wnd As Window 'requires additional code to verify the range is visible 'etc. Set wnd = rng.Parent.Parent.Windows(1) With rng rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) _ + wnd.PointsToScreenPixelsX(0) rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) _ + wnd.PointsToScreenPixelsY(0) rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) _ + rc.Left rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) _ + rc.Top End With End Sub Sub Demo() Dim rc As RECT With ActiveWindow .ScrollRow = 500 .ScrollColumn = 26 Range("ab510").Select End With MsgBox "Watch the mousecursor.. press CTRLBREAK to cancel" Application.EnableCancelKey = xlErrorHandler On Error GoTo done Call GetRangeRect(ActiveCell, rc) Do DoEvents Call SetCursorPos(rc.Left, rc.Top) Call Sleep(200) Call SetCursorPos(rc.Right, rc.Top) Call Sleep(200) Call SetCursorPos(rc.Right, rc.Bottom) Call Sleep(200) Call SetCursorPos(rc.Left, rc.Bottom) Call Sleep(200) Loop done: End Sub -- keepITcool | www.XLsupport.com | keepITcool chello nl | amsterdam |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
Rectangle Symbol | Excel Discussion (Misc queries) | |||
Rectangle Box | Excel Worksheet Functions | |||
Confining a point in a rectangle | Excel Discussion (Misc queries) | |||
Resizeable Rectangle | Excel Programming | |||
Add text to a rectangle in VBA | Excel Programming |