List AlternativeText names for every shape on a worksheet

[Guest]

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

SHAPENo = ActiveSheet.Shapes.Count
ActiveSheet.Hyperlinks.Delete
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]

Ewan,

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


HTH,
Bernie
MS Excel MVP

 

[Guest]

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

Sub Count_and_List_Photos()

Dim SHAPENo As Integer
Dim Response
Dim shapename As String

Application.ScreenUpdating = False

Columns("S:S").ClearContents
Range("S1").Select
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
Next
End With
Else
' Do nothing
End If
Columns("S:S").Select
Selection.sort Key1:=Range("S2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Range("S2:S3").Select
Selection.Delete Shift:=xlUp

Application.ScreenUpdating = True

End Sub