Working With Shapes In Excel VBA

Shapes From Drawing Toolbar and Forms Toolbar

Got any Excel Questions? Free Excel Help

WORKING WITH SHAPES

Shapes are those from the Drawing toolbar or the Forms toolbar.

LISTING SHAPE PROPERTIES OF ACTIVE WORKSHEET

The code below will create a new Worksheet where the Shape Properties are listed under their appropriate heading.

Sub GetShapeProperties()

    Dim sShapes As Shape, lLoop As Long

    Dim wsStart As Worksheet, WsNew As Worksheet

    

    ''''''''''''''''''''''''''''''''''''''''''''''''

    ''''''''''LIST PROPERTIES OF SHAPES'''''''''''''

    ''''''''''Dave Hawley www.ozgrid.com''''''''''''

    ''''''''''''''''''''''''''''''''''''''''''''''''

    

    Set wsStart = ActiveSheet

    Set WsNew = Sheets.Add

     

    'Add headings for our lists. Expand as needed

    WsNew.Range("A1:F1") = _

     Array("Shape Name", "Shape Type", "Height", "Width", "Left", "Top")

     

     

    'Loop through all shapes on active sheet

    For Each sShapes In wsStart.Shapes

        'Increment Variable lLoop for row numbers

        lLoop = lLoop + 1

        With sShapes

            'Add shape properties

            WsNew.Cells(lLoop + 1, 1) = .Name

            WsNew.Cells(lLoop + 1, 2) = .OLEFormat.Object.Name

            WsNew.Cells(lLoop + 1, 3) = .Height

            WsNew.Cells(lLoop + 1, 4) = .Width

            WsNew.Cells(lLoop + 1, 5) = .Left

            WsNew.Cells(lLoop + 1, 6) = .Top

            'Follow the same pattern for more

        End With

    Next sShapes

     

    'AutoFit Columns.

    WsNew.Columns.AutoFit

End Sub

LISTING SHAPE PROPERTIES OF ALL WORKSHEETS

The code below will create a new Worksheet where the Shape Properties from all Worksheets are listed under their appropriate heading.

Sub GetShapePropertiesAllWs()

    Dim sShapes As Shape, lLoop As Long

    Dim WsNew As Worksheet

    Dim wsLoop As Worksheet

    

    ''''''''''''''''''''''''''''''''''''''''''''''''

    ''''''''''LIST PROPERTIES OF SHAPES'''''''''''''

    ''''''''''Dave Hawley www.ozgrid.com''''''''''''

    ''''''''''''''''''''''''''''''''''''''''''''''''

    

    Set WsNew = Sheets.Add

     

    'Add headings for our lists. Expand as needed

    WsNew.Range("A1:G1") = _

     Array("Shape Name", "Shape Type", "Height", "Width", "Left", "Top", "Sheet Name")

     

    'Loop through all Worksheet

    For Each wsLoop In Worksheets

        'Loop through all shapes on Worksheet

        For Each sShapes In wsLoop.Shapes

            'Increment Variable lLoop for row numbers

            lLoop = lLoop + 1

            With sShapes

                'Add shape properties

                WsNew.Cells(lLoop + 1, 1) = .name

                WsNew.Cells(lLoop + 1, 2) = .OLEFormat.Object.name

                WsNew.Cells(lLoop + 1, 3) = .Height

                WsNew.Cells(lLoop + 1, 4) = .Width

                WsNew.Cells(lLoop + 1, 5) = .Left

                WsNew.Cells(lLoop + 1, 6) = .Top

                'Follow the same pattern for more

                WsNew.Cells(lLoop + 1, 7) = wsLoop.name

            End With

        Next sShapes

    Next wsLoop

     

    'AutoFit Columns.

    WsNew.Columns.AutoFit

End Sub

LISTING SHAPE PROPERTIES OF SOME WORKSHEETS

The code below will create a new Worksheet where the Shape Properties from chosen Worksheets (those NOT named in Select Case) are listed under their appropriate heading.

Sub GetShapePropertiesSomeWs()

    Dim sShapes As Shape, lLoop As Long

    Dim WsNew As Worksheet

    Dim wsLoop As Worksheet

    

    ''''''''''''''''''''''''''''''''''''''''''''''''

    ''''''''''LIST PROPERTIES OF SHAPES'''''''''''''

    ''''''''''Dave Hawley www.ozgrid.com''''''''''''

    ''''''''''''''''''''''''''''''''''''''''''''''''

    

    Set WsNew = Sheets.Add

     

    'Add headings for our lists. Expand as needed

    WsNew.Range("A1:G1") = _

     Array("Shape Name", "Shape Type", "Height", "Width", "Left", "Top", "Sheet Name")

     

    'Loop through all Worksheet

    For Each wsLoop In Worksheets

        Select Case UCase(wsLoop.name)

           Case "SHEET5", "SHEET8" 'add sheet names to exclude

              'Do nothing

           Case Else

            'Loop through all shapes on Worksheet

            For Each sShapes In wsLoop.Shapes

                'Increment Variable lLoop for row numbers

                lLoop = lLoop + 1

                With sShapes

                    'Add shape properties

                    WsNew.Cells(lLoop + 1, 1) = .name

                    WsNew.Cells(lLoop + 1, 2) = .OLEFormat.Object.name

                    WsNew.Cells(lLoop + 1, 3) = .Height

                    WsNew.Cells(lLoop + 1, 4) = .Width

                    WsNew.Cells(lLoop + 1, 5) = .Left

                    WsNew.Cells(lLoop + 1, 6) = .Top

                    'Follow the same pattern for more

                    WsNew.Cells(lLoop + 1, 7) = wsLoop.name

                End With

            Next sShapes

         End Select

    Next wsLoop

     

    'AutoFit Columns.

    WsNew.Columns.AutoFit

End Sub

Got any Excel/VBA Questions? Free Excel Help