CODEWITHSUNDEEP
vbaexcelpositioncell
Sinister Swan
Sinister Swan

Reputation: 109

Position Userform differently for each ActiveCell clicked

I have a UserForm of a MonthView and DTPicker that will populate when certain cells are clicked.

I have the form positioned directly below the first cell.
I would like it positioned right below each active cell that I tell it to activate on.

My activate code to position the userform:

Private Sub UserForm_Activate()
    With frmCalendar
        .Top = Application.Top + 340
        .Left = Application.Left + 330
    End With
End Sub

My worksheet selection change code, which will launch the userform upon certain cell clicks:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Application.Intersect(Target, Range("H10,H15")) Is Nothing Then
        frmCalendar.Show
    End If
End Sub

I know there are add-ins that help do this, but I'd like to figure out how to position the user form right below the cells mentioned above (H10, H14, H15) without using an add-in.

I changed the Activate Sub code

Private Sub UserForm_Activate()
    With frmCalendar
        .Top = ActiveCell.offset(31).Top
        .Left = ActiveCell.offset(1).Left
    End With
End Sub

This moves it slightly below and slightly to the right of the cell, but when I try it on another cell is moves further down but stays the same distance to the right. This still is messy.

Is there no way to position this form directly below the ActiveCell using these methods?

Upvotes: 2

Views: 7285

Answers (5)

kadrleyn
kadrleyn

Reputation: 384

by declaring the GetDeviceCaps , GetDC , ReleaseDC functions , I repositioned the userform next to each the clicked activecell . (I checked the codes in 32-bit and 64-bit versions of Excel)

enter image description here

Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
    Dim hDc As LongPtr
#Else
    Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
    Dim hDc As Long
#End If
...

Source of codes & sample file

Upvotes: 0

J. Garth
J. Garth

Reputation: 803

Please see the answer I provided to this question as I believe this question is the same.

How do I properly align UserForm next to active cell

Upvotes: 0

Harry S
Harry S

Reputation: 511

Sub FormToActCell(UF As Object, Optional RaD$ = "ACAD", Optional Topw% = 102, _
                  Optional TopH% = -120)
' form to Active cell or RaD as range address ,offsets topW topH
  Dim Px&, Py&, Zoomp!

  If RaD = "ACAD" Then RaD = ActiveCell.Address

  Set CellToRange = Range(RaD)

  With CellToRange    ' get point about object to
    Px = (.Left + .Width * Topw / 100)
    Py = (.Top + .Height * TopH / 100)
  End With
  Zoomp = ActiveWindow.Zoom / 100
  With UF  ' assuming screen as normal pts to pix of 3:4
    .Left = Px * Zoomp + ActiveWindow.PointsToScreenPixelsX(0) * 0.75
    .Top = Py * Zoomp + ActiveWindow.PointsToScreenPixelsY(0) * 0.75
  End With
End Sub

Upvotes: 0

dcromley
dcromley

Reputation: 1410

I found http://www.vbaexpress.com/forum/archive/index.php/t-22038.html and developed this which I've used:

Sub showUform(iRow&, iCol&)
  Dim x11!, y11!
  ActiveSheet.Cells(iRow, iCol).Select
  x11 = ActiveWindow.PointsToScreenPixelsX(ActiveSheet.Cells(1, 1))
  y11 = ActiveWindow.PointsToScreenPixelsY(ActiveSheet.Cells(1, 1))
  UserForm1.Left = x11 + ActiveSheet.Cells(iRow, iCol).Left
  UserForm1.Top = y11 + ActiveSheet.Cells(iRow, iCol).Top
  UserForm1.Show
End Sub

Upvotes: 0

Gary's Student
Gary's Student

Reputation: 96753

You are using the correct Event macro. I placed a TextBox in the worksheet and with this macro

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim s As Shape
    Set s = ActiveSheet.Shapes(1)
    s.Top = ActiveCell.Offset(1, 1).Top
    s.Left = ActiveCell.Offset(1, 1).Left
End Sub

I can get the TextBox to move just to the right and just below the activecell.

Upvotes: 2

Related Questions