Public Sub DimensionCenterText()

' Zentriert den Maßtext auf der Maßhilfslinie
' bei horizontalen und vertikalen Bemaßungen
'
'---------------------------------------------------------------------------------
'(c) Lothar Boekels 2008
'    Boekels Ingenieurbüro für Maschinenbau
'    Schroerskamp 74
'    41069 Mönchengladbach
'    kontakt@boekels-online.de
'---------------------------------------------------------------------------------
'
' Versionshinweise:
' 00 : 01.03.2008 : Boekels : Erstellung
'

    
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument

    ' Determine if there are any dimensions in the select set.
    Dim oSelectSet As SelectSet
    Set oSelectSet = oDrawDoc.SelectSet
    Dim colDimensions As New Collection
    Dim i As Long
    For i = 1 To oSelectSet.Count
        If TypeOf oSelectSet.Item(i) Is DrawingDimension Then
            ' Add any dimensions to the collection. We need to save them
            ' in something besides the selection set because once we start
            ' manipulating them the select set will be cleared.
            colDimensions.Add oSelectSet.Item(i)
        End If
    Next
    
    Dim oDimension As DrawingDimension
    Dim oPMitteLinie As Point2d
    Dim oPCenterText As Point2d

    For i = 1 To colDimensions.Count
        Set oDimension = colDimensions.Item(i)

        ' Get the position of the midpoint of the dimension line.
        ' This is the position the text will be aligned to.
            
        ' Change the position of the dimension.
        Set oPMitteLinie = oDimension.DimensionLine.MidPoint
        Set oPCenterText = oDimension.Text.Origin
        
        'MsgBox " Mittelpunkt Maßhilfslinie : X=" & CStr(Round(oPMitteLinie.X, 3)) & "   Y=" & CStr(Round(oPMitteLinie.Y, 3)) & vbCrLf & _
               " Mittelpunkt Maßtext       : X=" & CStr(Round(oPCenterText.X, 3)) & "   Y=" & CStr(Round(oPCenterText.Y, 3))
    
        If oDimension.DimensionLine.Direction.X = 0 Then
            oPCenterText.Y = oPMitteLinie.Y
        ElseIf oDimension.DimensionLine.Direction.Y = 0 Then
            oPCenterText.X = oPMitteLinie.X
        Else
            ' Bemassung ist schräg
        End If
        
        oDimension.Text.Origin = oPCenterText
    Next
End Sub