ExcelBanter - How to move a form under a cell?

Here's another approach

' normal module
Option Explicit
' Declarations to get points per pixel
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 GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Const POINTS_PER_INCH As Long = 72
Private Const LOGPIXELSX As Long = 88

' to get screen size
Private Declare Function GetSystemMetrics Lib "user32" ( _
ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Private mPPP As Single ' points per pixel

Sub getPPP()
Dim hWin As Long
Dim dcDT As Long
Dim nDPI As Long

hWin = GetDesktopWindow
dcDT = GetDC(hWin)
nDPI = GetDeviceCaps(dcDT, LOGPIXELSX)
mPPP = POINTS_PER_INCH / nDPI
ReleaseDC hWin, dcDT

' shouldn't be necessary but just in case, 96/72 is typical
If mPPP = 0 Then mPPP = 0.75
End Sub

Sub test1()
' If A1 is not visible don't step through or 'run' or at least don't
' stop or break until after doing the PointsToScreenPixelsX/Y lines
Dim bCenter As Boolean
Dim x As Single, y As Single

If mPPP = 0 Then getPPP

On Error GoTo errCantGetPosition

With ActiveCell
x = x + .Left
y = y + .Top

' maybe move the form to right lower corner of the cell
x = x + (.Width * 0.8)
y = y + (.Height * 0.5)
End With

With ActiveWindow
' goto the activecell if it's off the screen
If Intersect(ActiveCell, .VisibleRange) Is Nothing Then
Application.Goto ActiveCell, True
End If
' adjust for zoom
x = x * .Zoom / 100
y = y * .Zoom / 100

' relate to top left of sheet
x = x + (.PointsToScreenPixelsX(0) * mPPP)
y = y + (.PointsToScreenPixelsY(0) * mPPP)
End With

ResHe
On Error GoTo errH

With UserForm1
If bCenter Then
' something went wrong (or pass bCenter as an arg) so center the
form
.StartUpPosition = 2&
Else
.StartUpPosition = 0

' ensure all the form will appear on the screen
' if x/y = 0 suggests something not right, eg stepping through
code

If x < 0 Then x = 0
If y < 0 Then y = 0

If x + .Width GetSystemMetrics(SM_CXSCREEN) * mPPP Then
x = GetSystemMetrics(SM_CXSCREEN) * mPPP - .Width
End If

If y + .Height GetSystemMetrics(SM_CYSCREEN) * mPPP Then
y = GetSystemMetrics(SM_CYSCREEN) * mPPP - .Height
End If

.Left = x
.Top = y
End If
.Show ' vbModeless
End With

Exit Sub

errCantGetPosition:
' a chart perhaps
bCenter = True
Resume ResHere
errH:
' some other error
MsgBox Err.Description

End Sub

For testing include the following sheet change event

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target(1) = 1 Then TestShowForm
End Sub

Put some 1's in cells and select them. If you show the form as modeless, as
in the demo, selecting a cell with a 1 or entering 1 in a cell should "move"
the already loaded form (to 0.8 width 0.5 height of the cell).

As written the code does not cater for the possibility of Freeze panes

It's the first time I've posted this so would be interested to know if it
works or otherwise.

Regards,
Peter T

wrote in message
...
Hello NG,

I have created a form that pops up if the user clicks on a special
cell. Now I want to move the form direct under the cell. But how can I
get the Coordinates of this cell? This property
"Worksheet1.Cells(1,1).left" is always zero, so I must add an offset.
How can I get this offset from Excel?

Regards

Peter