Сделай свою работу в Solidworks эффективнее

[malvi.dp 261]

29.07.2020 в 09:49, Rich сказал:

HideEdge выкладываю

Уважаемый @Rich, возможно ли дополнить ваш макрос кнопкой/функцией "выделить равные отверстия", по типу функции "Найти равные"? 

Встроенная функция не устраивает именно невозможностью выделения одинаковых по диаметру отверстий.

Вернее она их выделяет, но при выходе из команды выделение пропадает.

[tompsongun 450]

на счёт линий соединений между отверстиями. вроде как отрабатывает это CenterMark.ConnectionLines = 1

т.е. я предположил, что раз они отключены по умолчанию, перед выполнением команды надо включить.

 

ну и добавил просто скрытие отверстий без простановки центров, на развёртках у себя обычно их скрывам.HideEdge mod.swp

[Rich 35]

@malvi.dp  к сожалению сделать выборку одинаковых отверстий не представляется возможным. Это связано с технологией выбора. Я летом пробовал вычленить из выбранных элементов диаметры и координаты центров этих элементов (чтобы улучшить функционал макроса), но не смог найти этот параметр. Кстати в том сообщении я расписал на чем стопорнулся.

@tompsongun в последней версии что я выложил соединительные линии проставляются, правда есть один нюанс, если последнее в построении отверстие лежит вне остальных (см. рис.) центра не получаются

 

[malvi.dp 261]

3 часа назад, malvi.dp сказал:

Уважаемый @Rich, возможно ли дополнить ваш макрос кнопкой/функцией "выделить равные отверстия", по типу функции "Найти равные"? 

Встроенная функция не устраивает именно невозможностью выделения одинаковых по диаметру отверстий.

Вернее она их выделяет, но при выходе из команды выделение пропадает.

Нашел нужный макрос.  Выбирает эскизные дуги/отверстия одинакового размера с предварительно выбранной дугой/отверстием.

[Rich 35]

Да только он работает в с элементами эскиза, тут тогда необходимо преобразовать окружности с плоскости в окружности эскиза.

[malvi.dp 261]

16 минут назад, Rich сказал:

Да только он работает в с элементами эскиза, тут тогда необходимо преобразовать окружности с плоскости в окружности эскиза.

Алгоритм такой:

С помощью макроса HideEdge выбираю все окружности на выбранной грани.

Преобразовываю их в окружности эскиза средствами SW.

Выбираю одну окружность и по ней выбираются все равные ей  с помощью макроса.

Далее запускается макрос SameACircle и для выбранных окружностей проставляется знак одинаковых отверстий.

[Rich 35]

Действий конечно много, но если отверстий действительно огромное количество, то оно того стоит. Собственно этот вариант я и пытался летом автоматизировать (объединить макросы HideEdge и  SameACircle).
Если найдешь функцию с помощью которой можно преобразовать выбранные отверстия добавь ее в HideEdge и минус одно действие.

[none 51]

22 часа назад, malvi.dp сказал:

Алгоритм такой:

С помощью макроса HideEdge выбираю все окружности на выбранной грани.

Преобразовываю их в окружности эскиза средствами SW.

Выбираю одну окружность и по ней выбираются все равные ей  с помощью макроса.

Далее запускается макрос SameACircle и для выбранных окружностей проставляется знак одинаковых отверстий.

Прошу прощения, а где выложен макрос SameACircle? В теме не нашел с наскока.

[Plumber 737]

1 час назад, none сказал:

где выложен макрос SameACircle? В теме не нашел с наскока.

Плохо наскакивал

мне поиск SameACircle в теме выдал 12 результатов

А если приложишь еще немного усилий, то вероятно найдешь и более свежую версию 

[Snake 60 679]

По просьбе @Maik812 выкладываю доработанную версию вот этого макроса:

 

20.04.2005 в 10:27, Rich сказал:

Изменение свойств файла (буржуйская) - PropertyEditorSpec

 

Какие изменения я сделал:

1. Снял пароль с макроса (исходный код теперь доступен для изучения и правок)
2. Адаптировал макрос под x64 системы
3. Перевел интерфейс на русский язык
4. Конвертировал файл настроек в кодировку, поддерживающую кирилицу

Назначение макроса:

1. Редактирование существующих свойств в модели.
2. Добавление новых свойств в модель на вкладки Настройка и/или Текущей конфигурации
3. Копирование свойств из вкладки с текущей конфигурации во все остальные конфигурации модели.
4. Удаление ненужный свойств с возможностью восстановления.

Установка и настройка макроса:

1. Извлекаем из архива папку с макросом в удобное место.
2. Правой кнопкой мыши на свободном поле панелей инструментов из выпадающего списка выбираем Настройка. Перетаскиваем иконку будущего макроса на панель инструментов в удобное для себя место
   
   
3. В появившемся окне заполняем поля как указано на скрине ниже Шаг-1 Указываем путь к макросу. Шаг-2 Указываем точку входа как на скрине. Шаг-3 Выбираем иконку (по желанию) Шаг-4 Нажимаем ОК
   
4. Настройка ini-файла макроса. В папке с макросом идет файл настроек PropertyEditorSpec.ini открываем его любым текстовым редактором.
   1.  В разделе [OPTIONS] выставляем следующие параметры
      1. ForceUpperCaseValues=True - Если хотим чтобы все свойства были прописаны только заглавными буквами
      2. ForceUpperCaseValues=False - Если НЕ хотим чтобы все свойства были прописаны только заглавными буквами
      3. AllowUpperCaseChange=True - Если хотим чтобы была доступна настройка "Все значения в ВЕРХНЕМ регистре"
      4. AllowUpperCaseChange=False - Если НЕ хотим чтобы была доступна настройка "Все значения в ВЕРХНЕМ регистре"
      5. ForcePropertyAdd=True - Если хотим чтобы все свойства из этого файла добавлялись автоматически при запуске макроса
      6. ForcePropertyAdd=False - Если Не хотим чтобы все свойства из этого файла добавлялись автоматически при запуске макроса. Будут добавляться только при нажатии кнопки "Записать"
         На данный момент мои настройки вот такие:
         
   2. В разделе [MODEL-CUSTOM] прописываем те свойства, которые будут добавлены на вкладку Настройки модели в формате 
      ИмяСвойства, ТипСвойства
      
      Число после запятой определяет тип свойства согласно списка указаного в начале этого файла
      
   3. В разделе [MODEL-CONFIGURATION] прописываем те свойства, которые будут добавлены на вкладку Текущей конфигурации модели
      формат записи тот же
      
   4. В разделе [DRAWING-CUSTOM] прописываем те свойства, которые будут добавлены в свойства чертежа
      формат записи тот же
      
   5. В разделе [SPECIAL PROPERTIES] прописываем те свойства, которые будут отображаться в выпадающеем списке свойств при нажатии кнопки "Добавить"
      формат записи тот же
      

Интерфейс макроса:

 

Интерфейс интуитивно понятный расписывать не буду, напишу только пару моментов.

 

• Удаленные свойства помечаются маркером <Удалено> и могут быть возвращены назад при нажатии кнопки "Отменить удаление"

• Все изменения свойств не попадают в модель пока не нажата кнопка "Записать"
• Чтобы сбросить все изменения разом нажимаем на кнопку "Обновить" - макрос перечитает все свойства из модели заново.
• Чтобы добавить все свойства из текущей конфигурации во все остальные нажимаем кнопку "Во все конфигурации" Добавляются только свойства, без значений этих свойств.

Скачать макрос:

 

PropertyEditorSpec_v1.4+.zip

 

@Rich  Если посчитаете нужным можно подправить ссылку в первом посте ;)

[Kir95 950]

01.02.2021 в 19:21, EvilBear сказал:

..реально ли в сборках назначать различным элементам/группам элементов слои? Чтобы в чертеже, например, элементы располагались на своих слоях с присущими им свойствами

Каждый раз, вручную назначать слои, как-то надоедает )

 

Реально - макрос для создания и назначения чертёжных слоёв по имени свойств деталей. В деталях создать свойство "Layer", со значением "Обстановка", к примеру. В чертеже выбрать в дереве проектирования чертёжный вид и запустить макрос - будет создан слой "Обстановка" и этот слой будет назначен деталям. С версиями солида от 2018 года и моложе должен работать. Если в свойствах детали нет слоя, то, после работы макроса, назначенный вручную слой будет сброшен. В общем, аккуратнее ) Можно в чертеже или шаблоне чертежа заранее создать слои со своими свойствами, тогда они будут использованы при совпадении названий

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

Option Explicit
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swDraw As SldWorks.DrawingDoc
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swView As SldWorks.View
    Dim swDrawComp As SldWorks.DrawingComponent
    Dim bRet As Boolean
    Dim RefModel As SldWorks.Component2
    Dim swRefModel As ModelDoc2
    Dim RefModelType As String
    Dim swCustPropMgr As SldWorks.CustomPropertyManager
    Dim swLayerMgr As SldWorks.LayerMgr
    Dim swLayer As SldWorks.Layer
    Dim swCurLayer As String
    Dim drwLayer As String
    Dim ResolvedValOut  As String
    Dim bool As Boolean
    Dim swDrawModel As SldWorks.ModelDoc2
    Dim swDrawPart As SldWorks.PartDoc
    Dim vBody As Variant
    Dim swBody As SldWorks.Body2
    Dim swFace As SldWorks.Face2
    Dim swEnt As SldWorks.Entity
    Dim nErrors As Long
    Dim nWarnings As Long
    Dim STIME As Long
    Dim ETIME As Long
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
        If swModel.GetType <> swDocDRAWING Then
            MsgBox "Откройте чертёж"
        Exit Sub
        End If
    Set swDraw = swModel
    Set swSelMgr = swModel.SelectionManager
        If swSelMgr.GetSelectedObjectCount2(0) = 0 Then
            MsgBox "Сначала выберите чертёжный вид в дереве проектирования"
        Exit Sub
        End If
        If swSelMgr.GetSelectedObjectType2(1) <> 12 Then
        MsgBox "Сначала выберите чертёжный вид в дереве проектирования"
        Exit Sub
        End If
    Set swLayerMgr = swModel.GetLayerManager
    swCurLayer = swLayerMgr.GetCurrentLayer
    Set swView = swSelMgr.GetSelectedObject6(1, -1)
    Set swDrawComp = swView.RootDrawingComponent
STIME = Timer
    RefModelType = swView.GetReferencedModelName
        If LCase(Right(RefModelType, 6)) = "sldasm" Then
    ProcessDrawingComponent swApp, swDraw, swDrawComp, "    "
        Else
    ChangePartLayer
        End If
    swModel.ClearSelection2 True
    swLayerMgr.SetCurrentLayer (swCurLayer)
    Set swDraw = Nothing
ETIME = Timer
    MsgBox "Слои назначены за " & Format(ETIME - STIME, "0.0") & " сек"
End Sub
Private Sub ChangeComponentLayer(swApp As SldWorks.SldWorks, swDraw As SldWorks.DrawingDoc, swDrawComp As SldWorks.DrawingComponent, sLayerName As String)
    bRet = swDraw.CreateLayer2(sLayerName, "", 0, swLineCONTINUOUS, swLW_THIN, True, True): Debug.Assert bRet
    swDrawComp.Layer = sLayerName
End Sub
Sub ProcessDrawingComponent(swApp As SldWorks.SldWorks, swDraw As SldWorks.DrawingDoc, swDrawComp As SldWorks.DrawingComponent, sPadStr As String)
    Dim vDrawCompChildArr As Variant
    Dim vDrawCompChild As Variant
    Dim swDrawCompChild As SldWorks.DrawingComponent
        On Error Resume Next
    Set RefModel = swDrawComp.Component
    Set swRefModel = RefModel.GetModelDoc2
        If swRefModel.GetType = swDocPART Then
            Set swCustPropMgr = swRefModel.Extension.CustomPropertyManager("")
            bool = swCustPropMgr.Get6("Layer", False, drwLayer, ResolvedValOut, False, False)
        End If
    ResolvedValOut = Replace(ResolvedValOut, "/", "_")
    ResolvedValOut = Replace(ResolvedValOut, "@", "_")
        If ResolvedValOut <> "" Then
            Debug.Print sPadStr & swDrawComp.Name
            Debug.Print "        Назначен слой " & ResolvedValOut
        End If
    ChangeComponentLayer swApp, swDraw, swDrawComp, ResolvedValOut
    vDrawCompChildArr = swDrawComp.GetChildren
    If Not IsEmpty(vDrawCompChildArr) Then
        For Each vDrawCompChild In vDrawCompChildArr
            Set swDrawCompChild = vDrawCompChild
            ProcessDrawingComponent swApp, swDraw, swDrawCompChild, sPadStr + "  "
        Next
    End If
End Sub
Sub ChangePartLayer()
    Set swDrawModel = swApp.OpenDoc6(swView.GetReferencedModelName, swDocPART, swOpenDocOptions_Silent, "", nErrors, nWarnings)
    Set swDrawPart = swDrawModel
    vBody = swDrawPart.GetBodies2(swSolidBody, True)
    Set swBody = vBody(0)
    Set swFace = swBody.GetFirstFace
    Set swEnt = swFace
    bRet = swView.SelectEntity(swEnt, False)
    Set swRefModel = swView.ReferencedDocument
    Set swCustPropMgr = swRefModel.Extension.CustomPropertyManager("")
    bool = swCustPropMgr.Get6("Layer", False, drwLayer, ResolvedValOut, False, False)
    ResolvedValOut = Replace(ResolvedValOut, "/", "_")
    ResolvedValOut = Replace(ResolvedValOut, "@", "_")
        If ResolvedValOut <> "" Then
            Debug.Print swDrawComp.Name
            Debug.Print "        Назначен слой " & ResolvedValOut
        End If
    swDraw.ChangeComponentLayer ResolvedValOut, True
End Sub

 

Чтобы в тексте кода не было кракозябров, перед копированием лучше переключиться на русскую раскладку

[Kir95 950]

10 часов назад, Kir95 сказал:

макрос для создания и назначения чертёжных слоёв по имени свойств деталей

Вариант для св2014 (может и для более старых версий), со значком для макроса )

 

DrwLayerCreate.swp  Layers.bmp

 

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

Option Explicit
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swDraw As SldWorks.DrawingDoc
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swView As SldWorks.View
    Dim swDrawComp As SldWorks.DrawingComponent
    Dim bRet As Boolean
    Dim RefModel As SldWorks.Component2
    Dim swRefModel As ModelDoc2
    Dim RefModelType As String
    Dim swCustPropMgr As SldWorks.CustomPropertyManager
    Dim swLayerMgr As SldWorks.LayerMgr
    Dim swLayer As SldWorks.Layer
    Dim swCurLayer As String
    Dim drwLayer As String
    Dim ResolvedValOut  As String
    Dim bool As Boolean
    Dim swDrawModel As SldWorks.ModelDoc2
    Dim swDrawPart As SldWorks.PartDoc
    Dim vBody As Variant
    Dim swBody As SldWorks.Body2
    Dim swFace As SldWorks.Face2
    Dim swEnt As SldWorks.Entity
    Dim nErrors As Long
    Dim nWarnings As Long
    Dim STIME As Long
    Dim ETIME As Long
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
        If swModel.GetType <> swDocDRAWING Then
            MsgBox "Откройте чертёж"
        Exit Sub
        End If
    Set swDraw = swModel
    Set swSelMgr = swModel.SelectionManager
        If swSelMgr.GetSelectedObjectCount2(0) = 0 Then
            MsgBox "Сначала выберите чертёжный вид в дереве проектирования"
        Exit Sub
        End If
        If swSelMgr.GetSelectedObjectType2(1) <> 12 Then
        MsgBox "Сначала выберите чертёжный вид в дереве проектирования"
        Exit Sub
        End If
    Set swLayerMgr = swModel.GetLayerManager
    swCurLayer = swLayerMgr.GetCurrentLayer
    Set swView = swSelMgr.GetSelectedObject5(1)
    Set swDrawComp = swView.RootDrawingComponent
STIME = Timer
    RefModelType = swView.GetReferencedModelName
        If LCase(Right(RefModelType, 6)) = "sldasm" Then
    ProcessDrawingComponent swApp, swDraw, swDrawComp, "    "
        Else
    ChangePartLayer swDrawModel
        End If
    swModel.ClearSelection2 True
    swLayerMgr.SetCurrentLayer (swCurLayer)
    Set swDraw = Nothing
ETIME = Timer
    MsgBox "Слои назначены за " & Format(ETIME - STIME, "0.0") & " сек"
End Sub
Private Sub ChangeComponentLayer(swApp As SldWorks.SldWorks, swDraw As SldWorks.DrawingDoc, swDrawComp As SldWorks.DrawingComponent, sLayerName As String)
    bRet = swDraw.CreateLayer(sLayerName, "", 0, swLineCONTINUOUS, swLW_THIN, True): Debug.Assert bRet
    swDrawComp.Layer = sLayerName
