Mass Property

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swxModelDoc As ModelDoc2
Dim swxModelDocExtension As ModelDocExtension
Dim swxCustomPropertyManager As CustomPropertyManager
Dim fileType As Long
Dim fileName As String

Const cQTY = "QTY"
Const cWEIGHT = "Gewicht"
Const cMATERIAL = "Material"
Const cUNIT = "Einheit"

Sub main()
    Dim returnValue As Long
    Dim valOut As String
    Dim resolvedValOut As String
    Dim wasResolved As Boolean
    Dim linkToProp As Boolean
    Set swApp = Application.SldWorks
    Set swxModelDoc = swApp.ActiveDoc
    If swxModelDoc Is Nothing Then
        swApp.SendMsgToUser2 "Keine Datei geladen.", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
        End
    End If
    fileName = swxModelDoc.GetPathName
    If fileName = "" Then
        swApp.SendMsgToUser2 "Die Datei muss Initial gespeichert werden.", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
        End
    End If
    Set swxModelDocExtension = swxModelDoc.Extension
    fileType = swxModelDoc.GetType
    ' QTY richtig einstellen
    If fileType = swDocumentTypes_e.swDocASSEMBLY Or fileType = swDocumentTypes_e.swDocPART Then
        Set swxCustomPropertyManager = swxModelDocExtension.CustomPropertyManager("")
        returnValue = swxCustomPropertyManager.Add3(cQTY, swCustomInfoType_e.swCustomInfoNumber, _
                      1, swCustomPropertyAddOption_e.swCustomPropertyOnlyIfNew)
        swxCustomPropertyManager.Get6 cQTY, False, valOut, resolvedValOut, wasResolved, linkToProp
        If returnValue <> 0 Then
            If IsNumeric(resolvedValOut) Then
                If CDbl(resolvedValOut) <= 0 Then resolvedValOut = 1
            Else
                swApp.SendMsgToUser2 "In das Feld " & cQTY & "dürfen nur Zahlen eingegeben werden.", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
                End
            End If
        End If
        WriteToProperty cQTY, resolvedValOut, "number"
    End If
    ' Gewicht richtig einstellen
    If fileType = swDocumentTypes_e.swDocASSEMBLY Or fileType = swDocumentTypes_e.swDocPART Then
        Dim weight As String
        Dim swxMassProperty As MassProperty2
        Set swxMassProperty = swxModelDocExtension.CreateMassProperty2
        If Not swxMassProperty Is Nothing Then
            If swxMassProperty.Mass < 1 Then
                If swxMassProperty.Mass < 0.001 Then
                    weight = CStr(Round(swxMassProperty.Mass, 5) * 1000) & "g"
                Else
                    weight = CStr(Round(swxMassProperty.Mass, 3) * 1000) & "g"
                End If
            ElseIf swxMassProperty.Mass > 10 Then
                weight = CStr(Round(swxMassProperty.Mass, 0)) & "kg"
            Else
                weight = CStr(Round(swxMassProperty.Mass, 2)) & "kg"
            End If
        Else
           weight = "0g"
        End If
        weight = Replace(weight, ",", ".")
        WriteToProperty cWEIGHT, weight, "text"
    End If
    ' Material eintragen
    If fileType = swDocumentTypes_e.swDocPART Then
        Dim tempSplit As Variant
        tempSplit = Split(fileName, "\")
        WriteToProperty cMATERIAL, Chr(34) & "SW-Material@" & tempSplit(UBound(tempSplit)) & Chr(34), "text"
    End If
    ' Einheit eingetragen
    If fileType = swDocumentTypes_e.swDocASSEMBLY Or fileType = swDocumentTypes_e.swDocPART Then
        Set swxCustomPropertyManager = swxModelDocExtension.CustomPropertyManager("")
        swxCustomPropertyManager.Get6 cUNIT, False, valOut, resolvedValOut, wasResolved, linkToProp
        If resolvedValOut = "" Then
            WriteToProperty cUNIT, "ST", "text"
        End If
    End If
End Sub

Sub WriteToProperty(ByVal constant As String, ByVal value As Variant, ByVal typ As String)
    Dim customInfoType As swCustomInfoType_e
    If typ = "text" Then customInfoType = swCustomInfoText Else customInfoType = swCustomInfoNumber
    Set swxCustomPropertyManager = swxModelDocExtension.CustomPropertyManager("")
    swxCustomPropertyManager.Add3 constant, customInfoType, value, _
                                  swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
    Dim arrayOfConfigurationNames As Variant
    arrayOfConfigurationNames = swxModelDoc.GetConfigurationNames()
    Dim name As Variant
    For Each name In arrayOfConfigurationNames
        Set swxCustomPropertyManager = swxModelDocExtension.CustomPropertyManager(name)
        swxCustomPropertyManager.Add3 constant, customInfoType, value, _
                                      swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
    Next
End Sub