Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swEdge As SldWorks.Edge
Dim swCurve As SldWorks.Curve
Dim swCenterMark As SldWorks.CenterMark
Dim dblDiameterMM As Double
Dim vCircleParams As Variant
Sub main()
' Инициализация
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
' Проверка, что открыт чертеж
If swModel Is Nothing Then
MsgBox "Откройте чертеж"
Exit Sub
End If
If swModel.GetType <> 3 Then ' swDocDRAWING = 3
MsgBox "Это не чертеж. Откройте чертеж."
Exit Sub
End If
Set swDraw = swModel
Set swSelMgr = swModel.SelectionManager
' 1. Проверяем, что выделено ребро (кромка)
If swSelMgr.GetSelectedObjectType3(1, -1) <> 24 Then ' swSelEDGES = 24
MsgBox "Выделите кромку отверстия (окружность на чертеже)"
Exit Sub
End If
' 2. Получаем ребро БЕЗОПАСНО через промежуточный объект
Dim swObj As Object
Set swObj = swSelMgr.GetSelectedObject6(1, -1)
If swObj Is Nothing Then
MsgBox "Не удалось получить объект"
Exit Sub
End If
' Принудительно приводим к типу Edge
Set swEdge = swObj
' 3. Получаем кривую ребра
Set swCurve = swEdge.GetCurve
If swCurve Is Nothing Then
MsgBox "Не удалось получить кривую"
Exit Sub
End If
' 4. Проверяем, что это окружность
If Not swCurve.IsCircle() Then
MsgBox "Выделенная кромка не является окружностью"
Exit Sub
End If
' 5. Получаем диаметр (CircleParams возвращает массив: [X, Y, Z, X, Y, Z, Radius])
vCircleParams = swCurve.CircleParams
dblDiameterMM = vCircleParams(6) * 2 * 1000 ' Радиус в метрах → диаметр в мм
' 6. Вставляем центровую метку (обычный крест)
' 2 = swCenterMark_Single
Set swCenterMark = swDraw.InsertCenterMark3(2, False, False)
If swCenterMark Is Nothing Then
MsgBox "Не удалось вставить центровую метку."
Exit Sub
End If
' 7. Настраиваем центровую метку по ГОСТ 2.303-68
' Отключаем настройки документа, чтобы применить локальные
swCenterMark.UseDocDisplaySettings = False
If dblDiameterMM < 12 Then
' МЕНЬШЕ 12 мм — сплошная тонкая линия
swCenterMark.CenterLineFont = False
swCenterMark.Size = 0.003 ' 3 мм в метрах
swCenterMark.Gap = 0.001 ' 1 мм в метрах
Else
' БОЛЬШЕ ИЛИ РАВНО 12 мм — штрихпунктирная линия (осевой шрифт)
swCenterMark.CenterLineFont = True
swCenterMark.Size = 0.006 ' 6 мм в метрах
swCenterMark.Gap = 0.0015 ' 1.5 мм в метрах
End If
' Масштабируется по виду
swCenterMark.ScaleByView = True
' 8. Обновляем чертеж
swModel.ForceRebuild3 False
' 9. Выводим результат
MsgBox "Центровая метка вставлена!" & vbCrLf & _
"Диаметр: " & Round(dblDiameterMM, 2) & " мм" & vbCrLf & _
"Тип: " & IIf(dblDiameterMM < 12, "Сплошная тонкая", "Штрихпунктирная (осевая)")
End Sub