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.
|2||colorize on letter||Comment 3||4||B1||L5|
|3||Sheet6||Text Box 1||17||d:\mysite\excel.htm||D2||D5|
|4||Hotel Rooms||Comment 11||4||B11||B15|
|5||Hotel Rooms||Comment 12||4||J11||L15|
|6||Hotel Rooms||Comment 13||4||B13||B17|
|7||Hotel Rooms||Comment 14||4||J13||L17|
|8||Sarnia||List Box 5||8||vlookup.xls!ListBox5_Change||G8||I21|
|10||Sheet15||Drop Down 13||8|
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
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 SubMissed 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 SubCode 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 SubCode to find out who called a macro attached to a shape:
msgbox "This macro was called by: " & _ ActiveSheet.Shapes(Application.Caller).Name 'returns stringTo Manually create your own selection of shapes
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
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
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
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
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
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
=HYPERLINK("c:\camera-canon20d\img_" & "TEXT(A2,"0000") & ".jpg","[pic]")
="<img src=""file:///c:/camera-canon20d/img_" & TEXT(A2,"0000") & ".jpg"" alt=""[" & TEXT(A2,"0000") & "["" title=""" & B2 & " width=""250px"">"
<img src="file:///c:/camera-canon20d/img_0109.jpg" alt="" title="Bumble Bee" width="250">
Please send your comments concerning this web page to: David McRitchie send email comments
Copyright © 1997 - 2006, F. David McRitchie, All Rights Reserved