Announcement

Collapse
No announcement yet.

Unconfigured Ad Widget

Collapse

Position User Form next to an Active Cell in Excel 2010 using VBA

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Position User Form next to an Active Cell in Excel 2010 using VBA

    I have been attempting to get a solution to this problem for a couple of days - my company cutover to Excel 2010, which killed my ActiveX Calendar - but I was able to work around it with code that I located online (see this thread for details on the calendar and where to get the code: http://www.ozgrid.com/forum/showthre...d=1#post609600). It works pretty well - but it always positions in the center of the spreadsheet. RoyUK helpfully pointed other users to Chip Pearson's form positioner code at http://cpearson.com/excel/FormPosition.htm - but I have a problem. It appears to have been written for an older version of Excel, and, in fact, much of the code within the form positioner references VBA6 (vice VBA7 which is shown on my Excel properties). No matter what I do with this code in 2010, I can't get it to reposition the userform - it always pops up in the center. If anyone is using this code with 2010 - can you tell me what I need to modify to get it running? I get coordinate positions, but the userform won't move.

    I've tried the following code in the codeblock for the UserForm - in this case named "DatePicker." This code would be added to the spreadsheet I loaded into my previous post - the file exceeds the upload limits now.

    Code:
    Private WithEvents Calendar1 As cCalendar
    
    Private Sub UserForm_Initialize()
    
    
    Dim PS As Positions
    
    Dim HO, VO As Long
    'Dim HO As cstFormHorizontalPosition
    'Dim VO As cstFormVerticalPosition
    
    'HO = cstFhpAuto '   set these to how you want the form positioned relative to AnchorCell
    'VO = cstFvpAuto '   set these to how you want the form positioned relative to AnchorCell
    
    Set Calendar1 = New cCalendar
    
    'MsgBox "Calendar1.Left = " & Calendar1.Left
    Calendar1.Add_Calendar_into_Frame Me.Frame1
    
    'MsgBox "Calendar1.Left = " & Calendar1.Left & " Calendar1.Width = " & Calendar1.Width
    MsgBox "ActiveCell.Left = " & ActiveCell.Left & " ActiveCell.Width = " & ActiveCell.Width & " ActiveCell.Top = " & ActiveCell.Top & " ActiveCell.Height = " & ActiveCell.Height
    
    HO = ActiveCell.Left + ActiveCell.Width ' - Calendar1.Width
    VO = ActiveCell.Top + ActiveCell.Height
    
    MsgBox "HO = " & HO & " VO = " & VO
    
    '
        ' Call PositionForm to determine the correct positions
        '
        'PS = PositionForm(WhatForm:=DatePicker, AnchorRange:=ActiveCell, HorizOrientation:=HO, VertOrientation:=VO)
    
    ''    PS = PositionForm(DatePicker, ActiveCell, 0, 0, HO, VO)
    
        DatePicker.Top = VO   ' set the Top position of the form
        DatePicker.Left = HO ' set the Left position of the form
    
        MsgBox "DatePicker.Top = " & DatePicker.Top & " DatePicker.Left = " & DatePicker.Left
    
    End Sub
    
    Private Sub Calendar1_DblClick()
    
    ActiveCell.Value = Calendar1.Value
    Unload Me
    
    End Sub
    
    Private Sub Calendar1_Click()
    
    ActiveCell.Value = Calendar1.Value
    Unload Me
    
    End Sub
    
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    
    Set Calendar1 = Nothing
    
    End Sub
    On the worksheet I've tried this code:

    Code:
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    Dim lastCol3 As Integer
    
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Not Application.Intersect(Worksheets("Sheet1").Range("TestRange"), Target) Is Nothing Then
    
        DatePicker.Show
        
    Else
        'do nothing
    End If
    
    End Sub

  • #2
    Re: Position User Form next to an Active Cell in Excel 2010 using VBA

    OK - I've fixed my own problem. I had a combination of stupid mistakes - Pearson's modFormPositioner http://cpearson.com/excel/FormPosition.htm works fine - IF - you change VBA6 to VBA7 (assuming you're in Excel 2010) and IF you select the right cstForm commands - do what I didn't do, and read his excellent comments. Also, you need to set the position of the form prior to executing the .show command - I was having problems figuring out where to make the call to Pearson's code. I, personnaly, like the calendar to popup to the right of the date field (ala Calendar 12.0). If you want this code to execute, you'll have to follow the link to my other post to get the sample cCalendar code - or pull it from the original source. Keep in mind my original note from that thread - if you're cutting over from an ActiveX Calendar 12.0 to a user form, you're likely to experience some very strange reference errors - no one has posted how to forestall that as of now. (Note to admins - I'll mark the thread as solved once I figure out the control for it).

    Code for Worksheet follows - lots of MsgBox commands - note that I had to add 5 points to the left position in order to account for the userform frame width:

    Code:
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    Dim lastCol3 As Integer
    Dim PS As Positions
    
    'Dim HO, VO As Long
    Dim HO As cstFormHorizontalPosition
    Dim VO As cstFormVerticalPosition
    
    'HO = cstFhpAuto '   set these to how you want the form positioned relative to AnchorCell
    'VO = cstFvpAuto '   set these to how you want the form positioned relative to AnchorCell
    
    HO = cstFhpFormLeftCellRight
    VO = cstFvpFormCenterCellTop
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Not Application.Intersect(Worksheets("Sheet1").Range("TestRange,TestRange2,TestRange3"), Target) Is Nothing Then
    
        With DatePicker
            MsgBox "ActiveCell.Left = " & ActiveCell.Left & " ActiveCell.Width = " & ActiveCell.Width & " ActiveCell.Top = " & ActiveCell.Top & " ActiveCell.Height = " & ActiveCell.Height
            'HO = ActiveCell.Left + (1.35 * ActiveCell.Width) ' - DatePicker.Width
            'VO = ActiveCell.Top + ActiveCell.Height + (0.65 * .Height)
            MsgBox "Before PositionForm call - HO = " & HO & " VO = " & VO
            MsgBox ".Left = " & .Left & " .Width = " & .Width
            '
            ' Call PositionForm to determine the correct positions
            '
            'PS = PositionForm(WhatForm:=DatePicker, AnchorRange:=ActiveCell, HorizOrientation:=HO, VertOrientation:=VO)
            'DatePicker.Top = VO   ' set the Top position of the form
            'DatePicker.Left = HO ' set the Left position of the form
            
            PS = PositionForm(DatePicker, ActiveCell, 0, 0, HO, VO)
            'MsgBox "HO = " & HO & " VO = " & VO
            .StartUpPosition = 0
            '.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
            '.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
            .Left = PS.FrmLeft + 5
            .Top = PS.FrmTop
            
            MsgBox ".Left = " & .Left & " .Top = " & .Top & " .Width = " & .Width
            .Show
        End With
        
    Else
        'do nothing
    End If
    
    End Sub
    Code for DatePicker user form follows:

    Code:
    Private WithEvents Calendar1 As cCalendar
    
    Private Sub UserForm_Initialize()
    
    Set Calendar1 = New cCalendar
    
    'MsgBox "Calendar1.Left = " & Calendar1.Left
    Calendar1.Add_Calendar_into_Frame Me.Frame1
    
    
    
    End Sub
    
    Private Sub Calendar1_DblClick()
    
    ActiveCell.Value = Calendar1.Value
    Unload Me
    
    End Sub
    
    Private Sub Calendar1_Click()
    
    ActiveCell.Value = Calendar1.Value
    Unload Me
    
    End Sub
    
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    
    Set Calendar1 = Nothing
    
    End Sub

    Comment


    • #3
      Re: Position User Form next to an Active Cell in Excel 2010 using VBA

      Also note - if you've frozen header panes above the body of the worksheet, you'll have to adjust the positioning of the user frame by those amount of points - in my case, I had four rows frozen which required me to drop the vertical boundary down by the height of the userform.

      Comment


      • #4
        Re: Position User Form next to an Active Cell in Excel 2010 using VBA

        The program does not account for zoom.. for us old with old eyes. the below is a module with some ideas about moving objects to ranges to shapes to screen etc
        I hope you can make some use of what is there
        Code:
        Option Explicit
        Option Compare Text
        Declare Function GetDC& Lib "user32" (ByVal hWnd&)
        Declare Function GetForegroundWindow& Lib "user32" ()
        Declare Function ReleaseDC& Lib "user32" (ByVal hWnd&, ByVal Hdc&)
        Declare Function GetDeviceCaps& Lib "gdi32" (ByVal Hdc&, ByVal nIndex&)
        Declare Function GetCursorPos& Lib "user32" (lpPoint As LPoint)
        Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
        Public Type LPoint
            X As Long
            Y As Long
        End Type
        Public Type SPoint
            X As Single
            Y As Single
        End Type
        Type MouseCommand      ' INPUT structure
            iType As Long        ' 0 for mouse, 1 for kbd
            iDx As Long          ' rel movt in pixels (unless ABSOLUTE)
            iDy As Long
            iWheelData As Long   ' we don't use this
            iFlags As Long       ' we use this (see MOUSEEVENT flags below)
            iTime As Long        ' don't use this
            iXtra As Long        ' or this
        End Type
        Const SM_CYCAPTION As Long = 4
        Const MOUSEEVENTF_LEFTDOWN = &H2              ' left button down
        Const MOUSEEVENTF_LEFTUP = &H4                ' left button up
        Const MOUSEEVENTF_MOVE As Long = &H1          ' mouse move
        Const MOUSEEVENTF_RIGHTDOWN As Long = &H8     ' right button down
        Const MOUSEEVENTF_RIGHTUP As Long = &H10      ' right button up
        Const MOUSEEVENTF_MIDDLEDOWN As Long = &H20   ' middle button down
        Const MOUSEEVENTF_MIDDLEUP As Long = &H40     ' middle button up
        Const MOUSEEVENTF_ABSOLUTE As Long = &H8000   ' absolute move
        Const MOUSEEVENTF_WHEEL As Long = &H800       ' wheel button rolled
        Declare Function SendInput _
                          Lib "User32.dll" _
                              (ByVal nCommands As Long, iCommand As MouseCommand, _
                               ByVal cSize As Long) As Long
        Public mPiPt As SPoint, ZoomP As Single, Hdc&, OffsetPT As LPoint
        'since people like to change screen size max min
        ' we need functions that will recalculate each time
        'in the event that windows are zoomed , scrolled
        'or if menus top or left are resized inserted or deleted
        'you need to run a tidy routine to  correctly reposition the objects
        Sub MouseAndClick()
            Dim mCommand As MouseCommand
            With mCommand
                .iFlags = MOUSEEVENTF_LEFTDOWN
                SendInput 1&, mCommand, Len(mCommand)
                .iFlags = MOUSEEVENTF_LEFTUP
                SendInput 1&, mCommand, Len(mCommand)
            End With
        End Sub
        
        Sub CursorXOBPt(CuP As LPoint, Obpt As LPoint)
            Dim Fopt As LPoint
            ZoomP = ActiveWindow.Zoom / 100
            Hdc = GetDC(0)
            mPiPt.X = 72 / (GetDeviceCaps(Hdc, 88))
            mPiPt.Y = 72 / (GetDeviceCaps(Hdc, 90))
        
            ReleaseDC 0, Hdc
            OffsetPT.X = ActiveWindow.PointsToScreenPixelsX(0) * mPiPt.X
            OffsetPT.Y = ActiveWindow.PointsToScreenPixelsY(0) * mPiPt.Y
            Obpt.X = (CuP.X * mPiPt.X - OffsetPT.X) / ZoomP
            Obpt.Y = (CuP.Y * mPiPt.Y - OffsetPT.Y) / ZoomP
        End Sub
        Sub FoPTxObPt(Fopt As LPoint, Obpt As LPoint)
            ZoomP = ActiveWindow.Zoom / 100
            Hdc = GetDC(0)
            mPiPt.X = 72 / (GetDeviceCaps(Hdc, 88))
            mPiPt.Y = 72 / (GetDeviceCaps(Hdc, 90))
            ReleaseDC 0, Hdc
            OffsetPT.X = ActiveWindow.PointsToScreenPixelsX(0) * mPiPt.X
            OffsetPT.Y = ActiveWindow.PointsToScreenPixelsY(0) * mPiPt.Y
            Obpt.X = (Fopt.X - OffsetPT.X) / ZoomP
            Obpt.Y = (Fopt.Y - OffsetPT.Y) / ZoomP
        End Sub
        Sub ObPTxFoPt(Obpt As LPoint, Fopt As LPoint)
            ZoomP = ActiveWindow.Zoom / 100
            Hdc = GetDC(0)
            mPiPt.X = 72 / (GetDeviceCaps(Hdc, 88))
            mPiPt.Y = 72 / (GetDeviceCaps(Hdc, 90))
            ReleaseDC 0, Hdc
            OffsetPT.X = ActiveWindow.PointsToScreenPixelsX(0) * mPiPt.X
            OffsetPT.Y = ActiveWindow.PointsToScreenPixelsY(0) * mPiPt.Y
            Fopt.X = Obpt.X * ZoomP + OffsetPT.X
            Fopt.Y = Obpt.Y * ZoomP + OffsetPT.Y
        End Sub
        Function ObNXForm(ob, ObN$) As Boolean
            'To get the user form named Obn as an object Ob
            ' true if it finds and shows it
            Dim fo As Boolean, cc%, Si%
            cc = VBA.UserForms.Count
            While Si < cc And Not fo
                If VBA.UserForms(Si).Name = ObN Then
                    fo = True
                    Set ob = VBA.UserForms(Si)
                End If
                Si = Si + 1
            Wend
            If Not fo Then
                On Error Resume Next
                Err.Clear
                Set ob = VBA.UserForms.Add(ObN)
                If Err.Number = 0 Then
                    fo = True
                    ob.Show 0
                    'ob.showmodal = True
                End If
            End If
            ObNXForm = fo
        End Function
        Sub FoXOb(Ufn$, ShName$, _
        Optional ToPW% = 0, Optional ToPH% = 0, _
                  Optional MoPW% = 0, Optional MoPH% = 0, _
                  Optional FitW% = 0, Optional FitH% = 0, _
                  Optional CRow% = 0, Optional CCol% = 0)
            ' to place a form about an object cell window range or named shape
            'two points  pt at topw * width and toph * height on the "To" object
            'and other   pt at Mopw  * width  and Moph * height on the "MO" object
            'are put together  moving the "Mo" to the "To"
            ' if FitW or FitH are given > 5 then the move object is scaled to the "To" object
            'CRow and CCol are used to specify which cell
            Dim WhatSHape, Obpt As LPoint, Fopt As LPoint, MoObjOffPt As LPoint, UF
            If ObNXForm(UF, Ufn) Then
                'UF.Show
                'MsgBox ShName
                Select Case ShName
                    Case "Cells": Set WhatSHape = Range(ActiveSheet.Cells(CRow, CCol).Address)
                    Case "VisWin": Set WhatSHape = ActiveWindow.Application.ActiveWindow.VisibleRange
                    Case "ActCell": Set WhatSHape = Range(ActiveCell.Address)
                    Case "ObCursor"  ' cursors events are in use in most programs
                        ' easier to have an autoshape ( can be moved any where)
                        'the use this routine to move the form to that shape on click
                    Case Else
                        If Left(ShName, 7) = "IsName." Then
                            Set WhatSHape = Range(Mid(ShName, 8, 100))
                        Else
                            Set WhatSHape = ActiveSheet.Shapes(ShName)
                        End If
                End Select
                With WhatSHape    ' get point about object to
                    Obpt.X = (.Left + .Width * ToPW / 100)
                    Obpt.Y = (.Top + .Height * ToPH / 100)
                End With
                ObPTxFoPt Obpt, Fopt
                With UF  ' correct point to position object moved
                    If FitW > 5 Then .Width = WhatSHape.Width * FitW / 100
                    If FitH > 5 Then .Height = WhatSHape.Height * FitH / 100
                    'set the offset of move object
                    MoObjOffPt.X = -.Width * MoPW / 100
                    MoObjOffPt.Y = -.Height * MoPH / 100
                    .Left = Fopt.X + MoObjOffPt.X
                    .Top = Fopt.Y + MoObjOffPt.Y
                End With
            End If
        End Sub
        Sub OBxFoCtrl(ShName$, FC, _
        Optional ToPW% = 0, Optional ToPH% = 0, _
                      Optional MoPW% = 0, Optional MoPH% = 0, _
                      Optional FitW% = 0, Optional FitH% = 0, _
                      Optional CRow% = 0, Optional CCol% = 0)
            'Shape to form  or form control Control
            '  FC as array("userform1")   or like  array("userform1","Frame2","label3" )
            Dim WhatSHape, Obpt As LPoint, Fopt As LPoint, MoObjOffPt As LPoint, UF, Ct%
            If ObNXForm(UF, CStr(FC(0))) Then
                Fopt.X = UF.Left + 4
                Fopt.Y = UF.Top + 21 ' check top border size
                For Ct = 1 To UBound(FC)    ' work through controls
                    Set UF = UF.Controls(CStr(FC(Ct)))
                    Fopt.X = Fopt.X + UF.Left
                    Fopt.Y = Fopt.Y + UF.Top
                Next Ct
                Fopt.X = Fopt.X + UF.Width * ToPW / 100
                Fopt.Y = Fopt.Y + UF.Height * ToPH / 100
                FoPTxObPt Fopt, Obpt
                If ShName <> "ObCursor" Then
                    Set WhatSHape = ActiveSheet.Shapes(ShName)
                    With WhatSHape  ' correct point to position object moved
                        If FitW > 5 Then .Width = WhatSHape.Width * FitW / 100
                        If FitH > 5 Then .Height = WhatSHape.Height * FitH / 100
                        'set the offset of move object
                        MoObjOffPt.X = -.Width * MoPW / 100
                        MoObjOffPt.Y = -.Height * MoPH / 100
                        .Left = Obpt.X + MoObjOffPt.X
                        .Top = Obpt.Y + MoObjOffPt.Y
                        .ZOrder msoBringToFront
                    End With
                Else    ' is cursor 'Mpipt global calculated above in FoPTxObPt
                    SetCursorPos Fopt.X / mPiPt.X, Fopt.Y / mPiPt.Y
                End If
            End If
        End Sub
        Sub CurxFoCtrl(FC, Optional ToPW% = 0, Optional ToPH% = 0)
            'cursor to form Ufn on Control CtrlN and or its Xtra Controls
            Dim WhatSHape, Obpt As LPoint, Fopt As LPoint, UF, Ct%
            If ObNXForm(UF, CStr(FC(0))) Then
                Fopt.X = UF.Left + 4
                Fopt.Y = UF.Top + 21
                For Ct = 1 To UBound(FC)    ' work through controls
                    Set UF = UF.Controls(FC(Ct))
                    Fopt.X = Fopt.X + UF.Left
                    Fopt.Y = Fopt.Y + UF.Top
                Next Ct
                Fopt.X = Fopt.X + UF.Width * ToPW / 100
                Fopt.Y = Fopt.Y + UF.Height * ToPH / 100
                FoPTxObPt Fopt, Obpt
                SetCursorPos Fopt.X / mPiPt.X, Fopt.Y / mPiPt.Y
                UF.SetFocus
            End If
        End Sub
        Sub CurToOb(UO, Optional ToPW% = 0, Optional ToPH% = 0, _
                    Optional Xo% = 0, Optional Yo% = 0)
            Dim X!, Y!, Fopt As LPoint, Obpt As LPoint
            With UO    ' get point about object to
                Obpt.X = (.Left + .Width * ToPW / 100)
                Obpt.Y = (.Top + .Height * ToPH / 100)
            End With
            ObPTxFoPt Obpt, Fopt
            '      FoPTxObPt Fopt, Obpt
            SetCursorPos Fopt.X / mPiPt.X + Xo, Fopt.Y / mPiPt.Y + Yo
         
        End Sub
        
        Sub OBxFO(ShName$, Ufn$, Optional ToPW% = 0, Optional ToPH% = 0, _
                  Optional MoPW% = 0, Optional MoPH% = 0, _
                  Optional FitW% = 0, Optional FitH% = 0, _
                  Optional CRow% = 0, Optional CCol% = 0)
            'object  shape of Obcursor to form
            Dim WhatSHape, Obpt As LPoint, Fopt As LPoint, MoObjOffPt As LPoint, UF
            If ObNXForm(UF, Ufn) Then
                With UF    ' get point about object to
                    Fopt.X = (.Left + .Width * ToPW / 100)
                    Fopt.Y = (.Top + .Height * ToPH / 100)
                End With
                FoPTxObPt Fopt, Obpt
                If ShName <> "ObCursor" Then
                    Set WhatSHape = ActiveSheet.Shapes(ShName)
                    With WhatSHape  ' correct point to position object moved
                        If FitW > 5 Then .Width = WhatSHape.Width * FitW / 100
                        If FitH > 5 Then .Height = WhatSHape.Height * FitH / 100
                        'set the offset of move object
                        MoObjOffPt.X = -.Width * MoPW / 100
                        MoObjOffPt.Y = -.Height * MoPH / 100
                        .Left = Obpt.X + MoObjOffPt.X
                        .Top = Obpt.Y + MoObjOffPt.Y
                    End With
                Else    ' is cursor 'Mpipt global calculated above in FoPTxObPt
                    SetCursorPos Fopt.X / mPiPt.X, Fopt.Y / mPiPt.Y
                End If
            End If
        End Sub
        Sub MoShapexShapeTo(ObjMoN$, ObjToN$, Optional ToPW% = 0, Optional ToPH% = 0, _
                            Optional MoPW% = 0, Optional MoPH% = 0, _
                            Optional FitW% = 0, Optional FitH% = 0, _
                            Optional AreForms As Boolean = False)
            ' also does form to form if AreForms := true
            Dim PtToInPT As LPoint, MoObjOffPt As LPoint
            Dim ObjTo, ObjMo, OktoGo As Boolean
            If AreForms Then
                OktoGo = ObNXForm(ObjTo, ObjToN) And ObNXForm(ObjMo, ObjMoN)
            Else
                Set ObjTo = ActiveSheet.Shapes(ObjToN)
                Set ObjMo = ActiveSheet.Shapes(ObjMoN)
                OktoGo = True
            End If
            If OktoGo Then
                With ObjTo    ' get point about object to
                    PtToInPT.X = (.Left + .Width * ToPW / 100)
                    PtToInPT.Y = (.Top + .Height * ToPH / 100)
                End With
                With ObjMo  ' correct point to position object moved
                    If FitW > 5 Then .Width = ObjTo.Width * FitW / 100
                    If FitH > 5 Then .Height = ObjTo.Height * FitH / 100
                    MoObjOffPt.X = -.Width * MoPW / 100
                    MoObjOffPt.Y = -.Height * MoPH / 100
                    'set the offset of move object and move it
                    .Left = PtToInPT.X + MoObjOffPt.X
                    .Top = PtToInPT.Y + MoObjOffPt.Y
                End With
            End If
        End Sub
        
        Sub UseLike()
            'FoXOb "UFX", "cells", 120, 50, 0, 50, CRow:=10, CCol:=10
            'puts user form ufx right centre of cells(10,10)
            'FoXOb "UFX", "IsName.ttt", 50,50,50,50
            'puts user form ufx centered on the named range ttt
            'FoXOb "UFX", "tbb", 100, 50, 20, 20
            ' puts form  ufx on shape("tbb")
            'FoXOb "ufx", "VisWin", 100, 0, 100, 0
            'puts ufx top right of visible window
            '    MoShapexShapeTo "fpassword", "Ufx", 100, 50, 10, 10, AreForms:=True
            ' put form fpassword to form ufx  ... 100 50 on ufx     matched to 10 10 of password
            ' MoShapexShapeTo "tbb", "coma", 100, 50, 10, 10
            '    OBxFO "tbb", "ufx", 100, 50, 10, 10,100,50
            'puts shapes("Tbb") to form named "Ufx" and resizes tbb to width and half height of form
            'OBxFO "ObCursor", "Fpassword", 50, 80
            'puts cursor to form "Fpassword"
            'CurxFoCtrl Array("Userform3, "Frame7", "label3"), 50, 50
            ' puts the cursor in the middle of label3 in frame7 of userform3
            'OBxFoCtrl "label1", Array("cuf", "frame1", "label4"), 95, 50
            'puts label1 to the right middle of label4 in frame 1 of form cuf
            ' BUT an opaque form hides it
        End Sub

        Comment


        • #5
          Re: Position User Form next to an Active Cell in Excel 2010 using VBA

          if you use vba to move a shape or ole object ( on a worksheet worksheet as activesheet.shapes('''') ) to the position of a userform ( on the same worksheet) how ( other than making it a child of the user form ) do you make the shape be in front of the form. It is always behind the form.

          Comment


          • #6
            Re: Position User Form next to an Active Cell in Excel 2010 using VBA

            Hello,

            Have had similar issues; did not want to depend on ActiveX Controls and Pearson's modFormPositioner not worked as expected.

            Have been using a combination of: Calendar control and User Form position with great results.

            As a simple example, in a new workbook:
            Add keepITcool's modMain Module.
            Add a User Form with a frame.
            Add a button control to the sheet.

            @ Harrys, wileydk ... keepITcool's sample file use panes and zoom, seem to work fine with them.

            Then add and customize following code in the User Form:

            Code:
            Option Explicit
            Private WithEvents Calendar1 As cCalendar
            
            Private Sub UserForm_Initialize()
                Set Calendar1 = New cCalendar
                ' Set properties to the Calendar.
                With Calendar1
                    .DayFont.Name = "Verdana"
                    .FirstDay = dwMonday
                    .GridFont.Name = "Verdana"
                    .TitleFont = "Verdana"
                    .UseDefaultBackColors = False
                    .SaturdayBackColor = RGB(255, 255, 200)
                    .SundayBackColor = RGB(255, 255, 200)
                    .SelectedBackColor = RGB(255, 255, 0)
                    .HeaderBackColor = RGB(200, 200, 255)
                    .RightToLeft = False
                End With
                
                ' Find coordinates of range/cell.
                Dim rc As RECT
                rc = GetRangeRect(ActiveWindow.RangeSelection)
            
                ' Set Form position.
                With Me
                    ' Added this variables to play with position. fX and fY are screen resolution functions.
                    Dim varFX As Double
                    varFX = rc.Right / fX()
                    Dim varFY As Double
                    varFY = rc.Bottom / fY()
                    ' This will position the form below the cell and centered to it.
                    '.Left = (.Width - (rc.Right - rc.Left) / 2) / 2
                    ' This will position the form below the cell and aligned to the right of it.
                    .Left = varFX - .Width
                    .Top = varFY
                End With
                    
                ' Add Calendar frame to User Form.  
                Calendar1.Add_Calendar_into_Frame Me.Frame1
            End Sub
            
            Private Sub UserForm_Activate()
                ' Set initial value.
                Calendar1.Value = ActiveCell.Value
            End Sub
            
            Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
                ' Free memory.
                Set Calendar1 = Nothing
            End Sub
            Use a Calendar event to set the cell value:
            Code:
            Private Sub Calendar1_DblClick()
                ActiveCell.Value = Calendar1.Value
                Unload Me
            End Sub
            Open the form with something like this:

            Code:
            Sub Button1_Click()
                CalendarForm.Show
            End Sub
            Now select a cell and press de button. ... cool uh!
            Simple and efficient. The RECT values are the range corners, so it's easy to position the form.

            If you want to keep using ActiveX; this have worked form me in Excel 2010 x32 and W7x64: Excel Date Picker

            It uses SelectionChange to place a button near a date cell, and Workbook_open to add a CommandBar Control (menu option) - Careful with that -

            When you press the button or select the menu option the form is opened. To position the form, just add this code to UserForm_Initialize:
            Code:
            Private Sub UserForm_Initialize()
            
              ...
            
                Dim rc As RECT
                rc = GetRangeRect(ActiveWindow.RangeSelection)
                With Me
                    ' Added this variables to play with position. fX and fY are screen resolution functions.
                    Dim varFX As Double
                    varFX = rc.Left / fX()
                    Dim varFY As Double
                    varFY = rc.Bottom / fY()
                    ' This will position the form below the cell, aligned to its left.
                    .Left = varFX
                    .Top = varFY
                End With
            
              ...
                
            End Sub
            Have fun mixing code from Calendar Control, Yogesh Gupta's and keepITcool's

            Best regards.

            Oscar.

            Comment


            • #7
              Re: Position User Form next to an Active Cell in Excel 2010 using VBA

              I am still working on form positioning ( and shapes and cursors and screens and OleObjects into one simple to use package
              An interesting idea for your datepicker is to use a set of labels around a rectangle to be 12 1 2 ... 11 so that the mouse x y on different labels
              will give you a time picker as well.... Include NOW and NOW + 24 buttons on the form. ( Works well but I will be a while before
              I have the VBE developer version to construct it for you.

              OK for now to cope with the jumps in form if you change their parent ... or try .top =.top +5 if it is in EXCEL7 window

              'a small lol from the above line... what question in a woman's mind is an insult to a man
              ' it contains 4 two letter words each starting with i

              Code:
              'Have this on a form called UFA that has a label TogParent
              Option Explicit
              ' currently example  a userform called UFA
              'needs the information below  .. or set up as a class
              'needs a label named TogParent
              Private Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
              Private Declare Function GetDesktopWindow Lib "user32" () As Long
              Public MeHWnd&, MeParent%, MeParentHwnd&
              Private Sub UserForm_Initialize()  ' this code in your initialize
                  MeHWnd = FindWindow("ThunderDFrame", Me.Caption)
                  MeParentHwnd = GetDesktopWindow
                  MeParent = 12
                  TogParent.Caption = "Screen 0 "
              End Sub
              Private Sub TogParent_Click()    ' a label named TogParent
                  Dim ToParent%
                  ToParent = MeParent + 2
                  With TogParent
                      Select Case ToParent
                          Case 14: .Caption = "EXCEL7"
                          Case 16: .Caption = "Application"
                          Case Else
                              .Caption = "Screen 0 "
                              ToParent = 12
                      End Select
                      OBFoPn Me, ToParent
                  End With
              End Sub
              ' have a worksheet with
              Code:
              Option Explicit
              Private Sub CommandButton1_Click()
                 'get back form UFA if lost
                 UFA.Show False
                  UFA.Top = 400
                  UFA.Left = 400
              End Sub
              Private Sub CommandButton2_Click()
              'position and size form  Left Top Width Height
              OBFoLTWH UFA, H:=260, W:=440, T:=320 ', L:=480
              End Sub
              Private Sub CommandButton4_Click()
                   ''change position and size form  Left Top Width Height
                   OBFodLdTdWdH UFA, dL:=60, dw:=-40   ', dT:=40
              End Sub
              Private Sub CommandButton5_Click()
              'put form to whatever type number  12 14 16 is in cell(20,15)  "O15"
                  OBFoPn UFA, Cells(20, 15)
              End Sub
              'and a code module to look after it
              Code:
              Option Explicit
              Private Type POINTAPI
                  x As Long
                  y As Long
              End Type
              Private Type RECT
                  Left As Long
                  Top As Long
                  Right As Long
                  Bottom As Long
              End Type
              Private Type WINDOWPLACEMENT
                  Length As Long
                  flags As Long
                  showCmd As Long
                  ptMinPosition As POINTAPI
                  ptMaxPosition As POINTAPI
                  rcNormalPosition As RECT
              End Type
              Private Const GWL_STYLE = (-16)
              Private Declare Function GetWindow& Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long)
              Declare Function GetDesktopWindow Lib "user32" () As Long
              Private Declare Function SetParent& Lib "user32" (ByVal hWndChild&, ByVal hWndNewParent&)
              Private Declare Function FindWindowEx& Lib "user32" Alias "FindWindowExA" (ByVal hWnd1&, ByVal hWnd2&, ByVal lpsz1$, ByVal lpsz2$)
              Private Declare Function GetWindowLong& Lib "user32" Alias "GetWindowLongA" (ByVal hwnd&, ByVal nIndex&)
              Private Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)
              Private Declare Function GetWindowRect& Lib "user32" (ByVal hwnd&, lpRect As RECT)
              Private Declare Function GetWindowPlacement& Lib "user32" (ByVal hwnd&, lpwndpl As WINDOWPLACEMENT)
              Private Declare Function SetWindowPlacement& Lib "user32" (ByVal hwnd&, lpwndpl As WINDOWPLACEMENT)
              Const GW_CHILD = 5
              Const GW_HWNDNEXT = 2
              Private StrB As String * 127, Nstr$
              '
              ' to make changes in  left,top,width,Height of form with public var MeHwind
              '
              Sub OBFodLdTdWdH(OBFO As Object, Optional dL& = 0, Optional dT& = 0, Optional dw& = 0, Optional dh& = 0)
                  Dim WinEst As WINDOWPLACEMENT, PtsPix!
                  'get the current window placement
                  PtsPix = 4 / 3
                  ' if not common screen get Points to pixels for X and Y  ...sub GetScreenStats
                  GetWindowPlacement OBFO.MeHWnd, WinEst
                  With WinEst.rcNormalPosition
                      .Left = .Left + dL * PtsPix
                      .Top = .Top + dT * PtsPix
                      .Right = .Right + (dL + dw) * PtsPix
                      .Bottom = .Bottom + (dT + dh) * PtsPix
                  End With
                  SetWindowPlacement OBFO.MeHWnd, WinEst
              End Sub
              '
              'find if an object has properties of MeParent etc
              Function IAmOrphan(OBFO As Object, wPn%) As Boolean
                  On Error Resume Next
                  wPn = 10
                  wPn = OBFO.MeParent    'if no error will change it
                  IAmOrphan = wPn = 10    ' else got 12 14 etc from  OBFo
              End Function
              '
              'Return form back after it jumps to new parent
              '
              Sub ChangeParentNoJump(OBFO As Object, ObHwnd, ParHwnd)
                  Dim WinEst As WINDOWPLACEMENT, dL&, dT&, Res&
                  '
                  'record it  to get shift when parent changed
                  '
                  Res = GetWindowPlacement(OBFO.MeHWnd, WinEst)
                  dL = OBFO.Left: dT = OBFO.Top
                  'change parent
                  Res = SetParent(ObHwnd, ParHwnd)
                  '
                  ' correct for shift when parent changed
                  '
                  dL = (OBFO.Left - dL) * 4 / 3
                  dT = (OBFO.Top - dT) * 4 / 3
                  With WinEst.rcNormalPosition
                      .Left = .Left - dL
                      .Top = .Top - dT
                      .Right = .Right - dL
                      .Bottom = .Bottom - dT
                  End With
                  'Back to same place
                  Res = SetWindowPlacement(OBFO.MeHWnd, WinEst)
              End Sub
              '
              'to set the  L  T  W  H of a normal form or form with MeHwnd and MeParentHwnd
              '
              Sub OBFoLTWH(OBFO As Object, _
                           Optional L& = 999, Optional T& = 999, Optional W& = 999, Optional H& = 999)
                  'using 999 to avoid IsMissing in argument passing.... does not work for integer% or double&
                  Dim Res&, wPn%
                  If Not IAmOrphan(OBFO, wPn) Then
                      If wPn = 16 Or wPn = 14 Then
                          Res = SetParent(OBFO.MeHWnd, GetDesktopWindow)
                      End If
                  End If  'OBFO  now a normal window... or an oleobject or shape if you change one of them
                  With OBFO
                      If L <> 999 Then .Left = L
                      If T <> 999 Then .Top = T
                      If W <> 999 Then .Width = W
                      If H <> 999 Then .Height = H
                  End With
                  If wPn = 14 Or wPn = 16 Then  ' back to parent
                      ChangeParentNoJump OBFO, OBFO.MeHWnd, OBFO.MeParent
                  End If
              End Sub
              'To set a form to parent number Pn   ( any numbers just using 12 14 16  )
              '
              Sub OBFoPn(OBFO As Object, Pn%)
                  Dim Res&, wPn%, WinInfo&
                  If IAmOrphan(OBFO, wPn) Then Exit Sub
                  'maybe get the current window style to reset later
                  WinInfo = GetWindowLong(OBFO.MeHWnd, GWL_STYLE)
                  If Pn <> OBFO.MeParent Then
                      With OBFO.TogParent
                          Select Case Pn
                              Case 12
                                  Res = GetDesktopWindow
                                  .Caption = "Screen 0 "
                              Case 14    ' EXCEL7
                                  Res = FindWindowEx(Application.hwnd, 0&, "XLDESK", Nstr)
                                  ' assume Excell7 of the active workbook is the first child of XLDESK
                                  ' seems to work OK rather than loop through looking for it
                                  ' search loop is complicated where words such as [Compatibility Mode] are in the  Caption
                                  Res = GetWindow(Res, GW_CHILD)
                                  .Caption = "EXCEL7"
                              Case 16  ' application
                                  Res = Application.hwnd  'or GetForegroundWindow
                                  .Caption = "Application"
                          End Select
                      End With
                      'set object values to the new values
                      OBFO.MeParentHwnd = Res
                      OBFO.MeParent = Pn
                      ChangeParentNoJump OBFO, OBFO.MeHWnd, Res
                  End If
                  'reset style  ??????
                  Res = SetWindowLong(OBFO.MeHWnd, GWL_STYLE, WinInfo)
              End Sub
              'and hopefully those forms that are children can now behave themselves

              Comment


              • #8
                Re: Position User Form next to an Active Cell in Excel 2010 using VBA

                Also have a look at ActiveWindow.ActivePane.pointstoScreenPixelsx() .. It is now good

                Comment

                Trending

                Collapse

                There are no results that meet this criteria.

                Working...
                X