Option Explicit

' http://www.mvps.org/dmcritchie/excel/shapes.htm
' http://www.mvps.org/dmcritchie/excel/code/shapes.txt
 
Sub DeleteSelectedRectangularShapes()
  Dim shp As Shape
  For Each shp In ActiveSheet.Shapes
   If shp.AutoShapeType = msoShapeRectangle Then
      If Intersect(shp.TopLeftCell, Selection.Range) Then shp.Delete
        'Intersect(shp.BottomRightCell),Selection.Range) Then shp.Delete
   End If
  Next shp
End Sub

Sub CheckShape()
'Find names of objects on a sheet -- Tom Ogilvy 01Nov199
'untested (dmcr) has a range("myzone")
Dim varArr()
Dim shpRange As ShapeRange
ReDim varArr(1 To 1)
i = 0
For Each shp In Worksheets("sheet1").Shapes
 If shp.Type = msoFreeform Then
  If Not Intersect(Range("MyZone"), _
    shp.TopLeftCell) Is Nothing Then
      i = i + 1
      ReDim Preserve varArr(1 To i)
      varArr(i) = shp.Name
  End If
 End If
Next
 Set shpRange = ActiveSheet.Shapes.Range(varArr)
 Debug.Print shpRange.Count
 For Each shp In shpRange
   Debug.Print shp.Name, shp.TopLeftCell.Address
 Next
 shpRange.Select
End Sub

Sub delShapesOnSht()
  'Dave Peterson, misc 2001-11-12, no loop required
  If ActiveSheet.Shapes.Count = 0 Then
     MsgBox "No Shapes on page for deletion"
     Exit Sub
  End If
  '- automatic filter arrows may interfere with the selectall below
  ActiveSheet.Shapes.SelectAll  '*** warning DELETE all Shapes
  Selection.Delete
End Sub

Sub delShapesSel()
  'Delete shapes within selection range,
  ' Dave Peterson, programming, 2001-11-13
    Dim myshape As Shape
    For Each myshape In ActiveSheet.Shapes
        If Intersect(myshape.TopLeftCell, _
                 Selection) Is Nothing Then
            'do nothing
        Else
            myshape.Delete
        End If
    Next myshape
End Sub

Sub ExtractLinkToRightOfShapes()
'Extract hyperlink and place to right of cells with shapes
'Dick Kusleika,  2003-03-26 in excel.links,  modified from
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
    On Error Resume Next
    shp.BottomRightCell.Offset(0, 1).Value = "'--"
    shp.BottomRightCell.Offset(0, 1).Value = shp.Hyperlink.Address
    On Error GoTo 0
Next shp
End Sub

Sub IDthisShape()
 'Identify selected shape, David McRitchie, programming, 2002-12-20
 '  http://www.mvps.org/dmcritchie/excel/shapes.htm
 '  http://google.com/groups?threadm=uV1T2%23FqCHA.2484@TK2MSFTNGP12
 Dim str As String, i As Long, cnt As Long
 cnt = 0
 On Error Resume Next
 cnt = Selection.ShapeRange.Count '-- err if none selected
 str = "There are " & ActiveSheet.Shapes.Count _
   & " shapes on this worksheet" _
   & Chr(10) & "of which " & cnt _
   & IIf(cnt = 1, " was selected", " were selected") _
   & Chr(10) & Chr(10)
 MsgBox Selection.Count
 If cnt = 0 Then
    str = str & "Actually, Selected shape is: " & Selection.Name
    MsgBox str
    Exit Sub
 End If
 For i = 1 To Selection.ShapeRange.Count
  MsgBox str & i & " of " & Selection.ShapeRange.Count _
   & " in selection. The selected shape is " _
   & Chr(10) & "    " & Selection.ShapeRange.Item(i).Name
 Next i
 End Sub
 
 Sub IDthisShape_old()
 'Identify selected shape, David McRitchie, programming, 2002-12-20
 On Error Resume Next
 
 Dim i As Long
 For i = 1 To Selection.Count
  MsgBox "there are " & ActiveSheet.Shapes.Count _
   & " shapes on this worksheet" _
   & Chr(10) & Chr(10) & i & " of " & Selection.Count _
   & " in selection. The selected shape is " _
   & Chr(10) & "    " & Selection(i).Name
 Next i
 Select Case Err.number
   Case 0
     Exit Sub
  ' Case 438
  '   MsgBox "Selected shape is: " & Selection.Name
   Case Else
     MsgBox Err.number & " -- " & Err.Description
 End Select
End Sub


Sub getShapeProc()
    'List of buttons/shapes ON THE worksheets
    'based on Shawn Foley, programming group, 1999-09-10
    '-- http://groups.google.com/groups?as_umsgid=7rbk95%24b44%241%40nntp8.atl.mindspring.net
    Dim wks As Worksheet
    Dim shp As Shape
    Dim nRow As Long
    Sheets.Add         'Don't destroy the active sheet
    Cells.Clear           '--  added due to on Error
    Cells(1, 1) = "Worksheet"
    Cells(1, 2) = "Shape"
    Cells(1, 3) = "Type"
    Cells(1, 4) = "OnAction"
    Cells(1, 5) = "Hyperlink"
    Cells(1, 6) = "TopLeft"
    Cells(1, 7) = "BotRight"
    Cells(1, 8) = "Height"
    Cells(1, 9) = "Width"
    Cells(1, 10) = "Autoshape"
    Cells(1, 10).AddComment "Autoshape Type"
    Cells(1, 11) = "Form"
    Cells(1, 11).AddComment "Form Control Type"
    Cells(1, 12) = "Fore"
    Cells(1, 12).AddComment "Fill.ForeColor.SchemeColor"
    Cells(1, 13) = "Back"
    Cells(1, 13).AddComment "Fill.BackColorSchemeColor"
    nRow = 1
    On Error Resume Next   'hyperlinks, topLeftCell, BottomRightCell
    For Each wks In ActiveWorkbook.Worksheets
        For Each shp In wks.Shapes
            If shp.Name = "Comment" Then GoTo skpThis
            nRow = nRow + 1
            Cells(nRow, 1) = "'" & wks.Name    'i.e. Worksheet  1999-01-10
            Cells(nRow, 2) = shp.Name
            Cells(nRow, 3) = shp.Type
            Cells(nRow, 4) = shp.OnAction
            On Error Resume Next
            Cells(nRow, 5) = shp.Hyperlink.Address     'additional information
            Cells(nRow, 6) = shp.TopLeftCell.Address(0, 0)
            Cells(nRow, 7) = shp.BottomRightCell.Address(0, 0)
            Cells(nRow, 8) = shp.Height
            Cells(nRow, 9) = shp.Width
            Cells(nRow, 10) = shp.AutoShapeType
            Cells(nRow, 11) = shp.FormControlType  'i.e.  autofilter button is 2
            Cells(nRow, 12) = shp.Fill.ForeColor.SchemeColor
            Cells(nRow, 13) = shp.Fill.BackColor.SchemeColor
            Cells(nRow, 14) = shp.ControlFormat    'not seen yet
            Cells(nRow, 15) = shp.ConnectorFormat  'not seen yet
            On Error Resume Next
            With shp.DrawingObject.Font
              Cells(nRow, 16).AddComment "DrawingObject.Font " _
                & " .name = " & .Name _
                & " .FontStyle = " & .FontStyle _
                & " .Size = " & .Size _
                & " .ColorIndex = " & .ColorIndex
            End With
skpThis:
            'Debug.Print wks.Name & Chr(9) & shp.Name & Chr(9) & shp.OnAction
            '------no/no shp.Delete
        Next shp
        'If wks.Name = "Abuse" Then GoTo done  'testing D.McRitchie
    Next wks
done: nRow = nRow + 0
End Sub

Sub selShapesOnSht()
    Dim shp As Shape
    Dim ans As Variant
    For Each shp In ActiveWorkbook.ActiveSheet.Shapes
      ans = MsgBox("DELETE Shape" & Chr(10) & shp.Name & " " _
        & shp.TopLeftCell.Address & Chr(10) & " -- " _
        & shp.AlternativeText, vbYesNoCancel + vbDefaultButton2)
      If ans = 2 Then
        shp.Select                 'Select shape and exit
        Exit Sub
      End If
      If ans = 6 Then shp.Delete   'Delete the shape
    Next shp
End Sub


 Sub selshapesall()
   ActiveSheet.Shapes.SelectAll
   '-- warning Select Tool remains active on drawing toolbar
End Sub
Sub selcontrolsall()
   ActiveSheet.Controls.SelectAll
   '-- warning Select Tool remains active on drawing toolbar
End Sub

Sub ShipShapes()
  Dim shp As Shape
  Dim sht As Worksheet
  Dim filename As String
  Dim i As Long
'  On Error Resume Next
  For Each sht In Application.Worksheets   '    Wo ThisWorkbook.Worksheets
    If sht.Name = "Sheet7" Then Exit Sub
    For Each shp In sht.Shapes
       i = i + 1
       filename = Replace("c:\tempshapes\" & sht.Name & "_" _
         & shp.Type & "_" & shp.Name & ".jpg", " ", "-")
       Debug.Print i & ".  " & filename
      '-- can't directly export a picture has to be pasted into a
      '  chart, resized, and then exported...
       'shp.Export filename:=filename, FilterName:="JPEG"
       If Err.number <> 0 Then MsgBox Err.number & " " & Err.Description
    Next shp
  Next sht
End Sub

Sub ShapeTest()
    Dim sr     As ShapeRange
    Dim i%
    Debug.Print "------ " & Format(Time, "hh:mm:ss")
    ' ActiveSheet.Shapes.SelectAll
    Set sr = Selection.ShapeRange

    For i = 1 To sr.Count
        sr(i).Select
        Debug.Print sr(i).Name & " -- " & _
              sr(i).AutoShapeType
        sr.Select
    Next

End Sub

Sub delRectangularShapesOnSht()
' there is an example of of smame for within a selection
' at the top of this coding page.
    Dim shp As Shape
    For Each shp In ActiveWorkbook.ActiveSheet.Shapes
      'check  shp.Code for Particular Shapes:
      If shp.AutoShapeType = msoShapeRectangle Then shp.Delete
    Next shp
End Sub