LinkBack URL
About LinkBacks
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
Register To Reply
Bookmarks