Макрос - Выделить все окружности определенного диаметра в Эскизе.

[filmi 2]

Помогите пожалуйста написать макрос для SW2019.
После импорта из Altium в SW (через DXF) в эскизе полно (50+) мелких окружностей диаметром 0,05мм. Их надо выделить и удалить. Ручками очень долго.
С помошью AI создал макрос для выделения всех Arc - работает.
А вот с проверкой радиуса Arc никак не получается.

 

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

 

Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then
        MsgBox "No document open.", vbCritical
        Exit Sub
    End If
    

    ' Ensure a sketch is active for editing
    If Not swModel.SketchManager.ActiveSketch Is Nothing Then
        Set swSketch = swModel.SketchManager.ActiveSketch
    Else
        MsgBox "No active sketch found. Please edit a sketch.", vbCritical
        Exit Sub
    End If

    swModel.ClearSelection2 True ' Clear any previous selections

    Dim vSkSegments As Variant
    Dim swSkSegment As SldWorks.SketchSegment
    Dim i As Integer

    vSkSegments = swSketch.GetSketchSegments() ' Get all sketch segments in the active sketch

    If Not IsEmpty(vSkSegments) Then
        For i = 0 To UBound(vSkSegments)
            Set swSkSegment = vSkSegments(i)

            ' Check if the segment is an arc
            If swSkSegment.GetType() = swSketchSegments_e.swSketchARC Then
                swSkSegment.Select True ' Add to selection
            End If
        Next i
    End If

    MsgBox "All arcs in the active sketch have been selected.", vbInformation

End Sub

 

 

 

[Kelny 1,600]

18 минут назад, filmi сказал:

С помошью AI создал макрос для выделения всех Arc - работает.

ИИ до добра не доведёт - надо бы свой И включать.

Как вариант использовать свой И, а так же справку:

https://help.solidworks.com/2012/english/api/sldworksapiprogguide/Welcome.htm

https://help.solidworks.com/2012/english/api/sldworksapi/Get_Broken_Out_Section_Feature_Data_Example_VB.htm

 

Как вариант:

18 минут назад, filmi сказал:

...

            If swSkSegment.GetType() = swSketchSegments_e.swSketchARC Then
                swSkSegment.Select True ' Add to selection

 

if swSkSegment.GetRadius < 0.0001 then  swModel.DeleteSelection True 'Радиус в метрах

            End If

...

 

Edited September 29, 2025 by Kelny

[filmi 2]

Спасибо. Я очень далек от этой темы.
Попробовал вашу строку - ошибка 438.

[Chuvak 191]

@filmi , какая версия SW? Ошибка 438 говорит о том, что данный объект не поддерживает указанный метод или свойство, что вполне логично. Нужно более явно задать объект SketchArc

Edited September 30, 2025 by Chuvak

[Chuvak 191]

17 часов назад, filmi сказал:

Помогите пожалуйста написать макрос для SW2019.

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

[Kelny 1,600]

2 часа назад, filmi сказал:

Спасибо. Я очень далек от этой темы.
Попробовал вашу строку - ошибка 438.

Хотите сказать, что до правок всё работало?

В оригинле дальше первых строк не должно запускаться:

Цитата

Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then
        MsgBox "No document open.", vbCritical
        Exit Sub
    End If

...

Ведь не хватает в начале процедуры или над ней:

Цитата

Option Explicit 'It is an option that turns on check for every used variable to be defined before execution.

'If this option is not defined, your code below will find undefined variables and define them when they are used.

'Good practice is to use this option, because it helps you, for example to prevent missprinting errors in variable names.

 

Sub main()

    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swSketch As SldWorks.Sketch

...

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

Цитата

            ' Check if the segment is an arc
            If swSkSegment.GetType() = swSketchSegments_e.swSketchARC Then
                swSkSegment.Select False ' One arc selection
                If swSkSegment.GetRadius < 0.0001 Then swModel.DeleteSelection False 'Del Arc <0.0001 m
            End If

 

Edited September 30, 2025 by Kelny

[Chuvak 191]

@filmi, макрос готов, тестировал на SW 2018

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

Option Explicit

'---БЛОК ОБЪЯВЛЕНИЯ ПЕРЕМЕННЫХ SOLIDWORKS---
Private swApp           As SldWorks.SldWorks
Private swModel         As SldWorks.ModelDoc2
Private swModelDocExt   As SldWorks.ModelDocExtension
Private swSketch        As SldWorks.Sketch
Private vSkSegments     As Variant
Private swSkSegment     As SldWorks.SketchSegment
Private swSkArc         As SldWorks.SketchArc
Private i               As Long
Private Const Diameter  As Double = 0.05    ' константа для задания диаметра

