Программное чтение свойств материалов

[BazingAAA 0]

Необходимо программно получить доступ к материалам и их свойствам. Получалось только получить наименование материала из детали.

Или я не с той стороны подхожу к вопросу?

[Leon 433]

@BazingAAA Если у вас вышло получить наименование материала, то вы знаете и имя базы. Дальше открываете базу и выдергиваете из нее все, что вам нужно. Это xml файл.

[BazingAAA 0]

1 минуту назад, Leon сказал:

@BazingAAA Если у вас вышло получить наименование материала, то вы знаете и имя базы. Дальше открываете базу и выдергиваете из нее все, что вам нужно. Это xml файл.

Интересно было бы узнать возможно ли это сделать средствами самого солида.

А так получается надо парсить xml'ку...

[Leon 433]

1 минуту назад, BazingAAA сказал:

возможно ли это сделать средствами самого солида

Я не нашел. Правда в последних версиях не искал.

[VOleg 228]

Sub getkodmat()

 Dim swApp           As SldWorks.SldWorks
 Dim swModel         As SldWorks.ModelDoc2
 Dim swPart          As SldWorks.PartDoc
 Dim dbs             As Variant
 Dim sMatName        As String
 Dim uMatName        As String
 Dim sMatDB          As String
 Dim name1           As String, name2 As String, valu1 As String, valu2 As String
 Dim bRet            As Boolean
 Dim i               As Integer
 Dim swConfigMgr     As SldWorks.ConfigurationManager
 Dim swConfig        As SldWorks.Configuration
 Dim swCustPropMgr   As SldWorks.CustomPropertyManager
 Dim cname           As String, isto As String

 Dim xd As MSXML2.DOMDocument
 Dim ndl As MSXML2.IXMLDOMNodeList
 Dim nd As MSXML2.IXMLDOMNode
 Dim ndcs As MSXML2.IXMLDOMNodeList
 Dim ndс As MSXML2.IXMLDOMNode
 Dim at As MSXML2.IXMLDOMAttribute

 Set swApp = Application.SldWorks
 Set swModel = swApp.ActiveDoc
 
  ' Начальные проверки
 If swModel Is Nothing Then
     MsgBox "Ничего не открыто", , "Откройте сборку"
     Exit Sub
 End If
 If swModel.GetType <> swDocPART Then
     MsgBox "Текущий документ д.б. деталью!", , "Откройте деталь"
     Exit Sub
 End If
 
 
 Set swPart = swModel
 Set swConfigMgr = swModel.ConfigurationManager
 Set swConfig = swConfigMgr.ActiveConfiguration
 Set swCustPropMgr = swConfig.CustomPropertyManager

 cname = swConfig.Name
 sMatDB = ""
 name1 = "Код материала"
 name2 = "РазмерСортамента"
 dbs = swApp.GetMaterialDatabases
 sMatName = swPart.GetMaterialPropertyName2(cname, sMatDB)
 If sMatName = "" Then
    MsgBox "Для конфигурации " + Chr(34) + cname + Chr(34) + " не задан материал"
    Exit Sub
 End If

 fnd1 = False
 For i = LBound(dbs) To UBound(dbs)
   If StrComp(UCase(Left(Right(dbs(i), Len(sMatDB) + 7), Len(sMatDB))), UCase(sMatDB)) = 0 Then
     sMatDB = dbs(i)
     fnd1 = True
     Exit For
   End If
 Next i

 If Not fnd1 Then
   MsgBox "Наща БД материалов не найдена", , sMatDB
   Exit Sub
 End If
 Set xd = CreateObject("MSXML2.DOMDocument")
 xd.Load (sMatDB)
 uMatName = UCase(sMatName)

 Set ndl = xd.getElementsByTagName("material")
 For i = 0 To ndl.Length - 1
   fnd1 = False
   Set nd = ndl.Item(i)
   nat = nd.Attributes.Length
   For j = 0 To nat - 1
     Set at = nd.Attributes.Item(j)
     If UCase(at.Name) = "NAME" And UCase(at.Value) = UCase(uMatName) Then
       fnd1 = True
       Exit For
     End If
   Next
   If fnd1 Then Exit For
 Next
 
 If fnd1 Then  ' nd - наш материал
    fnd2 = False
    fnd3 = False
    fnd4 = False
    fnd5 = False
    fnd6 = False
    fnd7 = False
    For j = 0 To nat - 1
      Set at = nd.Attributes.Item(j)
      If UCase(at.Name) = "PROPERTYSOURCE" Then
        fnd2 = True
        isto = at.Value
        If fnd2 Then Exit For
      End If
    Next
    
    Set ndcs = nd.childNodes
    For j = 0 To ndcs.Length - 1
      If UCase(ndcs.Item(j).nodeName) = "CUSTOM" Then
        fnd3 = True
        Exit For
      End If
    Next j
    
    If fnd3 Then
     Set ndcs = ndcs.Item(j).childNodes
     ' поиск первого свойства
     For i = 0 To ndcs.Length - 1
       Set nd = ndcs.Item(i)
       nat = nd.Attributes.Length
       For j = 0 To nat - 1
         Set at = nd.Attributes.Item(j)
         If UCase(at.Name) = "NAME" And UCase(at.Value) = UCase(name1) Then
           fnd4 = True
           Exit For
         End If
       Next
       If fnd4 Then
         For j = 0 To nat - 1
           Set at = nd.Attributes.Item(j)
           If UCase(at.Name) = "VALUE" Then
             fnd5 = True
             valu1 = at.Value
             Exit For
           End If
         Next
       End If
       If fnd5 Then Exit For
     Next
     ' поиск второго свойства
     For i = 0 To ndcs.Length - 1
       Set nd = ndcs.Item(i)
       nat = nd.Attributes.Length
       For j = 0 To nat - 1
         Set at = nd.Attributes.Item(j)
         If UCase(at.Name) = "NAME" And UCase(at.Value) = UCase(name2) Then
           fnd6 = True
           Exit For
         End If
       Next
       If fnd6 Then
         For j = 0 To nat - 1
           Set at = nd.Attributes.Item(j)
           If UCase(at.Name) = "VALUE" Then
             fnd7 = True
             valu2 = at.Value
             Exit For
           End If
         Next
       End If
       If fnd7 Then Exit For
     Next
    End If
    
 End If

 i = 0
 If Not fnd1 Then
   MsgBox "Материал " + Chr(34) + sMatName + Chr(34) + "не найден в БД", , sMatDB
 Else
   'If fnd2 Then
   '   MsgBox "Свойство Источник=" + isto, , sMatName
   'Else
   '   MsgBox "Атрибут PropertySource не найден для материала", , sMatName
   'End If
   If Not fnd3 Then
      MsgBox "Для материала не найдены свойства пользователя", , sMatName
   Else
     If fnd5 Then
      If swCustPropMgr.Set(name1, valu1) < 0 Then swCustPropMgr.Add2 name1, swCustomInfoText, valu1
      i = i + 1
     Else
      MsgBox "Для материала не найдено свойство " + name1, , sMatName
     End If
     If fnd7 Then
      If swCustPropMgr.Set(name2, valu2) < 0 Then swCustPropMgr.Add2 name2, swCustomInfoText, valu2
      i = i + 1
     Else
      MsgBox "Для материала не найдено свойство " + name2, , sMatName
     End If
   End If
 End If
 MsgBox "Добавлено/изменено свойств материала:" + Str(i)
 Set xd = Nothing
 
End Sub