Shapes

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.
 

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).
 

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)

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

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 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 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

  msgbox "This macro was called by: " & _
     ActiveSheet.Shapes(Application.Caller).Name  'returns string 

Find Shape at a Location (#find)

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)

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)

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)

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)

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)

Shortcut, Assign Shortcut to a Shape (#shortcut)

Watermarks   (#watermarks)

• Watermark, printing of, Robert Rosenberg. 
• Creating a watermark in Excel with VBA. «, Kenneth Ives (codetoad, 3/30/2003), with Word Art
• Print a Watermark on Excel Worksheet, Neil J. Rubenking in PC Mag (2005-01-05), text only article
• find more on Google
• Bob Phillips' page
• Debra Dalgleish shows how to use pictures in Comment boxes. (okay so it's not a watermark)
• Printing watermarks behind your data to identify confidential information   [archive 2000-07-11 «]
  Intro to the above article at Visually mark sensitive worksheets with a VBA macro - elementkjournals.com, Sean Kavanagh, Feb 2002 in EKJ online.
• How to create a watermark in Word 97 and in Word 2000 (probably much the same in Excel)

Pictures in and out of Excel (#pictures)

• Use of a hyperlink to view picture in your default application for the file type:
  =HYPERLINK("c:\camera-canon20d\img_" & "TEXT(A2,"0000") & ".jpg","[pic]")
• Create HTML code with a macro (Excel to HTML conversions (XL2HTML), or
• Create HTML code with worksheet formulas to paste into a webpage.
  ="<img src=""file:///c:/camera-canon20d/img_" & TEXT(A2,"0000") & ".jpg"" alt=""[" & TEXT(A2,"0000") & "["" title=""" & B2 & " width=""250px"">"
  to generate:
  <img src="file:///c:/camera-canon20d/img_0109.jpg" alt="[0109]" title="Bumble Bee" width="250">&nbsp;

Related (#related)

• Andrew's Blog, drawing shapes, squares, circles, composite assembly, 2004-05-09.
• Build Table of Contents, similar listings, working with Hyperlinks.  Create a Table of Contents list complete with hyperlinks in XL97 and up, as well as considerations in a similar listing for XL95 without hyperlinks. Additional information for creating Excel documentation.
• Pictures and Photos
  Picture within a Comment, Debra Dalgleish
  Displaying a picture based on a cell value, John McGimpsey,
  Additional links for Merge Pictures and Words in Excel, like in a catalog
• Posting on covering comment triangles with colored triangles, Dave Peterson, 2003-04-25 (see colors.htm)
• Color Palette and the 56 Excel ColorIndex Colors
• Graphics Exporter addin «, Andy J. Pope, will allow you to export pictures, shapes, charts and more to image files.
• Link to a Chart or Shape, faked by an Event Macro, see Hyperlinks in Excel, Jon Peltier, some notes on hyperlinks including how to fake a link to a chart.
• Textbox on Shapes page.
• Shapes like pictures, cell comment boxes, and text boxes can be hidden/unhidden with a Shortcut.  Ctl+6 Alternates between hiding objects, displaying objects, and displaying placeholders for objects.
• Slow Response, shapes are graphics and lots of them will affect graphical memory.
• Watermarks see topic above.
• XL2GIF and Manipulations creates a gif or other picture file from an Excel image.

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

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