Public Sub Prog1_MainProgram()    ' Главная программа макроса "Удаление окружностей менее заданного диаметра"

    On Error GoTo ErrorHandler      ' активируем обработчик ошибок
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then          ' если модель не открыта, то
        MsgBox Prompt:="Модель не открыта. Пожалуйста, откройте файл перед выполнением операции", Buttons:=48, Title:="Предупреждение"
        End ' закрываем макрос
    End If
    
    If swModel.SketchManager.ActiveSketch Is Nothing Then   ' если эскиз не активен, то
        MsgBox Prompt:="Не найден активный эскиз. Пожалуйста, активируйте эскиз", Buttons:=48, Title:="Предупреждение"
        End ' закрываем макрос
    End If
    
    Set swModelDocExt = swModel.Extension
    Set swSketch = swModel.SketchManager.ActiveSketch
    swModel.ClearSelection2 True                    ' очищаем список выбранных объектов
    vSkSegments = swSketch.GetSketchSegments()      ' получаем все объекты в эскизе (линии, кружности, сплайны и т.п.)

    If Not IsEmpty(vSkSegments) Then    ' если эскиз не пустой, то
        For i = LBound(vSkSegments) To UBound(vSkSegments)
            Set swSkSegment = vSkSegments(i)

            If swSkSegment.GetType() = 1 Then   ' если объект эскиза - окружность (дуга), то
                swSkSegment.Select4 False, Nothing ' выбираем окружность
                Set swSkArc = swSkSegment
                ' Если диаметр выбранной окружности меньше или равно 0,05 мм, то удаляем ее
                If swSkSegment.GetRadius <= Diameter * 500 And swSkArc.IsCircle = 1 Then swModelDocExt.DeleteSelection2 4
            End If
        Next i
    Else
        MsgBox Prompt:="Эскиз не содержит объектов", Buttons:=48, Title:="Предупреждение"
    End If

    MsgBox Prompt:="Операция успешно выполнена!", Buttons:=64, Title:="Сообщение"   ' открываем сообщение об успешном завершении операции
    End ' закрываем макрос
        
ErrorHandler:   ' если в макросе произошла ошибка, то
    MsgBox Prompt:="ВНИМАНИЕ! Произошла непредвиденная ошибка." & vbNewLine & "Код и описание ошибки: " & vbNewLine & Err.Number & " - " & Err.Description, Buttons:=16, Title:="ОШИБКА" ' информируем о критической ошибке
    End     ' закрываем макрос
End Sub

 

 

[Kelny 1,600]

34 минуты назад, Chuvak сказал:

Private Const Diameter As Double = 0.05 ' константа для задания диаметра

...

' Если диаметр выбранной окружности меньше или равно 0,05 мм, то удаляем ее

If swSkSegment.GetRadius <= Diameter * 500 And swSkArc.IsCircle = 1 Then swModelDocExt.DeleteSelection2 4

 

Можно чуть подробнее про 0,05 мм - как оно получается? Ведь 0,05 в GetRadius будут 0,05 метра или 50 мм, а не 0,05 мм.

А так же "swSkSegment.GetRadius <= Diameter * 500" - что это за волшебный коэффицент "* 500"? Почему не 2, что бы из радиуса получить диаметр?

 

[jtok 1,064]

Предлагаю ввести счетчик удаленных окружностей и в конце выводить его количество. 

[Kelny 1,600]

4 минуты назад, jtok сказал:

Предлагаю ввести счетчик удаленных окружностей и в конце выводить его количество. 

Можно, но какой в этом практический смысл?

 

19 часов назад, filmi сказал:

После импорта из Altium в SW (через DXF)

Что именно вы передаёте из Altium?

Может сподручнее использовать инструмент передачи моделей через нейтральный формта вроде Parasolid, Step или импортировать геометрию платы через CircuitWorks?

Edited September 30, 2025 by Kelny

[jtok 1,064]

2 минуты назад, Kelny сказал:

но какой в этом практический смысл?

Ну нажал юзер кнопку, ему ответило «Операция успешно выполнено». 
Чего выполнено, сколько выполнено - непонятно. Еще раз нажал - еще раз то же сообщение. «Дурацкий макрос» - подумает пользователь)

[Chuvak 191]

17 минут назад, Kelny сказал:

 

Можно чуть подробнее про 0,05 мм - как оно получается? Ведь 0,05 в GetRadius будут 0,05 метра или 50 мм, а не 0,05 мм.

А так же "swSkSegment.GetRadius <= Diameter * 500" - что это за волшебный коэффицент "* 500"? Почему не 2, что бы из радиуса получить диаметр?

Извиняюсь, опечатался, конечно делить на 2000.  Сейчас переделаю, протестирую и скину

9 минут назад, jtok сказал:

