References to Shapes, listing shapes

Shapes

Location: http://www.mvps.org/dmcritchie/excel/shapes.htm      
Code:  Coding within this page at /code/shapes.txt
Home page: http://www.mvps.org/dmcritchie/excel/excel.htm
[View without Frames]
Have cut and pasted from a web site into Excel only to find lots of Shapes were added and didn't want any of them.  Shapes included buttons, etc. 

A shape can be assigned a hyperlink, by RClick on shape and assign hyperlink.  A shape can be created from a cell, from the Drawing Toolbar, from the Forms Toolbar among what I presume are many other places where shapes can be created.  More information on bitmaps in Excel can be found at More on Bitmaps

When copying and pasting from a webpage to Excel 2000 sometimes buttons get copied, you can delete the created shapes.  A better way of copying a web page is to Open the URL directly from Excel 2000, which gives the best rendition and column widths.
 

 ABCDEFG
1WorksheetShape TypeOnActionHyperlink TopLeftBotRight
2colorize on letterComment 3 4  B1L5
3Sheet6Text Box 117  d:\mysite\excel.htmD2D5
4Hotel RoomsComment 11 4  B11B15
5Hotel RoomsComment 12 4  J11L15
6Hotel RoomsComment 13 4  B13B17
7Hotel RoomsComment 14 4  J13L17
8SarniaList Box 58 vlookup.xls!ListBox5_Change G8I21
9Sheet10Picture 102613   E886E886
10Sheet15Drop Down 138     

You will find code for macros on the page in code/shapes.txt and possibly in code/buildtoc.txt as this page was originally split off from Build Table of Contents (buildtoc.htm).
 

This page contains some VBA macros.  If you need assistance to install or to use a macro please refer to my  «Getting Started with Macros« or delve into it deeper on my Install  page.
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"
    nRow = 1
    On Error Resume Next   'hyperlinks, topLeftCell, BottomRightCell
    For Each Wks In ActiveWorkbook.Worksheets
        For Each shp In Wks.Shapes
            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
            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            
            '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 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

