List AlternativeText names for every shape on a worksheet



Hi all,

I am trying to write a code that will create a list of all the
AlternativeText (HTML) names for every shape on a worksheet. The 'shapes'
are photographs and the AlternativeText names are the serial numbers required
for ordering copies of them. i want to be able to add and delete photographs
to the worksheet until I am happy with th ones I have (around 100), then list
them for convenience of ordering.

I have been able to get a msgbox to display each of the numbers in turn, but
not list them at the same time. Here's what I have so far:

Dim SHAPENo As Integer
Dim Msg, Style, Title, Response
Dim shapename As Long

Msg = "Do you want to list photos?" ' Define message.
Style = vbYesNo ' Define buttons.
Title = "List Photos?" ' Define title.


SHAPENo = ActiveSheet.Shapes.Count
MsgBox "Number of Photos: " & SHAPENo
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
With ActiveSheet.Shapes
For sh = 1 To SHAPENo
With .Item(sh)
shapename = .AlternativeText ' Get serial number.
MsgBox shapename
End With
Next sh
End With
Else ' User chose No.
MsgBox "no" ' Do nothing.
End If

Bernie Deitrick


You should be able to use this to list the values in column A:

Dim mySh As Shape
For Each mySh In ActiveSheet.Shapes
Cells(Rows.Count,1).End(xlUp)(2).Value = mySh.AlternativeText
Next mySh

MS Excel MVP


Hi Bernie,

So simple!! If only I'd posted before attempting it myself...!!

I got it working finally before I saw your post (I had somehow entered the
code mistakenly into the sheet rather than a module), but thanks for your

Sub Count_and_List_Photos()

Dim SHAPENo As Integer
Dim Response
Dim shapename As String

Application.ScreenUpdating = False

ActiveCell.FormulaR1C1 = "Selected Photos"
With Selection
.WrapText = True
End With
Columns("S:S").ColumnWidth = 8.29

SHAPENo = ActiveSheet.Shapes.Count
MsgBox "Number of Photos: " & SHAPENo
Response = MsgBox("Do you want to list photos?", vbYesNo, "List Photos?")
If Response = vbYes Then
With ActiveSheet.Shapes
For sh = 1 To SHAPENo
With .Item(sh)
shapename = .AlternativeText
iNextFree = Cells(Rows.Count, "s").End(xlUp).Row + 1
Cells(iNextFree, "s").Value = shapename
End With
End With
' Do nothing
End If
Selection.sort Key1:=Range("S2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

Selection.Delete Shift:=xlUp

Application.ScreenUpdating = True

End Sub

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question