Größem/Maße von Objekten anzeigen lassen

Forumthread: Größem/Maße von Objekten anzeigen lassen

Objekten

Hallo zusammen,
besteht die Möglichkeit sich die Maße (Länge und Breite) , z.B. direkt an den Randlinien des Objektes, anzeigen zu lassen?
Gruß,
Jan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Standardmäßig wohl nicht,...

13.01.2010 15:00:40

Luc:-?

...Jan,
Xl ist ja kein CAD-Pgm und die Objekte sind quasi nur Dekoration. Da müsste schon was Entsprechendes pgmiert wdn...
Gruß Luc :-?

AW: Größem/Maße von Objekten anzeigen lassen

13.01.2010 15:07:51

Objekten

Hallo
Die Maße anzeigen zu lassen geht ohne Probleme mit z.B.
Beispiel an einem gezeichneten Rechteck:

Sub Makro1()
With ActiveSheet.Shapes("Rechteck 1")
MsgBox "Höhe: " & .Height
MsgBox "Breite: " & .Width
End With
End Sub

Wie willst Du die Daten angezeigt bekommen?
In einer Zelle? In einer Textbox? Als freien Text?
Gruß Jens

...Er schrieb aber "...direkt am Rand...

13.01.2010 15:25:32

Luc:-?

...des Objekts..." und das dürfte wohl deutlich aufwendiger zu pgmieren sein, Jens...
Gruß Luc :-?

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

Na Jens, an sowas dachte ich... ;-) orT

13.01.2010 15:33:49

Luc:-?

Mit Gruß an Franz!
Luc :-?

@Luc: Deshalb auch noch meine Nachfrage ;o) (oT)

13.01.2010 16:24:33

Jens

Danke, aber ich habe da noch ein Problem

13.01.2010 21:19:35

Jan

Erstmal danke für eure schnellen Antworten! Ich bin beeindruckt ;)
Leider bin ich eher ein durchschnittlich erfahrener Excel-Benutzer und daher tue ich mich schwer eure Anweisungen richtig umzusetzen.
Verstehe ich das richtig, dass ich im "Visual-Basic-Editor" hinter den Schritten zum Erstellen z.B. eines Rechtecks einfach dein "Makro zur Beschriftung der Shape-Objekte" anfüge?
Wenn ja, dann erhalte ich immer Fehlermeldung "Fehler beim kompilieren: Syntaxfehler".
Den fehlerhaten Pfad habe ich fett markiert:

'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

Gruß,
Jan

Das liegt wohl an der Forumssoftware,...

13.01.2010 23:59:44

Luc:-?

...Jan,
die setzt hier eigenmächtig Zeilentrenner/Fortsetzungszeichen _. 2 davon hintereinander und kein Text dazwischen ist zuviel. Der 2. _ ist der absichtlich gesetzte, die beiden anderen hat die FSw zusätzl eingefügt, weg damit und keine Lücke zwischen oShape.TopLeftCell.Adress lassen!
Gruß Luc :-?

Beliebteste Forumthreads (12 Monate)

Größem/Maße von Objekten anzeigen lassen

Forumthread: Größem/Maße von Objekten anzeigen lassen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread