Vba Decrease width from left

[mahmed1]

Hi All

I have a shape that when i run the macro, the shape gets smaller so its like its sliding open

for i = 500 to 1 step -5
DoEvents
worksheets("mysheet").shapes("moveleft").width = i
nexi i

What i want to do is have that same effect on my shape named moveright but get the shape to move right when decreasing so its like the shape is opening like a sliding door going right

please help me get this effect because by flipping the variable wont work

ie i = 1 to 500

 

[Peter_SSs]

Try this

For i = 500 To 1 Step -5
  DoEvents
  With Worksheets("mysheet").Shapes("moveright")
    .Left = .Left + .Width - i
    .Width = i
  End With
Next i

 

[mahmed1]

Thank you Peter - appreciated

I also have a center image that has the macro to open the doors if you like

Is there a way i can fade out this circle shape as the door (shapes left and right) are opened?

 

[Peter_SSs]

Thank you Peter - appreciated

I also have a center image that has the macro to open the doors if you like

Is there a way i can fade out this circle shape as the door (shapes left and right) are opened?

I'm not exactly sure what you have or where it is placed, but see if you can make something from this.

Sub OpenThem()
  Dim shL As Shape, shR As Shape, shC As Shape
  Dim i As Long, stepsize As Long
  
  Const shLleftanchor As Long = 0       '<- Horizontal position of left of Left Door
  Const shRrightanchor As Long = 1100   '<- Horizontal position of right of Right Door
  Const shCcenteranchor As Long = 550   '<- Horizontal position of center of Center Circle
  Const StartWidth As Long = 500        '<- Initial width of Doors
  Const TopPos As Long = 100            '<- Vertical position of all shapes (not sure if they are all the same?)
  
  stepsize = -StartWidth / 100
  With Worksheets("mysheet")
    Set shL = .Shapes("moveleft")
    With shL
      .Left = shLleftanchor
      .Top = TopPos
      .Width = StartWidth
    End With
    Set shR = .Shapes("moveright")
    With shR
      .Left = shRrightanchor - StartWidth
      .Top = TopPos
      .Width = StartWidth
    End With
    Set shC = .Shapes("center")
    With shC
      .Left = shCcenteranchor - shC.Width / 2
      .Top = TopPos
    End With
  End With
  For i = StartWidth To 1 Step stepsize
    Application.ScreenUpdating = False
    shL.Width = i
    shR.Left = shRrightanchor - i
    shR.Width = i
    shC.Fill.Transparency = (StartWidth - i) / StartWidth
    Application.ScreenUpdating = True
    DoEvents
  Next i
End Sub

 

[mahmed1]

Peter - you are amazing thank you

having looked at your code - the transparency part of the code is what will really help me

i have several of shapes within in a group called displaygroup

how can i amend the code so that it sets all the shapes to have a transparency of 100 together when i press show macro and have a hide button that sets transparency to 0 together. I guess ill have to use DoEvents because my aim to give a fade out and fade in effect

is it possible if can have the shapes named

myshape1
myshape2
myshape3
myshape4

to be ungrouped from the group once the group is displayed and then group it back when i hide it

the reason for that is so that i want to be able to drag and move these 4 shapes once displayed

i hope this makes sense

thank you

 

[Peter_SSs]

i have several of shapes within in a group called displaygroup

how can i amend the code so that it sets all the shapes to have a transparency of 100 together when i press show macro and have a hide button that sets transparency to 0 together.

Does this do what you want?

ActiveSheet.Shapes("displaygroup").Fill.Transparency = 0  ' 0 for no transparency, 1 for full transparency

is it possible if can have the shapes named

myshape1
myshape2
myshape3
myshape4

to be ungrouped from the group once the group is displayed and then group it back when i hide it

Are these the 'sliding doors'? If so, do you need to ungroup/regroup them as they should still 'open' while grouped.

 

[mahmed1]

Hi Peter- thank you for responding back to me

The shapes i listed are normal shapes that should allow the user to be able to move and position them manually where they want when displayed (just like how this is allowed in excel as it is)

By changing the transparency of just the group does not work because all the shapes within that group does not change the transparency

The reason why i wanted the 4 shapes ungrouped is because when its grouped, it doesn't allow the user to be able to select and move these 4 shapes.

I wanted to ungroup the 4 shapes when it fades in..

when the fade out button is pressed- i would then need everything in the group (ie the 4 shapes also) faded out together

i hope this makes sense

thank you so much

 

[Peter_SSs]

I'm not entirely clear, but does some combination of these lines enable you to do what you want?

With ActiveSheet.Shapes.Range(Array("myshape1", "myshape2", "myshape3", "myshape4"))
  .Group
  .Name = "displaygroup"
End With

ActiveSheet.Shapes("displaygroup").Fill.Transparency = 0   '(or 1)

ActiveSheet.Shapes("displaygroup").Ungroup

 

[mahmed1]

Thank you

I will try this code and see how this works

I have multiple shapes that make up the group called display group

only the 4 shapes listed should have the option to be dragged and moved as you wish when displayed (ie like as if was not grouped) and then to hide em all - I thought it would be easier to group them all back and then set the transparency to 1

ill give your code a try and will see how this works

ps is there i code i can have that gives me the exact position of all the shapes within the group?

the reason i say this is that - just encase the shapes have been moved - I want to be able to set back to default position when the group is displayed

i have the layout set up the way i want it to - it would be nice to quickly get all the default positions, length n size rather than manually going through every single shape

thank you

 

[mahmed1]

Hi Peter

Again thank you for all your help

So i have tested the code you provided - for some strange reason - all the shapes in the group sets the transparency to 0 or 1 except 1 shape even though its part of the group

So this code does set the transparency within the group but it doesnt ungroup the 4 shapes i need to ungroup that allows me to have the access to be able to move them about

I get this error message "Grouping is disabled for selected shapes"

Sub test()


'I have many shapes but these are the 4 shapes i want to be able to move about when displayed
With ActiveSheet.Shapes.Range(Array("Shape1", "Shape2", "Shape3", "Shape4"))
  .Group
  .Name = "DisplayGroup"
End With


For i = 0.99 To 0 Step -0.07
    Application.ScreenUpdating = False
    ActiveSheet.Shapes("DisplayGroup").Fill.Transparency = i
    Application.ScreenUpdating = True
    DoEvents
Next i
'ActiveSheet.Shapes("DisplayGroup").Fill.Transparency = 0   '(or 1)


ActiveSheet.Shapes("DisplayGroup").Ungroup


End Sub


Sub test2()


'With ActiveSheet.Shapes.Range(Array("Shape1", "Shape2", "Shape3", "Shape4"))
'  .Group
'  .Name = "DisplayGroup"
'End With


For i = 0 To 1 Step 0.07
    Application.ScreenUpdating = False
    ActiveSheet.Shapes("DisplayGroup").Fill.Transparency = i
    Application.ScreenUpdating = True
    DoEvents
Next i
'ActiveSheet.Shapes("DisplayGroup").Fill.Transparency = 0   '(or 1)


'ActiveSheet.Shapes("DisplayGroup").Ungroup


End Sub