Ну нажал юзер кнопку, ему ответило «Операция успешно выполнено». 
Чего выполнено, сколько выполнено - непонятно. Еще раз нажал - еще раз то же сообщение. «Дурацкий макрос» - подумает пользователь)

Окей, добавлю данную функцию)

Edited September 30, 2025 by Chuvak

[filmi 2]

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

Что именно вы передаёте из Altium?

Может сподручнее использовать инструмент передачи моделей через нейтральный формта вроде Parasolid, Step или импортировать геометрию платы через CircuitWorks?

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

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

       

 

[Snake 60 883]

@filmi Скиньте пожалуйста DXF? чтобы было на чем проверить работу макроса.

[Chuvak 191]

@filmi , исправил предыдущий код. Были проблемы с обработкой полученного значение радиуса окружности, но справился форматированием.

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

Option Explicit

'---БЛОК ОБЪЯВЛЕНИЯ ПЕРЕМЕННЫХ SOLIDWORKS---
Private swApp           As SldWorks.SldWorks
Private swModel         As SldWorks.ModelDoc2
Private swModelDocExt   As SldWorks.ModelDocExtension
Private swSketch        As SldWorks.Sketch
Private vSkSegments     As Variant
Private swSkSegment     As SldWorks.SketchSegment
Private swSkArc         As SldWorks.SketchArc
Private boolStatus      As Boolean
Private i               As Long
Private j               As Long
Private Const Diameter  As Double = 0.05    ' константа для задания диаметра в мм

Public Sub Prog1_MainProgram()    ' Главная программа макроса "Удаление окружностей менее заданного диаметра"

    On Error GoTo ErrorHandler      ' активируем обработчик ошибок
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then          ' если модель не открыта, то
        MsgBox Prompt:="Модель не открыта. Пожалуйста, откройте файл перед выполнением операции", Buttons:=48, Title:="Предупреждение"
        End ' закрываем макрос
    End If
    
    If swModel.SketchManager.ActiveSketch Is Nothing Then   ' если эскиз не активен, то
        MsgBox Prompt:="Не найден активный эскиз. Пожалуйста, активируйте эскиз", Buttons:=48, Title:="Предупреждение"
        End ' закрываем макрос
    End If
    
    Set swModelDocExt = swModel.Extension
    Set swSketch = swModel.SketchManager.ActiveSketch
    swModel.ClearSelection2 True                    ' очищаем список выбранных объектов
    vSkSegments = swSketch.GetSketchSegments        ' получаем все объекты в эскизе (линии, окружности, сплайны и т.п.)

    If Not IsEmpty(vSkSegments) Then    ' если эскиз не пустой, то
        j = 0   ' переменная для подсчета удаленных окружностей
        For i = LBound(vSkSegments) To UBound(vSkSegments)
            Set swSkSegment = vSkSegments(i)
            If swSkSegment.GetType = 1 Then   ' если объект эскиза - окружность (дуга), то
                Set swSkArc = swSkSegment
                ' Если диаметр выбранной окружности (не дуги) меньше или равно значению константы, то
                If CDbl(Format(swSkSegment.GetRadius, "General Number")) <= (Diameter / 2000) And swSkArc.IsCircle = 1 Then
                    boolStatus = swSkSegment.Select4(True, Nothing)   ' выбираем окружность
                    j = j + 1
                End If
            End If
        Next i
    Else
        MsgBox Prompt:="Эскиз не содержит объектов", Buttons:=48, Title:="Предупреждение"
    End If
    
    ' если была найдена хотя бы одна окружность, то
    If j > 0 Then
        boolStatus = swModelDocExt.DeleteSelection2(4) ' удаляем все выбранные окружности
        MsgBox Prompt:="Операция успешно выполнена!" & vbNewLine & "Кол-во удаленных окружностей: " & j, Buttons:=64, Title:="Сообщение"   ' открываем сообщение об успешном завершении операции
    Else
        MsgBox Prompt:="Эскиз не содержит окружностей c заданным диаметром", Buttons:=64, Title:="Сообщение"   ' информируем об отсутствии окружностей
    End If
    
    End ' закрываем макрос
        
ErrorHandler:   ' если в макросе произошла ошибка, то
    MsgBox Prompt:="ВНИМАНИЕ! Произошла непредвиденная ошибка." & vbNewLine & "Код и описание ошибки: " & vbNewLine & Err.Number & " - " & Err.Description, Buttons:=16, Title:="ОШИБКА" ' информируем о критической ошибке
    End     ' закрываем макрос
End Sub

 

 

[Chuvak 191]

Нет, проблема осталась. Гребаная плавающая точка)

[filmi 2]

@Chuvak  Спасибо огромное! РАБОТАЕТ! 
 

@Snake 60 01.DWG

[jtok 1,064]

