Перейти к публикации
Размещайте вопросы по расчетам в соответствующем разделе

Свойства материалов

pps270391

Автор: pps270391,
в SolidWorks

 Рассказать Подписчики 1

Рекомендованные сообщения

pps270391

pps270391 62

Опубликовано:
Опубликовано: (изменено)

image.png
Требуется чтобы при назначении материалов, данные автоматически записывались в строки:
- Заготовка
- Типоразмер
- Материал (для материала уже существует автоматическая команда "SW-Material@@По умолчанию@"наименование модели".SLDPRT", которая записывается автоматически)
Есть ли возможность, чтобы в модель записывались остальные строки, с учетом доработки материалов. Я так понимаю доработка свойств материала делается как на предоставленном фото

Изменено пользователем pps270391
Ссылка на сообщение
Поделиться на других сайтах


UnPinned posts
Snake 60

Snake 60 689

Опубликовано:
Опубликовано:

@pps270391  Полагаю, что стандартных формул нет для вывода данных свойств. На просторах инета встречал макрос который считывает эти свойства и переносит в свойства детали - если актуально могу поискать.

Ссылка на сообщение
Поделиться на других сайтах
Snake 60

Snake 60 689

Опубликовано:
Опубликовано:

@pps270391  Макрос нашел, переделал его под 3 свойства, вроде бы всё работает. (во вложении) Свойства пишет на вкладку Настройки, если нужна запись на вкладку Конфигурации - пиши, подправлю.

Скрытый текст

copy-material-custom-properties.swp

  • Нравится 1
  • Чемпион 1
Ссылка на сообщение
Поделиться на других сайтах
pps270391

pps270391 62

Опубликовано:
  • Автор
Опубликовано:
31.03.2024 в 00:22, Snake 60 сказал:

@pps270391  Макрос нашел, переделал его под 3 свойства, вроде бы всё работает. (во вложении) Свойства пишет на вкладку Настройки, если нужна запись на вкладку Конфигурации - пиши, подправлю.

  Скрыть содержимое

 

copy-material-custom-properties.swp 64 \u041a\u0431 · 5 скачиваний

Спасибо, но не завелось, можно переделать чтобы все записывалось в конфигурации? попробуем так сделать

Ссылка на сообщение
Поделиться на других сайтах
Snake 60

Snake 60 689

Опубликовано:
Опубликовано:
02.04.2024 в 16:57, pps270391 сказал:

Спасибо, но не завелось

Проверьте правильность версий подключенных библиотек:

Открыть макрос (Инструменты-Макрос-Редактировать)

Далее Tools-References должны быть подключены библиотеки как на скрине, только номера версий библиотек должны быть Вашей версии солида. Если будет библиотека с надписью MISSING то ее надо переподключить на одноименную но нужной версии.

Скрытый текст

изображение.png

Либо второй вариант, сами создайте макрос (Инструменты-Макрос-Создать) скопируйте и вставьте код макроса ниже (ВАЖНО, чтобы язык системы во время копирования был RUS): 

Option Explicit
'**********************
'Copyright(C) 2024 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-api/document/materials/copy-custom-property/
'License: https://www.codestack.net/license/
'**********************

Const PRP_NAME1 As String = "Заготовка"
Const PRP_NAME2 As String = "Материал"
Const PRP_NAME3 As String = "Типоразмер"

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    
    Dim swPart As SldWorks.PartDoc
    
    Set swPart = swApp.ActiveDoc
    
    If Not swPart Is Nothing Then
        
        Dim materialName As String
        Dim materialDb As String
        materialDb = GetMaterialDatabase(swPart, materialName)
        
        If materialDb <> "" Then
            Dim prpVal As String
            Dim j As Integer
            For j = 1 To 3
                Select Case j
                     Case 1
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME1)
                        SetCustomProperty swPart, PRP_NAME1, prpVal
                      Case 2
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME2)
                        SetCustomProperty swPart, PRP_NAME2, prpVal
                      Case 3
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME3)
                        SetCustomProperty swPart, PRP_NAME3, prpVal
                      Case Else
                         Debug.Print " Что-то пошло не так!"
                End Select
            Next j
        Else
            MsgBox "Не удалось найти базу данных материалов"
        End If
        
    Else
        MsgBox "Откройте деталь!"
    End If
    MsgBox "Готово!"
End Sub

Function GetMaterialDatabase(part As SldWorks.PartDoc, ByRef materialName As String) As String
    
    Dim materialDbName As String
    materialName = part.GetMaterialPropertyName2("", materialDbName)

    Dim vDbs As Variant
    vDbs = swApp.GetMaterialDatabases()
    
    If Not IsEmpty(vDbs) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vDbs)
            Dim dbFilePath As String
            dbFilePath = vDbs(i)
            
            Dim dbFileName As String
            dbFileName = Right(dbFilePath, Len(dbFilePath) - InStrRev(dbFilePath, "\"))
                        
            If LCase(dbFileName) = LCase(materialDbName & ".sldmat") Then
                GetMaterialDatabase = dbFilePath
                Exit Function
            End If
            
        Next
        
    End If
    
    GetMaterialDatabase = ""
    
End Function

Function GetMaterialCustomProperty(materialName As String, materialDb As String, prpName As String) As String
    
    Dim xmlDoc As Object
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.Load materialDb
    
    Dim matNode As Object
    Set matNode = xmlDoc.SelectSingleNode("//classification/material[@name='" & materialName & "']/custom/prop[@name='" & prpName & "']")
    
    If Not matNode Is Nothing Then
        GetMaterialCustomProperty = matNode.Attributes.GetNamedItem("value").Text
    Else
        Err.Raise vbError, , "Failed to find the custom property " & prpName & " in material " & materialName & " in database " & materialDb
    End If
    
End Function

Sub SetCustomProperty(model As SldWorks.ModelDoc2, prpName As String, prpVal As String)
    
    Dim swPrpMgr As SldWorks.CustomPropertyManager
    Set swPrpMgr = model.Extension.CustomPropertyManager("")
    swPrpMgr.Add3 prpName, swCustomInfoType_e.swCustomInfoText, prpVal, swCustomPropertyAddOption_e.swCustomPropertyReplaceValue
    swPrpMgr.Set2 prpName, prpVal
    
End Sub

 

  • Нравится 2
Ссылка на сообщение
Поделиться на других сайтах
pps270391

pps270391 62

Опубликовано:
  • Автор
Опубликовано:
9 часов назад, Snake 60 сказал:

Проверьте правильность версий подключенных библиотек:

Открыть макрос (Инструменты-Макрос-Редактировать)

Далее Tools-References должны быть подключены библиотеки как на скрине, только номера версий библиотек должны быть Вашей версии солида. Если будет библиотека с надписью MISSING то ее надо переподключить на одноименную но нужной версии.

  Показать содержимое

изображение.png

Либо второй вариант, сами создайте макрос (Инструменты-Макрос-Создать) скопируйте и вставьте код макроса ниже (ВАЖНО, чтобы язык системы во время копирования был RUS): 


Option Explicit
'**********************
'Copyright(C) 2024 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-api/document/materials/copy-custom-property/
'License: https://www.codestack.net/license/
'**********************

Const PRP_NAME1 As String = "Заготовка"
Const PRP_NAME2 As String = "Материал"
Const PRP_NAME3 As String = "Типоразмер"

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    
    Dim swPart As SldWorks.PartDoc
    
    Set swPart = swApp.ActiveDoc
    
    If Not swPart Is Nothing Then
        
        Dim materialName As String
        Dim materialDb As String
        materialDb = GetMaterialDatabase(swPart, materialName)
        
        If materialDb <> "" Then
            Dim prpVal As String
            Dim j As Integer
            For j = 1 To 3
                Select Case j
                     Case 1
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME1)
                        SetCustomProperty swPart, PRP_NAME1, prpVal
                      Case 2
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME2)
                        SetCustomProperty swPart, PRP_NAME2, prpVal
                      Case 3
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME3)
                        SetCustomProperty swPart, PRP_NAME3, prpVal
                      Case Else
                         Debug.Print " Что-то пошло не так!"
                End Select
            Next j
        Else
            MsgBox "Не удалось найти базу данных материалов"
        End If
        
    Else
        MsgBox "Откройте деталь!"
    End If
    MsgBox "Готово!"
End Sub

Function GetMaterialDatabase(part As SldWorks.PartDoc, ByRef materialName As String) As String
    
    Dim materialDbName As String
    materialName = part.GetMaterialPropertyName2("", materialDbName)

    Dim vDbs As Variant
    vDbs = swApp.GetMaterialDatabases()
    
    If Not IsEmpty(vDbs) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vDbs)
            Dim dbFilePath As String
            dbFilePath = vDbs(i)
            
            Dim dbFileName As String
            dbFileName = Right(dbFilePath, Len(dbFilePath) - InStrRev(dbFilePath, "\"))
                        
            If LCase(dbFileName) = LCase(materialDbName & ".sldmat") Then
                GetMaterialDatabase = dbFilePath
                Exit Function
            End If
            
        Next
        
    End If
    
    GetMaterialDatabase = ""
    
End Function

Function GetMaterialCustomProperty(materialName As String, materialDb As String, prpName As String) As String
    
    Dim xmlDoc As Object
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.Load materialDb
    
    Dim matNode As Object
    Set matNode = xmlDoc.SelectSingleNode("//classification/material[@name='" & materialName & "']/custom/prop[@name='" & prpName & "']")
    
    If Not matNode Is Nothing Then
        GetMaterialCustomProperty = matNode.Attributes.GetNamedItem("value").Text
    Else
        Err.Raise vbError, , "Failed to find the custom property " & prpName & " in material " & materialName & " in database " & materialDb
    End If
    
End Function

Sub SetCustomProperty(model As SldWorks.ModelDoc2, prpName As String, prpVal As String)
    
    Dim swPrpMgr As SldWorks.CustomPropertyManager
    Set swPrpMgr = model.Extension.CustomPropertyManager("")
    swPrpMgr.Add3 prpName, swCustomInfoType_e.swCustomInfoText, prpVal, swCustomPropertyAddOption_e.swCustomPropertyReplaceValue
    swPrpMgr.Set2 prpName, prpVal
    
End Sub

 

Спасибо большое! Получилось когда я скопировал сам! Как теперь его доработать, чтобы все прописалось в конфигурации?

Ссылка на сообщение
Поделиться на других сайтах
Snake 60

Snake 60 689

Опубликовано:
Опубликовано:
3 часа назад, pps270391 сказал:

Как теперь его доработать, чтобы все прописалось в конфигурации? 

Option Explicit
'**********************
'Copyright(C) 2024 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-api/document/materials/copy-custom-property/
'License: https://www.codestack.net/license/
'**********************

Const PRP_NAME1 As String = "Заготовка"
Const PRP_NAME2 As String = "Материал"
Const PRP_NAME3 As String = "Типоразмер"

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks

    Dim swPart As SldWorks.PartDoc
   
    Set swPart = swApp.ActiveDoc
    
    If Not swPart Is Nothing Then
        
        Dim materialName As String
        Dim materialDb As String
        materialDb = GetMaterialDatabase(swPart, materialName)
        
        If materialDb <> "" Then
            Dim prpVal As String
            Dim j As Integer
            For j = 1 To 3
                Select Case j
                     Case 1
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME1)
                        SetCustomProperty swPart, PRP_NAME1, prpVal
                      Case 2
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME2)
                        SetCustomProperty swPart, PRP_NAME2, prpVal
                      Case 3
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME3)
                        SetCustomProperty swPart, PRP_NAME3, prpVal
                      Case Else
                         Debug.Print " Что-то пошло не так!"
                End Select
            Next j
        Else
            MsgBox "Не удалось найти базу данных материалов"
        End If
        
    Else
        MsgBox "Откройте деталь!"
    End If
    MsgBox "Готово!"
End Sub

Function GetMaterialDatabase(part As SldWorks.PartDoc, ByRef materialName As String) As String
    
    Dim materialDbName As String
    materialName = part.GetMaterialPropertyName2("", materialDbName)

    Dim vDbs As Variant
    vDbs = swApp.GetMaterialDatabases()
    
    If Not IsEmpty(vDbs) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vDbs)
            Dim dbFilePath As String
            dbFilePath = vDbs(i)
            
            Dim dbFileName As String
            dbFileName = Right(dbFilePath, Len(dbFilePath) - InStrRev(dbFilePath, "\"))
                        
            If LCase(dbFileName) = LCase(materialDbName & ".sldmat") Then
                GetMaterialDatabase = dbFilePath
                Exit Function
            End If
            
        Next
        
    End If
    
    GetMaterialDatabase = ""
    
End Function

Function GetMaterialCustomProperty(materialName As String, materialDb As String, prpName As String) As String
    
    Dim xmlDoc As Object
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.Load materialDb
    
    Dim matNode As Object
    Set matNode = xmlDoc.SelectSingleNode("//classification/material[@name='" & materialName & "']/custom/prop[@name='" & prpName & "']")
    
    If Not matNode Is Nothing Then
        GetMaterialCustomProperty = matNode.Attributes.GetNamedItem("value").Text
    Else
        Err.Raise vbError, , "Failed to find the custom property " & prpName & " in material " & materialName & " in database " & materialDb
    End If
    
End Function

Sub SetCustomProperty(model As SldWorks.ModelDoc2, prpName As String, prpVal As String)
    
    Dim cusPropMgr As SldWorks.CustomPropertyManager
    Dim lRetVal As Long
    Dim config As SldWorks.Configuration
    
    Set config = model.GetActiveConfiguration
    Set cusPropMgr = config.CustomPropertyManager

    lRetVal = cusPropMgr.Add3(prpName, swCustomInfoType_e.swCustomInfoText, prpVal, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
    lRetVal = cusPropMgr.Set2(prpName, prpVal)
    
End Sub

 

  • Нравится 2
Ссылка на сообщение
Поделиться на других сайтах
pps270391

pps270391 62

Опубликовано:
  • Автор
Опубликовано:
15 минут назад, Snake 60 сказал: 

Option Explicit
'**********************
'Copyright(C) 2024 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-api/document/materials/copy-custom-property/
'License: https://www.codestack.net/license/
'**********************

Const PRP_NAME1 As String = "Заготовка"
Const PRP_NAME2 As String = "Материал"
Const PRP_NAME3 As String = "Типоразмер"

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks

    Dim swPart As SldWorks.PartDoc
   
    Set swPart = swApp.ActiveDoc
    
    If Not swPart Is Nothing Then
        
        Dim materialName As String
        Dim materialDb As String
        materialDb = GetMaterialDatabase(swPart, materialName)
        
        If materialDb <> "" Then
            Dim prpVal As String
            Dim j As Integer
            For j = 1 To 3
                Select Case j
                     Case 1
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME1)
                        SetCustomProperty swPart, PRP_NAME1, prpVal
                      Case 2
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME2)
                        SetCustomProperty swPart, PRP_NAME2, prpVal
                      Case 3
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME3)
                        SetCustomProperty swPart, PRP_NAME3, prpVal
                      Case Else
                         Debug.Print " Что-то пошло не так!"
                End Select
            Next j
        Else
            MsgBox "Не удалось найти базу данных материалов"
        End If
        
    Else
        MsgBox "Откройте деталь!"
    End If
    MsgBox "Готово!"
End Sub

