CODEWITHSUNDEEP
vbatextboxpowerpoint
Strelok
Strelok

Reputation: 189

Simultaneous many-shape rotation between fixed positions on Powerpoint

I have six objects, all in a given fixed position, as depicted below

enter image description here

The text boxes all have the same size. I would like to automate the counterclockwise rotation of all text boxes, so that when I use the macro, it will rotate the text 60º ccw (thus BETA becomes ALPHA, ALPHA becomes ZETA and so forth). However, I'm completely clueless on how to write it in VBA! I know that I can set the textbox using

Set myDocument = ActivePresentation.Slides(1) 
myDocument.Shapes.AddTextbox(Type:=msoTextOrientationHorizontal, _ 
    Left:=400, Top:=100, Width:=160, Height:=30).TextFrame _ 
    .TextRange.Text = "ALPHA"

But, I'm clueless on how to rotate them. Another alternative would be to create these six TextBoxes and create a function that only changed the text variable, but my VBA knowledge is very elementary, and I wouldn't even know where to begin :\

Can anyone be so kind as to give me a small help?

Upvotes: 0

Views: 200

Answers (2)

Pᴇʜ
Pᴇʜ

Reputation: 57733

If you mean to rotate their position and not their orientation it could look like this: 

Option Explicit

Public Sub ExampleRotatePositions()
    Dim myDocument As Slide
    Set myDocument = ActivePresentation.Slides(1)

    Dim TextBox(1 To 6) As Shape

    'create the textboxes in your desired position.
    Set TextBox(1) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=100, Top:=100, Width:=160, Height:=30)
    TextBox(1).TextFrame.TextRange.Text = "ALPHA"

    Set TextBox(2) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=200, Top:=100, Width:=160, Height:=30)
    TextBox(2).TextFrame.TextRange.Text = "BETA"

    Set TextBox(3) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=300, Top:=100, Width:=160, Height:=30)
    TextBox(3).TextFrame.TextRange.Text = "GAMMA"

    Set TextBox(4) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=400, Top:=100, Width:=160, Height:=30)
    TextBox(4).TextFrame.TextRange.Text = "DELTA"

    Set TextBox(5) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=500, Top:=100, Width:=160, Height:=30)
    TextBox(5).TextFrame.TextRange.Text = "EPSILON"

    Set TextBox(6) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=600, Top:=100, Width:=160, Height:=30)
    TextBox(6).TextFrame.TextRange.Text = "ZETA"

    MsgBox "Start rotating now"


    'remember last position
    Dim LastLeft As Single
    LastLeft = TextBox(UBound(TextBox)).Left
    Dim LastTop As Single
    LastTop = TextBox(UBound(TextBox)).Top

    'rotate position
    Dim iTextBox As Long
    For iTextBox = UBound(TextBox) - 1 To LBound(TextBox) Step -1
        TextBox(iTextBox + 1).Left = TextBox(iTextBox).Left
        TextBox(iTextBox + 1).Top = TextBox(iTextBox).Top
    Next iTextBox

    'move first to last position
    TextBox(LBound(TextBox)).Left = LastLeft
    TextBox(LBound(TextBox)).Top = LastTop
End Sub

Upvotes: 1

Pᴇʜ
Pᴇʜ

Reputation: 57733

Group them using the ShapeRange.Group method and then rotate the group:

Set myDocument = ActivePresentation.Slides(1)

With myDocument.Shapes   
    .AddShape(msoShapeCan, 50, 10, 100, 200).Name = "shpOne"
    .AddShape(msoShapeCube, 150, 250, 100, 200).Name = "shpTwo"

    With .Range(Array("shpOne", "shpTwo")).Group
        .Fill.PresetTextured msoTextureBlueTissuePaper
        .Rotation = 45
        .ZOrder msoSendToBack
    End With
End With

Upvotes: 0

Related Questions