---

Hallo VBAler,

ich suche und suche... und brauche noch einen oder zwei Tipps von Euch:

Am liebsten würde ich
1. die Bemaßungen per Makro abrufen und dann
2. die Bemaßungen ausrichten (besser gesagt, Bemaßungen außerhalb des Sheets einfangen).

Ich habe schon mal einen Code zusammengesetzt, der die Maße, die außerhalb des Sheets sind wieder einfängt. Jedoch komme ich nicht an die Winkelbemaßungen ran, da ich nicht weiß, wo die Positionen des Maßtextes abgespeichert sind.

Wer kann mir bei diesen Baustein helfen?

Viele Grüße,
Stefan

Code:

---

Public Sub EditDrawingDimensions()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument    ' Set a reference to the drawing document. This assumes a drawing document is active.

    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet    'Set a reference to the active sheet.

    Dim oPMitteLinie As Point2d
    Dim oPCenterText As Point2d
    Dim dmaxHeight As Double, dminHeight As Double, dmaxWidth As Double, dminWidth As Double

    dmaxHeight = oSheet.height - 0.7
    dminHeight = 0.7
   
    dmaxWidth = oSheet.Width - 0.7
    dminWidth = 0.7
   
    Dim oDrawingDim As DrawingDimension
    For Each oDrawingDim In oSheet.DrawingDimensions
        Set oPMitteLinie = Nothing
        On Error Resume Next
        Set oPMitteLinie = oDrawingDim.DimensionLine.MidPoint ' Get the position of the midpoint of the dimension line.
        If Not (oPMitteLinie Is Nothing) Then
            'change dimension position
            Set oPCenterText = oDrawingDim.Text.Origin
            If oDrawingDim.DimensionLine.Direction.x = 0 Then
                oPCenterText.y = oPMitteLinie.y
                If oPCenterText.x > dmaxWidth Then
                    dmaxWidth = dmaxWidth - 1
                    oPCenterText.x = dmaxWidth
                ElseIf oPCenterText.x < dminWidth Then
                    dminWidth = dminWidth + 1
                    oPCenterText.x = dminWidth
                End If
            ElseIf oDrawingDim.DimensionLine.Direction.y = 0 Then
                oPCenterText.x = oPMitteLinie.x
                If oPCenterText.y > dmaxHeight Then
                    dmaxHeight = dmaxHeight - 1
                    oPCenterText.y = dmaxHeight
                ElseIf oPCenterText.y < dminHeight Then
                    dminHeight = dminHeight + 1
                    oPCenterText.y = dminHeight
                End If
            Else
                ' Bemassung ist schräg
            End If
            oDrawingDim.Text.Origin = oPCenterText
   
            'oDrawingDim.Text.FormattedText = "<DimensionValue/> <StyleOverride Bold='True' Italic='True'>(Metric)</StyleOverride>"            ' Add some formatted text to all dimensions on the sheet.
        End If
    Next
End Sub

---

------------------
IV2008

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP