Loading
Ozgrid Excel Help & Best Practices Forums

Excel Training / Excel Dashboards Reports



Results 1 to 8 of 8

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

  1. #1
    Join Date
    27th March 2012
    Posts
    13

    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

    Excel Video Tutorials / Excel Dashboards Reports


  2. #2
    Join Date
    27th March 2012
    Posts
    13

    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

    Excel Video Tutorials / Excel Dashboards Reports


  3. #3
    Join Date
    27th March 2012
    Posts
    13

    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.

    Excel Video Tutorials / Excel Dashboards Reports


  4. #4
    Join Date
    5th August 2011
    Posts
    8

    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

    Excel Video Tutorials / Excel Dashboards Reports


  5. #5
    Join Date
    5th August 2011
    Posts
    8

    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.

    Excel Video Tutorials / Excel Dashboards Reports


  6. #6
    Join Date
    1st July 2012
    Posts
    1

    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.

    Excel Video Tutorials / Excel Dashboards Reports


  7. #7
    Join Date
    5th August 2011
    Posts
    8

    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

    Excel Video Tutorials / Excel Dashboards Reports


  8. #8
    Join Date
    5th August 2011
    Posts
    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

    Excel Video Tutorials / Excel Dashboards Reports


Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Possible Answers

  1. Active Hyperlink Display on user form
    By vikrampnz in forum EXCEL HELP
    Replies: 8
    Last Post: February 9th, 2012, 10:32
  2. Excel 2010 copying active row 4 times below each row
    By Sailingmike in forum EXCEL HELP
    Replies: 5
    Last Post: October 19th, 2011, 15:41
  3. User Form search setting active cell
    By kpfunf in forum EXCEL HELP
    Replies: 2
    Last Post: July 28th, 2006, 04:01
  4. Active Cell Position
    By depesh in forum EXCEL HELP
    Replies: 1
    Last Post: April 15th, 2005, 20:12
  5. Replies: 2
    Last Post: September 17th, 2003, 23:15

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
porno