CODEWITHSUNDEEP
vbapowerpoint
Norby
Norby

Reputation: 361

Resize selected shapes powerpoint VBA

I'm creating macro which should resize selected shapes. I've created with loop, so input box will pop up for each shape, and this works fine but problem is that this not changing anything. Any suggestions why?

Thank you so much.

Regards!

Sub resize()

Dim objHeigh As Integer
Dim objWidth As Integer
Dim oSh As Shape


On Error GoTo CheckErrors

With ActiveWindow.Selection.ShapeRange
    If .Count = 0 Then
        MsgBox "You need to select a shape first"
        Exit Sub
    End If
End With

For Each oSh In ActiveWindow.Selection.ShapeRange

    objHeigh = oSh.Height
    objWidth = oSh.Width

    objHeigh = InputBox$("Assign a new size of Height", "Heigh", objHeigh)
         ' give the user a way out
    If objName = "QUIT" Then
        Exit Sub
    End If

    If objName <> "" Then
        oSh.Name = objName
    End If
Next

 objWidth = InputBox$("Assign a new size of Width", "Width", objWidth)
         ' give the user a way out
    If objName = "QUIT" Then
        Exit Sub
    End If

    If objName <> "" Then
        oSh.Name = objName
    End If


Exit Sub

CheckErrors: MsgBox Err.Description

End Sub

Upvotes: 0

Views: 3345

Answers (1)

lokusking
lokusking

Reputation: 7456

The reason nothing happens, is that you do random things with your variables.

Following code is going to fix that:

    Sub test()

Dim objHeigh As Integer
Dim objWidth As Integer
Dim oSh As Shape


On Error GoTo CheckErrors

With ActiveWindow.Selection.ShapeRange
    If .Count = 0 Then
        MsgBox "You need to select a shape first"
        Exit Sub
    End If
End With

For Each oSh In ActiveWindow.Selection.ShapeRange

    objHeigh = oSh.Height
    objWidth = oSh.Width

    objHeigh = CInt(InputBox$("Assign a new size of Height", "Heigh", objHeigh))
         ' give the user a way out
    If objHeigh = 0 Then
        Exit Sub
    End If

    If objName <> "" Then
        oSh.Name = objName
    End If


 objWidth = CInt(InputBox$("Assign a new size of Width", "Width", objWidth))
         ' give the user a way out
    If objWidth = 0 Then
        Exit Sub
    End If


oSh.Height = CInt(objHeigh)
oSh.Width = CInt(objWidth)
Next
Exit Sub

CheckErrors: MsgBox Err.Description

End Sub

EDIT: Updateed code with an Cast to Int. Type mismatch sould be gone

EDIT2: Some more Fixes. This solution works as intended on my machine

Upvotes: 2

Related Questions