Sub SetzeMasseEinheit_kg()
  Dim swModel As SldWorks.ModelDoc2
  Dim swModelDocExt As ModelDocExtension
  Dim swPropMan1 As CustomPropertyManager
  Dim swPropMan2 As CustomPropertyManager
  Dim MaterialName1 As String
  Dim MaterialName2 As String
  Dim Eigenschaftsname As String
  Dim sConfigName As String
  Dim Gewichtseigenschaftsname As String
  Dim Filename As String, PL As String, Artikelnr As String
  Dim Cfg_Anzahl As Integer
  Dim i As Integer, ppos As Integer
  Dim RetInt As Integer
  Dim vConfNameArr               As Variant
  Dim swConfig                As SldWorks.Configuration
  Dim swPart                  As SldWorks.PartDoc
  Dim vMatProp      As Variant
  Dim wurdegeloest As Boolean, verbunden As Boolean
  Eigenschaftsname = "Masseneinheit"
  
  Set swApp = Application.SldWorks
  Set swModel = swApp.ActiveDoc
  Set swModelDocExt = swModel.Extension
  Set swPropMan1 = swModelDocExt.CustomPropertyManager("")
  Path = swModel.GetPathName
  Filename = Mid$(Path, InStrRev(Path, "\") + 1) ' With extension
 
  ' Masseneinheit ändern
  boolstatus = swModelDocExt.SetUserPreferenceInteger(swUnitsMassPropMass, swDetailingNoOptionSpecified, swUnitsMassPropMass_Kilograms)
  
  ' Eigenschaft zentral hinzufügen
  RetInt = swPropMan1.Add2(Eigenschaftsname, swCustomInfoText, "kg")
  If RetInt = 0 Then
    RetInt = swPropMan1.Set(Eigenschaftsname, "kg")
  End If
  If swModel.GetType = 1 Or swModel.GetType = 2 Then
  ' Gewindedarstellungen verbessern
    boolstatus = swModelDocExt.UpgradeLegacyCThreads
  ' Eigenschaft in den Konfigurationen löschen
  ' Gewichtseigenschaft hinzufügen
  
    vConfNameArr = swModel.GetConfigurationNames
    For i = 0 To UBound(vConfNameArr)
      sConfigName = vConfNameArr(i)
      'Set swConfig = swModel.GetConfigurationByName(sConfName)
      Set swPropMan2 = swModelDocExt.CustomPropertyManager(sConfigName)
      RetInt = swPropMan2.Delete(Eigenschaftsname)
      Gewichtseigenschaftsname = """SW-Mass@@" + sConfigName + "@" + Filename + """"
      RetInt = swPropMan2.Add2("Gewicht", swCustomInfoText, Gewichtseigenschaftsname)
      ' Produktlinie ermitteln
      RetInt = swPropMan2.Get6("Artikelnr", False, MaterialName1, MaterialName2, wurdegeloest, verbunden)
      If RetInt = swCustomInfoGetResult_ResolvedValue Then
        ppos = InStr(1, MaterialName1, "-", vbTextCompare) - 1
        If ppos >= 1 Then
          PL = Mid$(MaterialName1, 1, ppos)
          If Len(PL) > 0 Then
            PL = UCase(PL)
            RetInt = swPropMan2.Add3("PL", swCustomInfoText, PL, swCustomPropertyReplaceValue)
          End If
        End If
      End If
      Set swPropMan2 = Nothing
      Set swConfig = Nothing
    Next i
  End If

End Sub