Code:
Option ExplicitPrivate Sub TextWidth()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oTB As TitleBlock
Set oTB = oSheet.TitleBlock
Dim oSketch As DrawingSketch
Call oTB.Definition.Edit(oSketch)
Dim oTBox As TextBox
Set oTBox = oSketch.TextBoxes(1) ' <----- Hier anpassen für deine TextBox
Dim sResultText As String
sResultText = oTB.GetResultText(oTBox)
Dim objXML As msxml2.DOMDocument
Set objXML = New msxml2.DOMDocument
' Ersetzen der iProp Verlinkung durch Text
Dim sXML As String
sXML = oTBox.FormattedText
Dim oAttr As IXMLDOMAttribute
Dim oSONode As IXMLDOMNode
Dim oPNode As IXMLDOMNode
Dim oNode As IXMLDOMNode
Dim oChildNode As IXMLDOMNode
' Create a SyleOverride node
Set oSONode = objXML.createNode(msxml2.NODE_ELEMENT, "StyleOverride", "") 'StyleOverride
Set oAttr = objXML.createAttribute("FontSize")
oAttr.Value = Replace(CStr(Round(oTBox.Style.FontSize, 2)), ".", ",")
'Add the attribute to the node.
Call oSONode.Attributes.setNamedItem(oAttr)
' Falls kein XML-Objekt generiert werden konnte, bauen wir eines (kommt bei einem Property als Inhalt nie vor, aber bei reinem Text)
If Not objXML.loadXML(sXML) Then 'sXML is the string with XML'
'insert StyleOverride Node
Call objXML.appendChild(oSONode)
'insert regular text (property value)
oSONode.Text = sResultText
Else
' Gibt es schon einen PropertyNode aber ohne StyleOverride?
For Each oNode In objXML.ChildNodes
If oNode.baseName = "Property" And oNode.Text = "Rohmass" Then
Set oPNode = oNode
'insert StyleOverride Node
Call objXML.replaceChild(oSONode, oNode)
'insert regular text (property value)
oSONode.Text = sResultText
Exit For
ElseIf oNode.baseName = "StyleOverride" Then
For Each oChildNode In oNode.ChildNodes
If oChildNode.baseName = "Property" And oNode.Text = "Rohmass" Then
Set oPNode = oNode
'insert StyleOverride Node
Call objXML.replaceChild(oSONode, oNode)
'insert regular text (property value)
oSONode.Text = sResultText
Exit For
End If
Next
End If
Next
End If
'write back XML string to textbox
oTBox.FormattedText = objXML.XML
' jetzt sollte ein XML Tag mit dem StyleOverride und dem Inhalt des Rohmass iProps vorhanden sein
' Prüfen und skalieren der Textgröße
Do While oTBox.Width < oTBox.FittedTextWidth
For Each oAttr In oSONode.Attributes
If oAttr.baseName = "FontSize" Then
If CDbl(oAttr.nodeValue) - 0.01 <= 0.2 Then
Call MsgBox("Minimale Schriftgröße erreicht. Abbruch", vbCritical, "Scale text size")
Exit Do 'Notausstieg, bevor der Text unleserlich klein wird
End If
oAttr.nodeValue = Replace(oAttr.nodeValue - 0.01, ".", ",")
oTBox.FormattedText = objXML.XML
End If
Next
Loop
' Wiederherstellung der iProp Verlinkung
If Not oPNode Is Nothing Then
oSONode.Text = ""
Call oSONode.appendChild(oPNode)
End If
'write back XML string to textbox
oTBox.FormattedText = Replace(objXML.XML, Chr(13) & Chr(10), "")
Call oTB.Definition.ExitEdit(True)
End Sub