Function GetMaterialDatabase(part As SldWorks.PartDoc, ByRef materialName As String) As String
    
    Dim materialDbName As String
    materialName = part.GetMaterialPropertyName2("", materialDbName)

    Dim vDbs As Variant
    vDbs = swApp.GetMaterialDatabases()
    
    If Not IsEmpty(vDbs) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vDbs)
            Dim dbFilePath As String
            dbFilePath = vDbs(i)
            
            Dim dbFileName As String
            dbFileName = Right(dbFilePath, Len(dbFilePath) - InStrRev(dbFilePath, "\"))
                        
            If LCase(dbFileName) = LCase(materialDbName & ".sldmat") Then
                GetMaterialDatabase = dbFilePath
                Exit Function
            End If
            
        Next
        
    End If
    
    GetMaterialDatabase = ""
    
End Function

Function GetMaterialCustomProperty(materialName As String, materialDb As String, prpName As String) As String
    
    Dim xmlDoc As Object
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.Load materialDb
    
    Dim matNode As Object
    Set matNode = xmlDoc.SelectSingleNode("//classification/material[@name='" & materialName & "']/custom/prop[@name='" & prpName & "']")
    
    If Not matNode Is Nothing Then
        GetMaterialCustomProperty = matNode.Attributes.GetNamedItem("value").Text
    Else
        Err.Raise vbError, , "Failed to find the custom property " & prpName & " in material " & materialName & " in database " & materialDb
    End If
    
End Function

Sub SetCustomProperty(model As SldWorks.ModelDoc2, prpName As String, prpVal As String)
    
    Dim cusPropMgr As SldWorks.CustomPropertyManager
    Dim lRetVal As Long
    Dim config As SldWorks.Configuration
    
    Set config = model.GetActiveConfiguration
    Set cusPropMgr = config.CustomPropertyManager

    lRetVal = cusPropMgr.Add3(prpName, swCustomInfoType_e.swCustomInfoText, prpVal, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
    lRetVal = cusPropMgr.Set2(prpName, prpVal)
    
End Sub

 

Спасибо большое! Очень полезный макрос получился, теперь можно создать свою базу данных материалов и просто назначать материал и свойства будут прописываться

  • Нравится 1
Ссылка на сообщение
Поделиться на других сайтах
pps270391

pps270391 62

Опубликовано:
  • Автор
Опубликовано:
3 часа назад, Snake 60 сказал: 

Option Explicit
'**********************
'Copyright(C) 2024 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-api/document/materials/copy-custom-property/
'License: https://www.codestack.net/license/
'**********************

Const PRP_NAME1 As String = "Заготовка"
Const PRP_NAME2 As String = "Материал"
Const PRP_NAME3 As String = "Типоразмер"

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks

    Dim swPart As SldWorks.PartDoc
   
    Set swPart = swApp.ActiveDoc
    
    If Not swPart Is Nothing Then
        
        Dim materialName As String
        Dim materialDb As String
        materialDb = GetMaterialDatabase(swPart, materialName)
        
        If materialDb <> "" Then
            Dim prpVal As String
            Dim j As Integer
            For j = 1 To 3
                Select Case j
                     Case 1
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME1)
                        SetCustomProperty swPart, PRP_NAME1, prpVal
                      Case 2
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME2)
                        SetCustomProperty swPart, PRP_NAME2, prpVal
                      Case 3
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME3)
                        SetCustomProperty swPart, PRP_NAME3, prpVal
                      Case Else
                         Debug.Print " Что-то пошло не так!"
                End Select
            Next j
        Else
            MsgBox "Не удалось найти базу данных материалов"
        End If
        
    Else
        MsgBox "Откройте деталь!"
    End If
    MsgBox "Готово!"
End Sub

Function GetMaterialDatabase(part As SldWorks.PartDoc, ByRef materialName As String) As String
    
    Dim materialDbName As String
    materialName = part.GetMaterialPropertyName2("", materialDbName)

    Dim vDbs As Variant
    vDbs = swApp.GetMaterialDatabases()
    
    If Not IsEmpty(vDbs) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vDbs)
            Dim dbFilePath As String
            dbFilePath = vDbs(i)
            
            Dim dbFileName As String
            dbFileName = Right(dbFilePath, Len(dbFilePath) - InStrRev(dbFilePath, "\"))
                        
            If LCase(dbFileName) = LCase(materialDbName & ".sldmat") Then
                GetMaterialDatabase = dbFilePath
                Exit Function
            End If
            
        Next
        
    End If
    
    GetMaterialDatabase = ""
    
End Function

Function GetMaterialCustomProperty(materialName As String, materialDb As String, prpName As String) As String
    
    Dim xmlDoc As Object
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.Load materialDb
    
    Dim matNode As Object
    Set matNode = xmlDoc.SelectSingleNode("//classification/material[@name='" & materialName & "']/custom/prop[@name='" & prpName & "']")
    
    If Not matNode Is Nothing Then
        GetMaterialCustomProperty = matNode.Attributes.GetNamedItem("value").Text
    Else
        Err.Raise vbError, , "Failed to find the custom property " & prpName & " in material " & materialName & " in database " & materialDb
    End If
    
End Function

Sub SetCustomProperty(model As SldWorks.ModelDoc2, prpName As String, prpVal As String)
    
    Dim cusPropMgr As SldWorks.CustomPropertyManager
    Dim lRetVal As Long
    Dim config As SldWorks.Configuration
    
    Set config = model.GetActiveConfiguration
    Set cusPropMgr = config.CustomPropertyManager

    lRetVal = cusPropMgr.Add3(prpName, swCustomInfoType_e.swCustomInfoText, prpVal, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
    lRetVal = cusPropMgr.Set2(prpName, prpVal)
    
End Sub

 

А нельзя сделать так, чтобы выбранный материал прописывался во все исполнения? При создании нескольких исполнений материал назначается только выбранному ваданный момент, для других надо также выбрать исполнение и запустить макрос

Ссылка на сообщение
Поделиться на других сайтах
Snake 60

Snake 60 689

Опубликовано:
Опубликовано: (изменено)
7 часов назад, pps270391 сказал:

А нельзя сделать так, чтобы выбранный материал прописывался во все исполнения?

Без проблем (код ниже) Позволю себе небольшую рекламу. Подписывайтесь на меня на бусти - там куча полезных макросов: https://boosty.to/snake.nest 

Option Explicit
'**********************
'Copyright(C) 2024 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-api/document/materials/copy-custom-property/
'License: https://www.codestack.net/license/
'**********************

Const PRP_NAME1 As String = "Заготовка"
Const PRP_NAME2 As String = "Материал"
Const PRP_NAME3 As String = "Типоразмер"

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks

    Dim swPart As SldWorks.PartDoc
   
    Set swPart = swApp.ActiveDoc
    
    If Not swPart Is Nothing Then
        
        Dim materialName As String
        Dim materialDb As String
        materialDb = GetMaterialDatabase(swPart, materialName)
        
        If materialDb <> "" Then
            Dim prpVal As String
            Dim j As Integer
            For j = 1 To 3
                Select Case j
                     Case 1
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME1)
                        SetCustomProperty swPart, PRP_NAME1, prpVal
                      Case 2
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME2)
                        SetCustomProperty swPart, PRP_NAME2, prpVal
                      Case 3
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME3)
                        SetCustomProperty swPart, PRP_NAME3, prpVal
                      Case Else
                         Debug.Print " Что-то пошло не так!"
                End Select
            Next j
        Else
            MsgBox "Не удалось найти базу данных материалов"
        End If
        
    Else
        MsgBox "Откройте деталь!"
    End If
    MsgBox "Готово!"
