调整所选形状 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:更多修复。此解决方案在我的机器上按预期工作
我正在创建应调整所选形状大小的宏。我用循环创建了,所以每个形状都会弹出输入框,这工作正常但问题是这没有改变任何东西。有什么建议吗?
非常感谢。
此致!
子调整大小()
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:更多修复。此解决方案在我的机器上按预期工作