End Sub
Sub ProcessDrawingComponent(swApp As SldWorks.SldWorks, swDraw As SldWorks.DrawingDoc, swDrawComp As SldWorks.DrawingComponent, sPadStr As String)
    Dim vDrawCompChildArr As Variant
    Dim vDrawCompChild As Variant
    Dim swDrawCompChild As SldWorks.DrawingComponent
        On Error Resume Next
    Set RefModel = swDrawComp.Component
    Set swRefModel = RefModel.GetModelDoc2
        If swRefModel.GetType = swDocPART Then
            Set swCustPropMgr = swRefModel.Extension.CustomPropertyManager("")
            bool = swCustPropMgr.Get5("Layer", False, drwLayer, ResolvedValOut, False)
        End If
    ResolvedValOut = Replace(ResolvedValOut, "/", "_")
    ResolvedValOut = Replace(ResolvedValOut, "@", "_")
        If ResolvedValOut <> "" Then
            Debug.Print sPadStr & swDrawComp.Name
            Debug.Print "        Назначен слой " & ResolvedValOut
        End If
    ChangeComponentLayer swApp, swDraw, swDrawComp, ResolvedValOut
    vDrawCompChildArr = swDrawComp.GetChildren
    If Not IsEmpty(vDrawCompChildArr) Then
        For Each vDrawCompChild In vDrawCompChildArr
            Set swDrawCompChild = vDrawCompChild
            ProcessDrawingComponent swApp, swDraw, swDrawCompChild, sPadStr + "  "
        Next
    End If
End Sub
Sub ChangePartLayer(swDrawModel As SldWorks.ModelDoc2)
    Set swDrawModel = swApp.OpenDoc6(swView.GetReferencedModelName, swDocPART, swOpenDocOptions_Silent, "", nErrors, nWarnings)
    Set swDrawPart = swDrawModel
    vBody = swDrawPart.GetBodies2(swSolidBody, True)
    Set swBody = vBody(0)
    Set swFace = swBody.GetFirstFace
    Set swEnt = swFace
    bRet = swView.SelectEntity(swEnt, False)
    Set swRefModel = swView.ReferencedDocument
    Set swCustPropMgr = swRefModel.Extension.CustomPropertyManager("")
    bool = swCustPropMgr.Get5("Layer", False, drwLayer, ResolvedValOut, False)
    ResolvedValOut = Replace(ResolvedValOut, "/", "_")
    ResolvedValOut = Replace(ResolvedValOut, "@", "_")
        If ResolvedValOut <> "" Then
            Debug.Print swDrawComp.Name
            Debug.Print "        Назначен слой " & ResolvedValOut
        End If
    swDraw.ChangeComponentLayer ResolvedValOut, True
End Sub

 

Названия слоёв берутся с общей вкладки, а не вкладки конфигураций

[livedten 34]

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

 

Мужики может кто помочь отредактировать макрос, а точнее поменять функции кнопок - это MProp от leona

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

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

TxtShape

 

 

MProp_ico.swp

Изменено 10 февраля 2021 пользователем livedten

[Kir95 950]

Подправил макрос для назначения слоёв - теперь не сбрасывает на значение "нет", если у детали нет свойства для слоя и ей уже был назначен свой слой в чертеже. Так же меняет свойство линий компонента на значение "по слою". Обычно, после назначения слоя компоненту, толщина и стиль не меняются, для этого нужно на вкладке "Свойства линий..." выбирать "по умолчанию"

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

Option Explicit
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swDraw As SldWorks.DrawingDoc
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swView As SldWorks.View
    Dim swDrawComp As SldWorks.DrawingComponent
    Dim bRet As Boolean
    Dim RefModel As SldWorks.Component2
    Dim swRefModel As ModelDoc2
    Dim RefModelType As String
    Dim swCustPropMgr As SldWorks.CustomPropertyManager
    Dim swLayerMgr As SldWorks.LayerMgr
    Dim swLayer As SldWorks.Layer
    Dim swCurLayer As String
    Dim drwLayer As String
    Dim ResolvedValOut  As String
    Dim bool As Boolean
    Dim swDrawModel As SldWorks.ModelDoc2
    Dim swDrawPart As SldWorks.PartDoc
    Dim vBody As Variant
    Dim swBody As SldWorks.Body2
    Dim swFace As SldWorks.Face2
    Dim swEnt As SldWorks.Entity
    Dim nErrors As Long
    Dim nWarnings As Long
    Dim STIME As Long
    Dim ETIME As Long
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
        If swModel.GetType <> swDocDRAWING Then
            MsgBox "Откройте чертёж"
        Exit Sub
        End If
    Set swDraw = swModel
    Set swSelMgr = swModel.SelectionManager
        If swSelMgr.GetSelectedObjectCount2(0) = 0 Then
            MsgBox "Сначала выберите чертёжный вид в дереве проектирования"
        Exit Sub
        End If
        If swSelMgr.GetSelectedObjectType2(1) <> 12 Then
        MsgBox "Сначала выберите чертёжный вид в дереве проектирования"
        Exit Sub
        End If
        
