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

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

pps270391

Автор: pps270391,
в SolidWorks

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

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

pps270391

pps270391 62

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

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

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


UnPinned posts
Snake 60

Snake 60 719

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

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

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

Snake 60 719

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

@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 719

Опубликовано:
Опубликовано:
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 719

Опубликовано:
Опубликовано:
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 719

Опубликовано:
Опубликовано: (изменено)
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 пользователей

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


  • Сообщения

    • Killerchik
      Смешное для понимающих v2

      Автор: Killerchik · Опубликовано:

      Господа, Вы все по-своему правы, как мне кажется. Виктор прав в том, что при описанном им отклонении будет невозможно сделать ось шпинделя перпендикулярной к поверхности детали, прижатой к столу, хоть убейся. Если это 3д фрезеровака - по барабану, а вот если надо расточить отверстие или обработать точную поверхность торцом фрезы (или шлифовального круга, шлифование на фрезерных ОЦ давно не что-то невероятное) - мы получаем неисправимое искажение.   Конечно, на хороших станках и физическую геометрию станины стараются делать хорошо. Но хорошо - это не отлично, а ещё её ведёт со временем, а ещё есть удары и т.п. Тут-то и приходит на помощь коррекция всех мастей. пиэс - работники Блом'а как выяснилось вручную подшлифовывают плоскости под рельсами брусками с наждачкой по результатам замеров))))) В видосе от Титанов это было.
    • gudstartup
      Смешное для понимающих v2

      Автор: gudstartup · Опубликовано:

      я вам все написал . вы же b компенсируете вот и вводите относительно наклона в заданной точке значения отклонений хоть по x и хоть по  y и ваша точка на оси сместится в пространстве. таблица компенсаций это позволяет. точки для оси b задаются от +90 0 -90 или как сами хотите 
    • Viktor2004
      Смешное для понимающих v2

      Автор: Viktor2004 · Опубликовано:

      Вот в моем примере надо задать смещение оси X в зависимости от Y. Но при B-90 это смещение должно быть в одну сторону, а при B+90 в другую сторону. А в промежутке между B-90---------B+90 значения смещения Х между этими крайними Значит компенсация X в зависимости от Y должна зависеть еще и от наклона оси В Ну и как будем компенсировать?
    • gudstartup
      Смешное для понимающих v2

      Автор: gudstartup · Опубликовано:

      вы понимаете что такое объемная компенсация? можно задать смещение точки вашего стола во всех плоскостях и станок это отработает переместив  на заданную величину оси х у или z  перемещая стол вы вообще не увидите больших отклонений. естественно все зависит от качества измерения и правильности ввода. лучше когда это делает специальная программа
    • Viktor2004
      Смешное для понимающих v2

      Автор: Viktor2004 · Опубликовано:

      хорошо. Представьте ситуацию 1. Ось В=0. двигаем индикатором по Х и Y все идеально ровно 2. Ось B=-90 ведем индикатором по Y вдоль стола. Отклонение в + (существенное) в сторону +X 3. Ось B=+90 ведем индикатором по Y вдоль стола. Отклонение в - (существенное) в сторону -X делаем вывод. стол не параллелен оси наклона Как будем компенсировать?
    • gudstartup
      Смешное для понимающих v2

      Автор: gudstartup · Опубликовано:

      если есть нормальный цикл для щупа и геометрия выравнена и соответствует кинематике то настройка = времени исполнения этого цикла. буржуи вообще этот цикл гоняют перед каждой высокоточной деталью и имеют прекрасную повторяемость точности. так надо уметь проводить измерения и иметь для этого соответствующие приборы.  вычисляется смещение оси в заданной точке и смещение осей влияющие на ее взаимную перпендикулярность. не видел там никаких формул. только недавно компенсировали ось А на пятиосевом хайдене и без формул обошлись.  согласен с тем что измерения пятиосевого продлятся дольше 
    • Viktor2004
      Смешное для понимающих v2

      Автор: Viktor2004 · Опубликовано:

      Я не смог. На Хенденхайне, где все компенсации очень наглядны и открыты. Трехосевой скомпенсировать можно, пятиосевой у меня не получилось. Потому что в значения компенсаций надо писать формулы, а оно позволяет писать туда только константы. А формулы оно туда писать не умеет
    • gudstartup
      Смешное для понимающих v2

      Автор: gudstartup · Опубликовано:

      тяжесть это отсутствие высокоскоростной обработки и трудоемкость. особенно если делать это с помощью индикатора и линейки станкостроители именно так и работают!
    • Guhl
      Смешное для понимающих v2

      Автор: Guhl · Опубликовано:

      Там и прямой станок настроить непросто, а уж кривой, так хоть стреляйся 
    • gudstartup
      Смешное для понимающих v2

      Автор: gudstartup · Опубликовано:

      3 часа на измерение всех геометрических отклонений при умении работать с интерферометром это реально. не смешите
×
×
  • Создать...