Deleting Shapes (#delete)

' Dave Peterson showed us that you don't need a loop at all
' just two lines of code on the inside. (misc 2001-11-12)
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
  ActiveSheet.Shapes.SelectAll  '*** warning DELETE all Shapes
  Selection.Delete
End Sub
' Dave Peterson provided another example in programming 2001-11-13 ' to delete shapes with upper left corner within a selection range. ' -- had -- ActiveSheet.Range("a37:o50")) Is Nothing Then
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	
Missed the specific range in the above, it would be better to use Selection.  instead of ActivesSheet.Range("a37:o50") -- one person used BottomRightCell instead of TopLeftCell due to the way that multiple shapes hit one cell.  Modify to suit your needs.  You can manually select all objects on a sheet regardless of what cells are selected with Edit, GoTo (Ctrl+G), Special, Objects.
Sub selShapesOnSht()
    Dim shp As Shape
    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
Code for Particular Shapes:
If sp.AutoShapeType = msoShapeRectangle Then shp.Delete
If sp.AutoShapeType = msoShapeTriangle Then shp.Delete

Code to delete all Rectangular shapes on a sheet
Since you can't collectively select them as a group of rectangles you have to select all of the shapes and then check them one by one.  If there are no shapes then no shapes are tested.

Sub delAllRectangularShapesOnSht()
    Dim shp As Shape
    For Each shp In ActiveWorkbook.ActiveSheet.Shapes
      'check  shape code for Particular Shapes:
      If shp.AutoShapeType = msoShapeRectangle Then shp.Delete
    Next shp
End Sub
Code to find out who called a macro attached to a shape:
  msgbox "This macro was called by: " & _
     ActiveSheet.Shapes(Application.Caller).Name  'returns string 
To Manually create your own selection of shapes
A suggestion from Debra Dalgleish:  From customize, choose Commands (tab), Drawing (left side), Select Multiple Objects (right side) and drag to the drawing toolbar.  I only keep the drawing icon on my toolbar and use it to brigng up the actual drawing toolbar when needed. [Debra Dalgleish, 2006-05-24]

Find Shape at a Location (#find)

Dave Peterson, programming, 2002-06-16
Sub testme3()
    Dim myCell As Range, myShape As Shape    
    Set myCell = Range("A1")    
    For Each myShape In ActiveSheet.Shapes
        If Intersect(myShape.TopLeftCell, myCell) Is Nothing Then
            'do nothing
        Else
            MsgBox myShape.Name
            Exit For
        End If
    Next myShape        
End Sub

Create an Anchored Shape (#anchor)

Creating a shape anchored to the four borders of a cell.  Even though the shape is anchored to the four borders, you can manually move the image and change it's shape, but the image remains anchored to the four original points (cell's top, left, width, height)and will distort according to their movement of those borders. (see code on left below)

A shape's default .Placement property value is xlMoveAndSize.  Change it to xlFreeFloating if desired -- then the the image is anchored to the upper left corner of the spreadsheet and removal of columns does not affect it's position. (see code on right below)

JE McGimpsey, public.excel, 2004-08-30

    With Range("J4")
        ActiveSheet.Shapes.AddShape _
                Type:=msoShapeSmileyFace, _
                Left:=.Left, _
                Top:=.Top, _
                Width:=.Width, _
                Height:=.Height
    End With
 
With Range("K10")
        With ActiveSheet.Shapes.AddShape( _
                Type:=msoShapeSmileyFace, _
                Top:=.Top, Left:=.Left, _
                Width:=.Width, _
                Height:=.Height)
            .Placement = xlFreeFloating
        End With
    End With

Add shape (#add)

The following code was provided by David Duncan (email 2012-02-04) to insert “Bars” on a bar chart.
Sub ddStartInsertRectBar_Click()
  Set ddBarLength = ActiveSheet.Range("b" & ActiveCell.Row)
  With ActiveCell
        ActiveSheet.Shapes.AddShape _
                Type:=msoShapeRectangle, _
                Left:=.Left, _
                Top:=.Top + 5, _
                Width:=ddBarLength.Value * (.Width), _
                Height:=5
  End With
End Sub


Name of shape(s) in a Selection (#name)

Curious that you can have multiple shapes selected (Shift+click on shape), but for a single shape you cannot get a selection.count.  Incomplete check the newsgroup thread for later information. Ideally this should indicate exactly which if any shape was actually selected.  Single selection Chart or TextBox currently are not properly represented, nor when there are actually no shapes selected like when a single cell is selected.
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.Count
 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)
 If cnt = 0 Then
    '-- can at least report a single chart but not a single textboxl 
    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

Extract and Place Hyperlink from Shape into cell to the right (#extractlinktorightofshapes)

Sub ExtractLinkToRightOfShapes()
'Extract hyperlink and place to right of cells with shapes
'Dick Kusleika,  2003-03-26 in excel.links,  modified from
'  http://google.com/groups?threadm=efcLbz%238CHA.2820%40TK2MSFTNGP11.phx.gbl
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

Resizing Shapes (#resize)

Sizes are in points so 4 * 72 is 4 inches.  The following is a test and example you can add msgbox code to view results at various points if you wish to see something particular.
Sub Macro19()
    Dim wfactor As Double
    Dim shp As Shape
    
    'Delete all shapes to begin test
    For Each shp In ActiveWorkbook.ActiveSheet.Shapes
            shp.Delete   '****** warning DELETE all Shapes found
    Next shp

    'Create some shapes
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
        36#, 151.5, 202.5, 125.25).Select
    ActiveSheet.Shapes.AddShape(msoShapeOval, _
        544.5, 154.5, 57#, 41.25).Select
        
    'Resize each shape to 4 inches  height and width
    For Each shp In ActiveWorkbook.ActiveSheet.Shapes
            shp.Height = 4 * 72
            shp.Width = 4 * 72
    Next shp

    'Rescale each shape to 2 inches  width and scale height
    For Each shp In ActiveWorkbook.ActiveSheet.Shapes
            wfactor = 2 * 72 / shp.Width
            shp.Height = shp.Height * wfactor
            shp.Width = shp.Width * wfactor
    Next shp
		
     'insert an image and resize width
     Dim PictureName As String
     PictureName = "C:\copiedsite\dmcritchie\icons\bl-green.gif"
     Range("A4").Select
     ActiveSheet.Pictures.Insert(Picturename).Select
     Selection.Width = 4 * 72
		 MsgBox TypeName(Selection)   'shows up as   Picture 
End Sub

Dimensioning variables   (#dim)

Dimensioning variables for use with Options Explicit.  If you have simply used Dim xyz as variant you can find out the actual type that you used with  MsgBox typename(xyz) so you can replace variant by its actual type.  Similarly  MsgBox TypeName(Selection)  can be use to tell what the selection is. [See Slow Response]

Shortcut, Assign Shortcut to a Shape (#shortcut)

You can assign a Macro Shortcut to your Shape by right-clicking on Shape and then choosing Properties.  More information on shortcuts, Tool bars, and Event Macros.

Watermarks   (#watermarks)

Pictures in and out of Excel (#pictures)

Excel cannot display a picture that is not within a workbook, so you cannot display a picture on another file as if it were in Excel.  See pictures in the related area.
 
There are some alternatives:
This page was split off from Build Table of Contents, similar listings, working with Hyperlinks on February 8, 2002. 
 
[My Excel Pages -- home]    [INDEX to my site and the off-site pages I reference] 
[Site Search -- Excel]     [Go Back]    [Return to TOP

Please send your comments concerning this web page to: David McRitchie send email comments


Copyright © 1997 - 2006,  F. David McRitchie,  All Rights Reserved