|
こんなことでしょうか。
それを選択状態にして実行してください。
Sub test()
Dim sp As ShapeRange
Dim a As Adjustments
Dim wTop As Double, wLeft As Double, wWidth As Double, wHeight As Double
Dim l As Double, t As Double
Dim ovl As Shape
Set sp = Selection.ShapeRange
wTop = sp.Top
wLeft = sp.Left
wWidth = sp.Width
wHeight = sp.Height
Set a = sp.Adjustments
l = wLeft + 0.5 * wWidth + a.Item(1) * wWidth
t = wTop + 0.5 * wHeight + a.Item(2) * wHeight
Set ovl = ActiveSheet.Shapes.AddShape(msoShapeOval, l, t, 1, 1)
MsgBox ovl.TopLeftCell.Address
ovl.Delete
End Sub
|
|