On Error Resume Next
        
    Set swLayerMgr = swModel.GetLayerManager
    swCurLayer = swLayerMgr.GetCurrentLayer
    Set swView = swSelMgr.GetSelectedObject5(1)
    Set swDrawComp = swView.RootDrawingComponent
STIME = Timer
    RefModelType = swView.GetReferencedModelName
        If LCase(Right(RefModelType, 6)) = "sldasm" Then
    ProcessDrawingComponent swApp, swDraw, swDrawComp, "    "
        Else
    ChangePartLayer swDrawModel
        End If
    swModel.ClearSelection2 True
    swLayerMgr.SetCurrentLayer (swCurLayer)
    Set swDraw = Nothing
ETIME = Timer
    MsgBox "Слои назначены за " & Format(ETIME - STIME, "0.0") & " сек"
End Sub
Private Sub ChangeComponentLayer(swApp As SldWorks.SldWorks, swDraw As SldWorks.DrawingDoc, swDrawComp As SldWorks.DrawingComponent, sLayerName As String)
    Dim sLayerNameNo As String: sLayerNameNo = "Non-existent layer"

         
        Debug.Assert swLayerMgr.AddLayer(sLayerName, "", 255, swLineCONTINUOUS, swLW_THICK)
   
        If sLayerName <> "" Then
        
        swDrawComp.UseDocumentDefaults = False 'True '

        swDrawComp.SetLineStyle swDrawingComponentLineFontVisible, swLineDEFAULT 'swLineDEFAULT swLineCHAIN swLineHIDDEN
        
        swDrawComp.SetLineThickness swDrawingComponentLineFontVisible, swLW_LAYER, 0 '0.0003 _LAYER _THICK3
        
        Else
        
        sLayerName = sLayerNameNo
        
        End If
        
    swDrawComp.Layer = sLayerName
    Debug.Print sLayerName
End Sub
Sub ProcessDrawingComponent(swApp As SldWorks.SldWorks, swDraw As SldWorks.DrawingDoc, swDrawComp As SldWorks.DrawingComponent, sPadStr As String)
    Dim vDrawCompChildArr As Variant
    Dim vDrawCompChild As Variant
    Dim swDrawCompChild As SldWorks.DrawingComponent
        On Error Resume Next
    Set RefModel = swDrawComp.Component
    Set swRefModel = RefModel.GetModelDoc2
'        If swRefModel.GetType = swDocPART Then
            Set swCustPropMgr = swRefModel.Extension.CustomPropertyManager("")
            bool = swCustPropMgr.Get5("Layer", False, drwLayer, ResolvedValOut, False)
'        End If
    ResolvedValOut = Replace(ResolvedValOut, "/", "_")
    ResolvedValOut = Replace(ResolvedValOut, "@", "_")
        If ResolvedValOut <> "" Then
            Debug.Print sPadStr & swDrawComp.Name
            Debug.Print "        Назначен слой " & ResolvedValOut
        End If
    ChangeComponentLayer swApp, swDraw, swDrawComp, ResolvedValOut
    vDrawCompChildArr = swDrawComp.GetChildren
    If Not IsEmpty(vDrawCompChildArr) Then
        For Each vDrawCompChild In vDrawCompChildArr
            Set swDrawCompChild = vDrawCompChild
            ProcessDrawingComponent swApp, swDraw, swDrawCompChild, sPadStr + "  "
        Next
    End If
End Sub
Sub ChangePartLayer(swDrawModel As SldWorks.ModelDoc2)
    Set swDrawModel = swApp.OpenDoc6(swView.GetReferencedModelName, swDocPART, swOpenDocOptions_Silent, "", nErrors, nWarnings)
    Set swDrawPart = swDrawModel
    vBody = swDrawPart.GetBodies2(swSolidBody, True)
    Set swBody = vBody(0)
    Set swFace = swBody.GetFirstFace
    Set swEnt = swFace
    bRet = swView.SelectEntity(swEnt, False)
    Set swRefModel = swView.ReferencedDocument
    Set swCustPropMgr = swRefModel.Extension.CustomPropertyManager("")
    bool = swCustPropMgr.Get5("Layer", False, drwLayer, ResolvedValOut, False) 'Layer
    ResolvedValOut = Replace(ResolvedValOut, "/", "_")
    ResolvedValOut = Replace(ResolvedValOut, "@", "_")
        If ResolvedValOut <> "" Then
            Debug.Print swDrawComp.Name
            Debug.Print "        Назначен слой " & ResolvedValOut
        End If
    swDraw.ChangeComponentLayer ResolvedValOut, True
