调整所选形状 powerpoint VBA

Resize selected shapes powerpoint VBA

我正在创建应调整所选形状大小的宏。我用循环创建了,所以每个形状都会弹出输入框,这工作正常但问题是这没有改变任何东西。有什么建议吗?

非常感谢。

此致!

子调整大小()

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

检查错误: MsgBox Err.Description

结束子

没有任何反应的原因是您对变量进行了随机操作。

以下代码将解决此问题:

    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

编辑:使用 Cast to Int 更新了代码。类型不匹配应该消失了

EDIT2:更多修复。此解决方案在我的机器上按预期工作