Code:
Option ExplicitPrivate Sub namesplit()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oFilename As String
oFilename = oDrawDoc.FullDocumentName
Dim oArray() As String
oArray = Split(oFilename, "\")
oArray = Split(oArray(UBound(oArray)), "_")
Dim dn As String
dn = oArray(LBound(oArray))
Dim zn As String
oArray = Split(oArray(UBound(oArray)), ".")
zn = oArray(LBound(oArray))
Dim oPropset As PropertySet
Set oPropset = oDrawDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'user defined props
On Error Resume Next
If oPropset.Item("Dateiname").Name <> "Dateiname" Then
Call oPropset.Add(dn, "Dateiname")
Else
If oPropset.Item("Dateiname").Value <> dn Then
oPropset.Item("Dateiname").Value = dn
End If
End If
If oPropset.Item("Zeichnungsnr").Name <> "Zeichnungsnr" Then
Call oPropset.Add(zn, "Zeichnungsnr")
Else
If oPropset.Item("Zeichnungsnr").Value <> zn Then
oPropset.Item("Zeichnungsnr").Value = zn
End If
End If
End Sub