End Sub
 

 

 

Макрос для удаления всех слоёв в чертеже. Слои хранятся в шаблоне основной надписи, чтобы вернуть слои из шаблона, в свойствах листа выбрать нужный шаблон -> "Перезагрузить" -> слои добавятся в чертёж. Слои соданные в текущем чертеже и не сохранённые в шаблон, естественно, не восстановятся )

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

Option Explicit
Sub main()
    Dim swApp                       As SldWorks.SldWorks
    Dim swModel                     As SldWorks.ModelDoc2
    Dim swLayerMgr                  As SldWorks.LayerMgr
    Dim vLayerArr                   As Variant
    Dim vLayer                      As Variant
    Dim swLayer                     As SldWorks.Layer
    Dim ModView                     As ModelView

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swLayerMgr = swModel.GetLayerManager
    Set ModView = swModel.ActiveView
    
ModView.EnableGraphicsUpdate = False
    vLayerArr = swLayerMgr.GetLayerList
    For Each vLayer In vLayerArr
        Set swLayer = swLayerMgr.GetLayer(vLayer)
        swLayerMgr.DeleteLayer (swLayer.Name)
    Next
ModView.EnableGraphicsUpdate = True
    swModel.GraphicsRedraw2
    MsgBox "Слои удалены!"
End Sub

 

[Kir95 950]

Макрос отменяет назначенные слои и восстанавливает значения по умолчанию для "Толщины линий компонентов". То есть значения будут браться из настроек документа для стиля линий видимого/невидимого контура. Значения для слоёв размеров, эскизов не меняются

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

Option Explicit
Sub main()
    Dim swApp                       As SldWorks.SldWorks
    Dim swModel                     As SldWorks.ModelDoc2
    Dim swDraw                      As SldWorks.DrawingDoc
    Dim swSelMgr                    As SldWorks.SelectionMgr
    Dim swSelData                   As SldWorks.SelectData
    Dim swModelDocExt               As SldWorks.ModelDocExtension
    Dim swView                      As SldWorks.View
    Dim swRootDrawComp              As SldWorks.DrawingComponent
    Dim vDrawChildCompArr           As Variant
    Dim vDrawChildComp              As Variant
    Dim swDrawComp                  As SldWorks.DrawingComponent
    Dim swComp                      As SldWorks.Component2
    Dim swCompModel                 As SldWorks.ModelDoc2
    Dim errors                      As Long
    Dim warnings                    As Long
    Dim bRet                        As Boolean
    Dim ModView                     As ModelView

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
        If swModel.GetType <> swDocDRAWING Then
            MsgBox "Откройте чертёж"
        Exit Sub
        End If

    
    Set ModView = swModel.ActiveView
    Set swDraw = swModel
    Set swModelDocExt = swModel.Extension
    Set swSelMgr = swModel.SelectionManager
    Set swSelData = swSelMgr.CreateSelectData
    
    On Error Resume Next
    
    Set swView = swSelMgr.GetSelectedObject6(1, -1)
    
        If swView Is Nothing Then
            MsgBox "Сначала выберите чертёжный вид" & vbCrLf & "в окне или дереве проектирования"
        Exit Sub
        End If

    ModView.EnableGraphicsUpdate = False

    Set swRootDrawComp = swView.RootDrawingComponent
    Debug.Print "File = " & swModel.GetPathName
    Debug.Print "  View = " & swView.Name
    vDrawChildCompArr = swRootDrawComp.GetChildren
    For Each vDrawChildComp In vDrawChildCompArr
        Set swDrawComp = vDrawChildComp
        Set swComp = swDrawComp.Component
        If Not Nothing Is swComp Then
            Set swCompModel = swComp.GetModelDoc2
            swDrawComp.UseDocumentDefaults = True
        End If
    Next
        swModel.ClearSelection2 True
        bRet = swModel.Save3(swSaveAsOptions_Silent, errors, warnings)
        
    ModView.EnableGraphicsUpdate = True
    
    swDraw.GraphicsRedraw2
    MsgBox "Толщина линий компонентов установлена" & vbCrLf & "в соответствии с настройками документа"
End Sub
 

 

Линии резной капители до и после работы макроса

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

 

 

