shapes vba

[rakesh seebaruth]

Hi Guys


I have the following vba codes


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Box As Shape
Set Box = Me.Shapes("Rectangle 1")
If Selection.Left + Selection.Width _
+ Box.Width > Rows(1).Width Then
Box.Left = Selection.Left - Box.Width
Else: Box.Left = Selection.Left + Selection.Width
End If
If Selection.Top + Selection.Height _
+ Box.Height > Columns(1).Height Then
Box.Top = Selection.Top - Box.Height
Else: Box.Top = Selection.Top + Selection.Height
End If
Box.ZOrder msoBringToFront
End Sub

It works fully well with the rectangle


I have changed the rectangle to rounded rectangle


It’s not working


Your help will be highly appreciated.


Happy New Year 2019


Thanks/regards

rakesh

 

[Yongle]

What is the new shape's name?
- select shape and look in Excel's name box

Either
- rename the shape as "Rectangle 1"
or
- amend the code to refer to the correct name

 

[rakesh seebaruth]

Thanks it works

Now how to add two shapes one Rectangle 1 and Rounded Rectangle 1 the above vba codes?

Happy new year 2019

regards

rakesh

 

[Yongle]

In principle, simply repeat the code for each shape (see below)

But
Your code is triggered EVERY time a new cell is selected - is that what you really want?
Should changes to "Rectangle 1" and "Rectangle: Rounded Corners 1" BOTH be triggered by selecting the same cell(s)?
- if not please explain what should happen

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Box As Shape
    Set Box = Me.Shapes("Rectangle 1")
        If Selection.Left + Selection.Width + Box.Width > Rows(1).Width Then
            Box.Left = Selection.Left - Box.Width
        Else: Box.Left = Selection.Left + Selection.Width
        End If

        If Selection.Top + Selection.Height + Box.Height > Columns(1).Height Then
            Box.Top = Selection.Top - Box.Height
        Else: Box.Top = Selection.Top + Selection.Height
        End If
    Box.ZOrder msoBringToFront
'Now Repeat for 2nd shape - amend properties as required
    Set Box = Me.Shapes("Rectangle: Rounded Corners 1")
        If Selection.Left + Selection.Width + Box.Width > Rows(1).Width Then
            Box.Left = Selection.Left - Box.Width
        Else: Box.Left = Selection.Left + Selection.Width
        End If

        If Selection.Top + Selection.Height + Box.Height > Columns(1).Height Then
            Box.Top = Selection.Top - Box.Height
        Else: Box.Top = Selection.Top + Selection.Height
        End If
    Box.ZOrder msoBringToFront
     
End Sub

 

[rakesh seebaruth]

thanks but there is only one shape the rectangle 1 covers the other shape completely. The position of the second shape is not correct.

 

[Yongle]

Do you want second shape to always be the same size and in same position as first shape?

 

[rakesh seebaruth]

yes same size and the next the other one

 

[Yongle]

Is this what you want?
- amend shape names if necessary

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Box As Shape, Box2 As Shape
    Set Box = Me.Shapes("[COLOR=#ff0000]Rectangle 1[/COLOR]")
    Set Box2 = Me.Shapes("[COLOR=#ff0000]Rectangle: Rounded Corners 2[/COLOR]")
[I][COLOR=#006400]'first box    [/COLOR][/I]
    With Selection
        If .Left + .Width + Box.Width > Rows(1).Width Then
            Box.Left = .Left - Box.Width
        Else: Box.Left = .Left + .Width
        End If
        If .Top + .Height + Box.Height > Columns(1).Height Then
            Box.Top = .Top - Box.Height
        Else: Box.Top = .Top + .Height
        End If
    End With
    Box.ZOrder msoBringToFront
[I][COLOR=#006400]'other box[/COLOR][/I]
    With Box
        Box2.Left = .Left + .Width
        Box2.Top = .Top
        Box2.Width = .Width
        Box2.Height = .Height
    End With
End Sub

 

[rakesh seebaruth]

Yes you can leave a little space in between the shapes

thanks again

 

[Yongle]

leave a little space in between the shapes?

Amend this line

        Box2.Left = .Left + .Width

Try

        Box2.Left = .Left + .Width + 10