Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Frame
BildScreenshot zu Frame Frame-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Label
BildScreenshot zu Label Label-Seite mit Beispielarbeitsmappe aufrufen

Größem/Maße von Objekten anzeigen lassen | Herbers Excel-Forum


Betrifft: Größem/Maße von Objekten anzeigen lassen von: Jan
Geschrieben am: 13.01.2010 12:56:46

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

  

Betrifft: Standardmäßig wohl nicht,... von: Luc:-?
Geschrieben am: 13.01.2010 15:00:40

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


  

Betrifft: AW: Größem/Maße von Objekten anzeigen lassen von: Jens
Geschrieben am: 13.01.2010 15:07:51

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


  

Betrifft: ...Er schrieb aber "...direkt am Rand... von: Luc:-?
Geschrieben am: 13.01.2010 15:25:32

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


  

Betrifft: AW: Größem/Maße von Objekten anzeigen lassen von: fcs
Geschrieben am: 13.01.2010 15:30:05

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



  

Betrifft: Na Jens, an sowas dachte ich... ;-) orT von: Luc:-?
Geschrieben am: 13.01.2010 15:33:49

Mit Gruß an Franz!
Luc :-?


  

Betrifft: @Luc: Deshalb auch noch meine Nachfrage ;o) (oT) von: Jens
Geschrieben am: 13.01.2010 16:24:33




  

Betrifft: Danke, aber ich habe da noch ein Problem von: Jan
Geschrieben am: 13.01.2010 21:19:35

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


  

Betrifft: Das liegt wohl an der Forumssoftware,... von: Luc:-?
Geschrieben am: 13.01.2010 23:59:44

...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 :-?


Beiträge aus den Excel-Beispielen zum Thema "Größem/Maße von Objekten anzeigen lassen"