LinkBack Thread Tools Search this Thread Display Modes
Prev Previous Post   Next Post Next
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 2,253
Default Code to get a Range RECTangle or PT


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
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Rectangle Symbol cs_jono Excel Discussion (Misc queries) 3 April 25th 08 09:29 PM
Rectangle Box Keyrookie Excel Worksheet Functions 1 January 27th 08 08:09 AM
Confining a point in a rectangle [email protected] Excel Discussion (Misc queries) 1 May 24th 07 01:03 AM
Resizeable Rectangle Bill Bell Excel Programming 1 October 27th 03 08:34 PM
Add text to a rectangle in VBA pk Excel Programming 2 October 19th 03 02:44 AM


All times are GMT +1. The time now is 11:38 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
Copyright ©2004-2025 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"