AW: Größem/Maße von Objekten anzeigen lassen
13.01.2010 15:30:05
Objekten
Hallo Jan,
hier ein Makro zur Beschriftung der Shape-Objekte.
Die Shapes werden in einer Schleife abgefragt.
Gruß
Franz
'Erstellt mit Excel 2003
Sub aaShapeMassBeschriftung()
Dim X0#, Y0#, PXW#, PYW#, PXH#, PYH#
Dim wks As Worksheet
Const HT# = 10
Const WT# = 30
Dim oShape As Shape, sShape$, oText As Shape
On Error GoTo Fehler
Set wks = ActiveSheet
For Each oShape In wks.Shapes
ActiveWindow.ScrollColumn = oShape.TopLeftCell.Column
ActiveWindow.ScrollRow = oShape.TopLeftCell.Row
If Left(oShape.Name, 6) = "MassW_" Or Left(oShape.Name, 6) = "MassH_" Then
'do nothing - Bemassungs-Label
Else
If MsgBox("Shape beschriften" & vbLf & oShape.Name & " @ " & oShape.TopLeftCell.Address, _
_
vbQuestion + vbYesNo, "Shape beschriften") = vbYes Then
With oShape
'Daten des Shape
sShape = .Name
X0 = .Left
Y0 = .Top
'Position für horizontale Beschriftung
PXW = X0 + .Width / 2
PYW = Y0 + 2
'Position für vertikale Beschriftung
PXH = X0 + 2
PYH = Y0 + .Height / 2
End With
'Label für horizontale Beschriftung
Set oText = wks.Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
Left:=PXW - WT / 2, Top:=PYW, Width:=WT, Height:=HT)
With oText
With .TextFrame.Characters
.Text = oShape.Width
.Font.Size = 8
End With
.Left = PXW - WT / 2
.Name = "MassW_" & sShape
End With
'Label für vertikale Beschriftung
Set oText = wks.Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
Left:=PXH, Top:=PYH - HT / 2, Width:=WT, Height:=HT)
With oText
With .TextFrame.Characters
.Text = oShape.Height
.Font.Size = 8
End With
.Top = PYH - HT / 2
.Name = "MassH_" & sShape
End With
End If
End If
Next
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 70 'Beschriftung wird 2. Mal zugeordnet
wks.Shapes("MassW_" & sShape).Delete
wks.Shapes("MassH_" & sShape).Delete
Resume
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Sub aaShapeBeschriftungenLoeschen()
'Erstellt Beschriftungslabels löschen
Dim wks As Worksheet
Dim oShape As Shape, sShape$, oText As Shape
Set wks = ActiveSheet
If MsgBox("Shape-Bemassungen löschen", _
vbQuestion + vbYesNo, "Shape beschriften") = vbYes Then
For Each oShape In wks.Shapes
With oShape
If Left(.Name, 6) = "MassW_" Or Left(.Name, 6) = "MassH_" Then
.Delete
End If
End With
Next
End If
End Sub