В общем, что бы не говорили, но слои в солиде существуют не напрасно. Когда нужно скрыть или выделить другим цветом на чертеже крепёж, ручки/ножки, резные элементы и т.п., то с помощью слоёв это сделать намного проще и быстрее. Просто не задумывался раньше, что можно связать модель и чертёж, пока @EvilBear своим вопросом о назначении слоёв в сборке не направил ход мысли )

[tompsongun 450]

Округление в solidworks в уравнениях

round  (число, точность)

Изменено 2 марта 2021 пользователем tompsongun

[kenny 49]

@tompsongun

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

это наверное у вас параметр "Total lenght"

Изменено 2 марта 2021 пользователем kenny

[tompsongun 450]

@kenny , увы, не знаю. этот "total lenght"  из сварных, а сварные сплайны не понимают - приходится дугами и линиями рисовать

 

на входном и выходном концах в 3д эскизе рисую две прямые линии, соединяю их сплайном, задаю касательности. потом по этому сплайну пару или более дуг и линий размещаю, сплайн или удаляю или во вспомогательные, выполняю сварные конструкции

Изменено 2 марта 2021 пользователем tompsongun

[tompsongun 450]

в общем, довольно сносно можно нарисовать и посчитать, учитывая минимальные радиусы изгиба

 

естественно лучше все трубы в одну деталь не лепить, и даже в одной детали лучше разбивать на несколько веток - несколько эскизов. это эж сварные, и 3д бывает глючит с привязками и когда перестраиваешь сами сварные.

 

да, есть роутинг, но не освоили.. да и там надо, как я понимаю, свою библиотеку прежде создать

Изменено 2 марта 2021 пользователем tompsongun

[Kir95 950]

1 час назад, kenny сказал:

как узнать длину сплайна одной функцией? чтобы не суммировать кучу размеров в формулах

 

Переделывал пример из справки солида - макрос считает общую длину линий эскиза, копирует её в буфер обмена (чтобы вставить в заметку или в свойства) и показывает в сообщении. Работает в модели и в чертеже. Эскиз выбрать в дереве предварительно

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

'----------------------------------------------------
'http://help.solidworks.com/2018/english/api/sldworksapi/Find_Total_Length_of_Sketch_Segments_in_Sketch_Example_VB.htm?verRedirect=1
 Option Explicit
Public Enum swSketchSegments_e
    swSketchLINE = 0
    swSketchARC = 1
    swSketchELLIPSE = 2
    swSketchSPLINE = 3
    swSketchTEXT = 4
    swSketchPARABOLA = 5
End Enum
Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swFeat As SldWorks.Feature
    Dim swSketch As SldWorks.Sketch
    Dim i As Long
    Dim bRet As Boolean
    Dim vSketchSeg As Variant
    Dim swSketchSeg As SldWorks.SketchSegment
    Dim nLength As Double
    
    Dim obj As New DataObject
    Dim txt As String
    Dim txt2 As String

    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    Set swSelMgr = swModel.SelectionManager
    On Error GoTo Line

    Set swFeat = swSelMgr.GetSelectedObject6(1, -1)
    
    If swFeat Is Nothing Then
Line:
    MsgBox "Нужно выбрать эскиз в дереве проектирования."
    Exit Sub
    End If
    
    Set swSketch = swFeat.GetSpecificFeature2
    vSketchSeg = swSketch.GetSketchSegments
    For i = 0 To UBound(vSketchSeg)
        Set swSketchSeg = vSketchSeg(i)
        ' Ignore construction lines
        If swSketchSeg.ConstructionGeometry = False Then
            ' Ignore text
            If swSketchTEXT <> swSketchSeg.GetType Then
                nLength = nLength + swSketchSeg.GetLength
            End If
        End If
    Next i
    Debug.Print "File = " & swModel.GetPathName
    Debug.Print "  Sketch = " & swFeat.Name
    MsgBox "Наименование эскиза " & vbCrLf & _
    "< " & swFeat.Name & " >" + vbCrLf + "Total length in mm = " & Format(nLength * 1000#, "00") & " mm" & vbCrLf & _
    "Total length in meters = " & Format(nLength, "0.000") & " m"
    
    'Put some text inside a string variable
  txt = Format(nLength * 1000#, "0.00") 'ResCount '"This was copied to the clipboard using VBA!"

'Make object's text equal above string variable
  obj.SetText txt

'Place DataObject's text into the Clipboard
  obj.PutInClipboard
  obj.GetFromClipboard
  txt2 = obj.GetText
  Debug.Print txt2 & " mm"

End Sub