VBA/Excel/Access/Word/Excel/Shapes

Add a new shape

 
Private Sub btnShowAllAutoShapes_Click()
  Dim i&
  On Error Resume Next
  For i = 0 To 136
    ActiveSheet.Shapes.AddShape i + 1, 40 + 50 * (i Mod 12), 50 + 50 * (i \ 12), 40, 40
  Next
End Sub

Add a rectangle

 
Sub AddRectangle()
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 10, 10, 200, 100).TextFrame
        .Characters.Text = "This is a rectangle"
        .HorizontalAlignment = xlHAlignCenter
        .VerticalAlignment = xlVAlignCenter
    End With
End Sub

Delete all shapes

 
Private Sub btnDeleteShapes_Click()
  Dim s As Shape
  For Each s In ActiveSheet.Shapes
    If s.Type = msoAutoShape Or s.Type = msoLine Then s.Delete
  Next
End Sub

Display auto shapes

 
Sub DisplayAutoShapes()
    Dim sh As Shape
    Dim i As Integer
    Set sh = ActiveSheet.Shapes.AddShape(1, 100, 100, 72, 72)
    For i = 1 To 138
       sh.AutoShapeType = i
       sh.Visible = True
       ActiveSheet.Cells(1, 1).Value = sh.AutoShapeType
       Delay 0.5
    Next i
End Sub

Draw a star

 
Private Sub btnStar_Click()
  Dim degree#
  Dim s As Shape
  Const Pi = 3.1415927
  Randomize
  For degree = 0 To 2 * Pi Step Pi / 12
    Set s = ActiveSheet.Shapes.AddLine(200, 200, 200 + 100 * Sin(degree), 200 + 100 * Cos(degree))
    s.Line.EndArrowheadStyle = msoArrowheadTriangle
    s.Line.EndArrowheadLength = msoArrowheadLengthMedium
    s.Line.EndArrowheadWidth = msoArrowheadWidthMedium
    s.Line.ForeColor.RGB = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
  Next
End Sub