Information about Shapes!

In the following code different information about Shapes on the current worksheet is spent. If you need still more information, then you look with F2 into the object catalog or also in the "Local Window", if you go with F8 step by step through the code. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Module1"

Option Explicit
Public Sub Shape_Info()
Dim wksSheetNew As Worksheet
Dim wksSheet As Worksheet
Dim wksTMP As Worksheet
Dim shpShape As Shape
Dim lngRow As Long
On Error GoTo Fin
Application.ScreenUpdating = False
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name = "Info_Shapes" Then
Application.DisplayAlerts = False
wksTMP.Delete
Application.DisplayAlerts = True
End If
Next wksTMP
Set wksSheet = ActiveSheet
If wksSheet.Shapes.Count < 1 Then
MsgBox "No Shapes in the current worksheet!"
Exit Sub
End If
Set wksSheetNew = Worksheets.Add(Before:=Worksheets(1))
wksSheetNew.Name = "Info_Shapes"
For Each shpShape In wksSheet.Shapes
With wksSheetNew
.Cells(lngRow + 1, 2) = shpShape.Name
.Cells(lngRow + 1, 2).Font.Bold = True
.Cells(lngRow + 1, 2).HorizontalAlignment = xlRight
.Cells(lngRow + 1, 1) = "Name"
.Cells(lngRow + 2, 2) = shpShape.Type
.Cells(lngRow + 2, 1) = "Type"
.Cells(lngRow + 3, 2) = shpShape.AutoShapeType
.Cells(lngRow + 3, 1) = "AutoShapeType"
.Cells(lngRow + 4, 2) = shpShape.Height
.Cells(lngRow + 4, 1) = "Height"
.Cells(lngRow + 5, 2) = shpShape.Width
.Cells(lngRow + 5, 1) = "Width"
.Cells(lngRow + 6, 2) = shpShape.Top
.Cells(lngRow + 6, 1) = "Top"
.Cells(lngRow + 7, 2) = shpShape.Left
.Cells(lngRow + 7, 1) = "Left"
.Cells(lngRow + 8, 2) = shpShape.TopLeftCell.Column
.Cells(lngRow + 8, 1) = "TopLeftCell.Column"
.Cells(lngRow + 9, 2) = shpShape.TopLeftCell.Row
.Cells(lngRow + 9, 1) = "TopLeftCell.Row"
.Cells(lngRow + 10, 2) = shpShape.TopLeftCell.Address(0, 0)
.Cells(lngRow + 10, 1) = "TopLeftCell.Address"
.Cells(lngRow + 10, 2).HorizontalAlignment = xlRight
If shpShape.OnAction = "" Then
.Cells(lngRow + 11, 2) = "No macro assigned!"
Else
.Cells(lngRow + 11, 2) = shpShape.OnAction
.Cells(lngRow + 11, 2).Font.ColorIndex = 3
End If
.Cells(lngRow + 11, 1) = "OnAction"
.Cells(lngRow + 11, 2).HorizontalAlignment = xlRight
lngRow = lngRow + 12
End With
Next
With wksSheetNew
.Range(Cells(1, 1), _
Cells(.Rows.Count, 1).End(xlUp)).Rows.Font.Bold = True
.Columns("A:B").AutoFit
End With
Fin:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set wksSheetNew = Nothing
Set wksSheet = Nothing
End Sub

The following code belonged In "Module2"

Option Explicit
Option Private Module
Sub Big()
With ActiveSheet.Shapes(Application.Caller)
.LockAspectRatio = True
.Height = .Height * 2
.Width = .Width * 2
.Rotation = 0#
.OnAction = "Small"
End With
End Sub
Sub Small()
With ActiveSheet.Shapes(Application.Caller)
.LockAspectRatio = True
.Height = .Height / 2
.Width = .Width / 2
.Rotation = 0#
.OnAction = "Big"
End With
End Sub


Sample 2003

Sample 2007

Kommentare

  1. Hi,

    I want to save a chart that is stored on a excel sheet as msoOleControlObject to disk. I was able to save a chart object using code below. Any help would be appreciated.

    if (_sheet.Index == (int)WorkSheetIndex.CustomGraphs)
    {
    switch (_sheet.Shapes.Item(iShapeIndex).Type)
    {
    case MsCore.MsoShapeType.msoChart:
    MsExcel.ChartObject objChart = (MsExcel.ChartObject)_sheet.Shapes.Item(iShapeIndex).DrawingObject;
    objChart.Chart.Export(sImageFilePath + sImageFileName, sImageFileType, System.Type.Missing);
    break;

    AntwortenLöschen

Kommentar veröffentlichen

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...