Loading
Ozgrid Excel Help & Best Practices Forums

Excel Video Tutorials / 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.

    VB:
    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:

    VB:
    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:

    VB:
    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:

    VB:
    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
    6

    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
    VB:
    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
    6

    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:

    VB:
    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:
    VB:
    Private Sub Calendar1_DblClick() 
        ActiveCell.Value = Calendar1.Value 
        Unload Me 
    End Sub 
    
    
    Open the form with something like this:

    VB:
    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:
    VB:
    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
    6

    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

    VB:
     '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
    VB:
    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
    VB:
    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
    6

    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 3 users browsing this thread. (0 members and 3 guests)

Possible Answers

  1. Active Hyperlink Display on user form
    By vikrampnz in forum EXCEL HELP
    Replies: 8
    Last Post: February 9th, 2012, 09: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, 14:41
  3. User Form search setting active cell
    By kpfunf in forum EXCEL HELP
    Replies: 2
    Last Post: July 28th, 2006, 03:01
  4. Active Cell Position
    By depesh in forum EXCEL HELP
    Replies: 1
    Last Post: April 15th, 2005, 19:12
  5. Replies: 2
    Last Post: September 17th, 2003, 22: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