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. Получаем ребро
On Error Resume Next
Set swEdge = swSelMgr.GetSelectedObject6(1, -1)
On Error GoTo 0
If swEdge Is Nothing Then
MsgBox "Не удалось получить ребро. Попробуйте выделить заново."
Exit Sub
End If
' 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. Вставляем центровую метку (обычный крест)
Set swCenterMark = swDraw.InsertCenterMark3(2, False, False) ' 2 = swCenterMark_Single
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