End Sub

Function GetMaterialDatabase(part As SldWorks.PartDoc, ByRef materialName As String) As String
    
    Dim materialDbName As String
    materialName = part.GetMaterialPropertyName2("", materialDbName)

    Dim vDbs As Variant
    vDbs = swApp.GetMaterialDatabases()
    
    If Not IsEmpty(vDbs) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vDbs)
            Dim dbFilePath As String
            dbFilePath = vDbs(i)
            
            Dim dbFileName As String
            dbFileName = Right(dbFilePath, Len(dbFilePath) - InStrRev(dbFilePath, "\"))
                        
            If LCase(dbFileName) = LCase(materialDbName & ".sldmat") Then
                GetMaterialDatabase = dbFilePath
                Exit Function
            End If
            
        Next
        
    End If
    
    GetMaterialDatabase = ""
    
End Function

Function GetMaterialCustomProperty(materialName As String, materialDb As String, prpName As String) As String
    
    Dim xmlDoc As Object
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.Load materialDb
    
    Dim matNode As Object
    Set matNode = xmlDoc.SelectSingleNode("//classification/material[@name='" & materialName & "']/custom/prop[@name='" & prpName & "']")
    
    If Not matNode Is Nothing Then
        GetMaterialCustomProperty = matNode.Attributes.GetNamedItem("value").Text
    Else
        Err.Raise vbError, , "Failed to find the custom property " & prpName & " in material " & materialName & " in database " & materialDb
    End If
    
End Function

Sub SetCustomProperty(model As SldWorks.ModelDoc2, prpName As String, prpVal As String)
    
    Dim cusPropMgr                   As SldWorks.CustomPropertyManager
    Dim lRetVal                            As Long
    Dim config                              As SldWorks.Configuration
    Dim allConfNames                As Variant
    
    allConfNames = model.GetConfigurationNames
    Dim i As Integer
    For i = 0 To UBound(allConfNames)
        Set cusPropMgr = model.Extension.CustomPropertyManager(allConfNames(i))
        lRetVal = cusPropMgr.Add3(prpName, swCustomInfoType_e.swCustomInfoText, prpVal, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
        lRetVal = cusPropMgr.Set2(prpName, prpVal)
    Next i
    
End Sub

 

Изменено пользователем Snake 60
  • Нравится 3
Ссылка на сообщение
Поделиться на других сайтах
pps270391

pps270391 62

Опубликовано:
  • Автор
Опубликовано:
11 часов назад, Snake 60 сказал:

Без проблем (код ниже) Позволю себе небольшую рекламу. Подписывайтесь на меня на бусти - там куча полезных макросов: https://boosty.to/snake.nest 


Option Explicit
'**********************
'Copyright(C) 2024 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-api/document/materials/copy-custom-property/
'License: https://www.codestack.net/license/
'**********************

Const PRP_NAME1 As String = "Заготовка"
Const PRP_NAME2 As String = "Материал"
Const PRP_NAME3 As String = "Типоразмер"

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks

    Dim swPart As SldWorks.PartDoc
   
    Set swPart = swApp.ActiveDoc
    
    If Not swPart Is Nothing Then
        
        Dim materialName As String
        Dim materialDb As String
        materialDb = GetMaterialDatabase(swPart, materialName)
        
        If materialDb <> "" Then
            Dim prpVal As String
            Dim j As Integer
            For j = 1 To 3
                Select Case j
                     Case 1
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME1)
                        SetCustomProperty swPart, PRP_NAME1, prpVal
                      Case 2
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME2)
                        SetCustomProperty swPart, PRP_NAME2, prpVal
                      Case 3
                        prpVal = GetMaterialCustomProperty(materialName, materialDb, PRP_NAME3)
                        SetCustomProperty swPart, PRP_NAME3, prpVal
                      Case Else
                         Debug.Print " Что-то пошло не так!"
                End Select
            Next j
        Else
            MsgBox "Не удалось найти базу данных материалов"
        End If
        
    Else
        MsgBox "Откройте деталь!"
    End If
    MsgBox "Готово!"
End Sub

Function GetMaterialDatabase(part As SldWorks.PartDoc, ByRef materialName As String) As String
    
    Dim materialDbName As String
    materialName = part.GetMaterialPropertyName2("", materialDbName)

    Dim vDbs As Variant
    vDbs = swApp.GetMaterialDatabases()
    
    If Not IsEmpty(vDbs) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vDbs)
            Dim dbFilePath As String
            dbFilePath = vDbs(i)
            
            Dim dbFileName As String
            dbFileName = Right(dbFilePath, Len(dbFilePath) - InStrRev(dbFilePath, "\"))
                        
            If LCase(dbFileName) = LCase(materialDbName & ".sldmat") Then
                GetMaterialDatabase = dbFilePath
                Exit Function
            End If
            
        Next
        
    End If
    
    GetMaterialDatabase = ""
    
End Function

Function GetMaterialCustomProperty(materialName As String, materialDb As String, prpName As String) As String
    
    Dim xmlDoc As Object
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.Load materialDb
    
    Dim matNode As Object
    Set matNode = xmlDoc.SelectSingleNode("//classification/material[@name='" & materialName & "']/custom/prop[@name='" & prpName & "']")
    
    If Not matNode Is Nothing Then
        GetMaterialCustomProperty = matNode.Attributes.GetNamedItem("value").Text
    Else
        Err.Raise vbError, , "Failed to find the custom property " & prpName & " in material " & materialName & " in database " & materialDb
    End If
    
End Function

Sub SetCustomProperty(model As SldWorks.ModelDoc2, prpName As String, prpVal As String)
    
    Dim cusPropMgr                   As SldWorks.CustomPropertyManager
    Dim lRetVal                            As Long
    Dim config                              As SldWorks.Configuration
    Dim allConfNames                As Variant
    
    allConfNames = model.GetConfigurationNames
    Dim i As Integer
    For i = 0 To UBound(allConfNames)
        Set cusPropMgr = model.Extension.CustomPropertyManager(allConfNames(i))
        lRetVal = cusPropMgr.Add3(prpName, swCustomInfoType_e.swCustomInfoText, prpVal, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
        lRetVal = cusPropMgr.Set2(prpName, prpVal)
    Next i
    
End Sub

 

Спасибо! Заработало! 

Ссылка на сообщение
Поделиться на других сайтах

Присоединяйтесь к обсуждению

Вы можете опубликовать сообщение сейчас, а зарегистрироваться позже. Если у вас есть аккаунт, войдите в него для написания от своего имени.
Примечание: вашему сообщению потребуется утверждение модератора, прежде чем оно станет доступным.

Гость
Ответить в тему...

×   Вставлено в виде отформатированного текста.   Вставить в виде обычного текста

  Разрешено не более 75 эмодзи.

×   Ваша ссылка была автоматически встроена.   Отобразить как ссылку

×   Ваш предыдущий контент был восстановлен.   Очистить редактор

×   Вы не можете вставить изображения напрямую. Загрузите или вставьте изображения по ссылке.

×
 Рассказать
Подписчики 1
Перейти к списку тем

  • Сейчас на странице   0 пользователей

    Нет пользователей, просматривающих эту страницу.


×
×
  • Создать...