Jump to content

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


Recommended Posts

pps270391

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

Edited by pps270391
Link to post
Share on other sites


UnPinned posts
Snake 60

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

Link to post
Share on other sites
Snake 60

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

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

copy-material-custom-properties.swp

  • Нравится 1
  • Чемпион 1
Link to post
Share on other sites
pps270391
31.03.2024 в 00:22, Snake 60 сказал:

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

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

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

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

Link to post
Share on other sites
Snake 60
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
Link to post
Share on other sites
pps270391
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

 

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

Link to post
Share on other sites
Snake 60
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
Link to post
Share on other sites
pps270391
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
Link to post
Share on other sites
pps270391
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

 

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

Link to post
Share on other sites
Snake 60
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

 

Edited by Snake 60
  • Нравится 3
Link to post
Share on other sites
pps270391
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

 

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

Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • Recently Browsing   0 members

    No registered users viewing this page.




  • Сообщения

    • ID_Hacker
      Так это и есть сообщение о том что разрешение сброшено. Дословно: Ось S1/C11: Разрешение сброшено, причина 1. Потом сообщение 201707 от CU о том что допуск для безопасного останова превышен. Потом сообщение 25050 контроль контура - говорит о том что ось переместилась более допустимого значения в MD36400 от заданного положения Ну и последние два это безопасный останов А и В. Верно, все сообщения кроме 21612 это следствие.     Simodrive 611 и Sinamics S120 отличаются. В синамиксах все сигналы передаются по цифровой шине передачи данных, следовательно, при отказе шины одно только разрешение пропадать не может, был бы отказ моторного модуля на шине. При этом внутренняя логика моторного модуля так же себя контролирует и был бы отказ модуля, он бы упал в ошибку. На симодрайвах, симовертах реле готовности модуля бывает выходит из строя. В этом случае можно проверить мультиметром или регистратором сигналов.
    • NGLSHMNN
      Всем здравия. Какой бюджетный ноут купить для работы в nx и solid? Каких то серьезных моделей/сборок нет и не предвидится.. Тыс за 60-80 можно взять?  
    • NGLSHMNN
      подобрал? у меня такая же ситуация сейчас..
    • gudstartup
      @Александр 36 шпиндель вручную нормально крутится обороты показывает? Какая нагрузка  на индикаторе loadmeter если он у вас есть? Шпиндель начиает вращаться быстро или медленно
    • DJ Astro
      Подскажите, пожалуйста, как это собрать, чтобы двигая в динамике рычаг ("переместить компонент" или во время назначения сопряжений), шток двигался за ним. Цилиндр как подсборка.   Через wave работает, но только если переместить рычаг и применить изменения, естественно всё пересчитывается и перемещается. А нужно, чтобы шток двигался в процессе перемещения. Один раз удалось так сделать, но результат не сохранил. И больше повторить не удаётся, в каких бы комбинациях не использовал всякие соединения и ограничения. 
    • maxx2000
      Молоком написано. Владимир Ильич одобрил бы . Не показывайте это банкам и кредитным организациям 
    • Priminer
      Добрый день Вячеслав. Наша компания является официальным представительством компании Priminer в РФ. Вы можете обратиться в нашу техническую службу за поддержкой.  
    • kkk
      Вот прям то, что нужно! Особенно приятно, что переименовывает только стандартные названия элементов, если сам переименовал элемент во что-то свое, то такие не трогает.
    • ANT0N1DZE
      Теперь ясно. А у вас какие-то другие конструкции?
    • alex-207-1999
      Необходим выезд на завод для обучения созданию команд и 3D-моделей на фрезерном станке с ЧПУ Fanuc S+ в г.Кириши (Ленинградская область). Если кого-то заинтересовало предложение, прошу написать мне на почту avv@s-n-t.com
×
×
  • Create New...