Перейти к публикации

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


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

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

HideEdge выкладываю

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

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

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

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


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

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

 

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

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

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

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

 

2021-02-05_124727.jpg

Ссылка на сообщение
Поделиться на других сайтах
3 часа назад, malvi.dp сказал:

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

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

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

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

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

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

Ссылка на сообщение
Поделиться на других сайтах
16 минут назад, Rich сказал:

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

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

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

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

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

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

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

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

Ссылка на сообщение
Поделиться на других сайтах
22 часа назад, malvi.dp сказал:

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

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

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

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

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

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

Ссылка на сообщение
Поделиться на других сайтах
1 час назад, none сказал:

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

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

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

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

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

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

 

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

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

 

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

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

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

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

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

  1. Извлекаем из архива папку с макросом в удобное место.
  2. Правой кнопкой мыши на свободном поле панелей инструментов из выпадающего списка выбираем Настройка. Перетаскиваем иконку будущего макроса на панель инструментов в удобное для себя место

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

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

 

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

 

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

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

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

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

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

 

PropertyEditorSpec_v1.4+.zip

 

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

Ссылка на сообщение
Поделиться на других сайтах
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

 

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

Ссылка на сообщение
Поделиться на других сайтах
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

 

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

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

 

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

0001.PNG

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

0002.PNG

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

TxtShape

0003.PNG

 

 

MProp_ico.swp

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

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

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

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

 

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

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

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

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
 

 

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

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

резные капители-линии по слою.jpg

 

резные капители-линии по умолчанию.jpg

 

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

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

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

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

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

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

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

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

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

@tompsongun

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

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

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

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

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

 

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

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

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

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

 

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

 

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

Изменено пользователем tompsongun
Ссылка на сообщение
Поделиться на других сайтах
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

 

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

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

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

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

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

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

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

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

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

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

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



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