In message <
[email protected]> of Mon, 29 Aug 2011 06:42:55 in
microsoft.public.excel.programming, Dave Peterson
You could loop through all the shapes...
Dim myShape as Shape
dim wks as worksheet
set wks = worksheets("Somesheetnamehere"
for each myshape in wks.shapes
msgbox myshape.name & vblf & myshape.topleftcell.address
next myshape
(Untested, uncompiled. Watch for typos.)
But there are lots of other things that can be shapes, too.
Comments are shapes. Autofilters are shapes.
I'd be much more careful and I'd start by reviewing the notes at Ron de Bruin's
site:
http://www.rondebruin.nl/controlsobjectsworksheet.htm
I run Excel 2003.
I had a problem with a change to a particular shape in successive files
from a client. It turned out that x.ActiveSheet.AutoMargins had been
changed from True to False.
This code can be dropped in a stand-alone module. It dumps the shapes on
the active sheet to the Immediate window. I do not cater for overfilling
the Immediate window which is limited to about 200 lines.
Option Explicit
Public Sub ShowShapes() ' Noddy to dump shapes on ActiveSheet
Dim GroupName As String
Dim I As Long, J As Long
Dim O As ShapeRange
Dim S As String
Dim V As Variant
Dim W As Variant
Debug.Print ActiveSheet.Shapes.Count & " shapes"
Debug.Print "Index" & vbTab & Left("Name" & ", ", 12) & _
Left(" Shapetype ", 2 + 20) & _
vbTab & _
Left("Left, Top, Width, Height" & " ", 32) & _
"AM, AS, M(L, T, R, B) Text"
I = 0
For Each V In ActiveSheet.Shapes
I = I + 1
If Not V.Name Like "Group *" Then
Debug.Print ShapeLine(I, 0, V)
Else
GroupName = V.Name
' Can't analyse a group without destroying it
Debug.Print ShapeLine(I, 0, V) & "consists of " & _
V.GroupItems.Count & " items"
Set O = V.Ungroup
J = 0
For Each W In O
J = J + 1: Debug.Print ShapeLine(I, J, W)
Next W
O.Group ' Recreate group
' Restore default name V is destroyed by ungroup
ActiveSheet.Shapes(I).Name = GroupName
End If
Next V
End Sub
Private Function ShapeLine(ByVal Imain As Long, ByVal Isub As Long, _
ByVal V As Shape) As String
ShapeLine = Imain & "." & Left(Isub & " ", 2) & vbTab & _
Left(V.Name & ", ", 12) & " " & _
TXAutoShapeType(V) & vbTab & _
Left(V.Left & ", " & V.Top & ", " & V.Width & ", " & _
V.Height & " ", 32) & _
ShapeText(V)
End Function
Private Function ShapeText(ByVal V As Shape) As String
Dim S As String
Dim I As Long
Dim J As Long
On Error Resume Next
With V.TextFrame
S = IIf(.AutoMargins, "Tr, ", "Fa, ") & _
IIf(.AutoSize, "Tr, ", "Fa, ")
S = S & "M(" & .MarginLeft & "," & .MarginTop & "," & _
.MarginRight & "," & .MarginBottom & ") "
With .Characters.Font
If Err.Number <> 0 Then _
Exit Function ' Return empty string if no textframe
On Error GoTo 0 ' Any errors now are fatal
S = S & "Font(" & .FontStyle & ", " & .Name & ", " & _
.Size & "): """
End With
On Error Resume Next
J = .Characters.Count
If Err.Number <> 0 Then
On Error GoTo 0 ' Any errors now are fatal
S = S & "NO TEXT"
Else
On Error GoTo 0 ' Any errors now are fatal
' Text limits itself to 255 bytes
For I = 1 To J Step 255
S = S & .Characters(Start:=I).Text
Next I
End If
End With
S = S & """"
ShapeText = S
End Function
Private Function TXAutoShapeType(ByVal x As Shape) As String
Dim S As String
Select Case x.AutoShapeType
Case msoShapeMixed: S = "msoShapeMixed"
Case msoShapeRectangle: S = "msoShapeRectangle"
Case Else
Debug.Print "Untranslated AutoShapeType: " & x.AutoShapeType & _
"."
Debug.Print "cf. x.AutoShapeType in Locals window to get name"
Debug.Assert False ' Force error
End Select
S = Left(S & " ", 20)
TXAutoShapeType = S
End Function