30 минут назад, Chuvak сказал:

' если была найдена хотя бы одна окружность, то If j > 0 Then

Муахахахахахах, переменной нашлось применение в основном коде, не только для информации))

[Chuvak 191]

@filmi Все, отполировал код, теперь точно нормально работает

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

Option Explicit

'---БЛОК ОБЪЯВЛЕНИЯ ПЕРЕМЕННЫХ SOLIDWORKS---
Private swApp           As SldWorks.SldWorks
Private swModel         As SldWorks.ModelDoc2
Private swModelDocExt   As SldWorks.ModelDocExtension
Private swSketch        As SldWorks.Sketch
Private vSkSegments     As Variant
Private swSkSegment     As SldWorks.SketchSegment
Private swSkArc         As SldWorks.SketchArc
Private boolStatus      As Boolean
Private i               As Long
Private Const Diameter  As Double = 0.05        ' константа для задания диаметра в мм

Public Sub Prog1_MainProgram()    ' Главная программа макроса "Удаление окружностей менее заданного диаметра"

    On Error GoTo ErrorHandler      ' активируем обработчик ошибок
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then          ' если модель не открыта, то
        MsgBox Prompt:="Модель не открыта. Пожалуйста, откройте файл перед выполнением операции", Buttons:=48, Title:="Предупреждение"
        End ' закрываем макрос
    End If
    
    If swModel.SketchManager.ActiveSketch Is Nothing Then   ' если эскиз не активен, то
        MsgBox Prompt:="Не найден активный эскиз. Пожалуйста, активируйте эскиз", Buttons:=48, Title:="Предупреждение"
        End ' закрываем макрос
    End If
    
    Set swModelDocExt = swModel.Extension
    Set swSketch = swModel.SketchManager.ActiveSketch
    swModel.ClearSelection2 True                    ' очищаем список выбранных объектов
    vSkSegments = swSketch.GetSketchSegments        ' получаем все объекты в эскизе (линии, окружности, сплайны и т.п.)

    If Not IsEmpty(vSkSegments) Then    ' если эскиз не пустой, то
        For i = LBound(vSkSegments) To UBound(vSkSegments)
            Set swSkSegment = vSkSegments(i)
            If swSkSegment.GetType = 1 Then   ' если объект эскиза - окружность (дуга), то
                Set swSkArc = swSkSegment
                ' Если диаметр выбранной окружности (не дуги) меньше или равно значению константы, то
                If CDbl(FormatNumber(swSkSegment.GetRadius, Len(CStr(Diameter / 2000)) - InStr(1, CStr(Diameter / 2000), ","))) <= (Diameter / 2000) And swSkArc.IsCircle = 1 Then _
                    boolStatus = swSkSegment.Select4(True, Nothing)   ' выбираем окружность
            End If
        Next i
    Else
        MsgBox Prompt:="Эскиз не содержит объектов", Buttons:=48, Title:="Предупреждение"
    End If
    
    i = swModel.SelectionManager.GetSelectedObjectCount2(-1)
    If i > 0 Then   ' если была найдена хотя бы одна окружность, то
        boolStatus = swModelDocExt.DeleteSelection2(4) ' удаляем все выбранные окружности
        MsgBox Prompt:="Операция успешно выполнена!" & vbNewLine & "Кол-во удаленных окружностей: " & i, Buttons:=64, Title:="Сообщение"   ' открываем сообщение об успешном завершении операции
    Else
        MsgBox Prompt:="Эскиз не содержит окружностей c заданным диаметром", Buttons:=64, Title:="Сообщение"   ' информируем об отсутствии окружностей
    End If
    
    End ' закрываем макрос
        
ErrorHandler:   ' если в макросе произошла ошибка, то
    MsgBox Prompt:="ВНИМАНИЕ! Произошла непредвиденная ошибка." & vbNewLine & "Код и описание ошибки: " & vbNewLine & Err.Number & " - " & Err.Description, Buttons:=16, Title:="ОШИБКА" ' информируем о критической ошибке
    End     ' закрываем макрос
End Sub

 

 

11 минут назад, jtok сказал:

Муахахахахахах, переменной нашлось применение в основном коде, не только для информации))

Исправил косяк)

15 минут назад, filmi сказал:

Спасибо огромное! РАБОТАЕТ! 

У меня некорректно работал на разных примерах, видимо из-за плавающей точки

[jtok 1,064]

2 часа назад, Chuvak сказал:

отполировал код

Я бы в начале вывел inputQuery с сообщением, что будут удалены все дуги с радиусом таким-то, в поле ввода стоит число "0,05" выделенное - если Ок, то побежали, если Cancel, то отмена, ну или юзер может изменить число. Т.е. формы не надо даже, но запрос бы не помешал.