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 vParams As Variant
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swDraw = swModel
Set swSelMgr = swModel.SelectionManager
' 1. Проверяем, что выделено ребро
If swSelMgr.GetSelectedObjectType3(1, -1) <> 24 Then
MsgBox "Выделите ребро отверстия"
Exit Sub
End If
Set swEdge = swSelMgr.GetSelectedObject6(1, -1)
Set swCurve = swEdge.GetCurve
' 2. Проверяем, что это окружность, и получаем диаметр
If Not swCurve.IsCircle() Then
MsgBox "Ребро не является окружностью"
Exit Sub
End If
vParams = swCurve.CircleParams ' vParams(6) = Radius
dblDiameterMM = vParams(6) * 2 * 1000 ' Переводим радиус (м) в диаметр (мм)
' 3. Вставляем центровую метку (обычный крест)
Set swCenterMark = swDraw.InsertCenterMark3(swCenterMarkStyle_e.swCenterMarkStyle_Cross, False, False)
If swCenterMark Is Nothing Then
MsgBox "Не удалось вставить центровую метку"
Exit Sub
End If
' 4. Применяем настройки по ГОСТ 2.303-68
swCenterMark.UseDocDisplaySettings = False ' Используем локальные настройки
If dblDiameterMM < 12 Then
' Для отверстий МЕНЬШЕ 12 мм — сплошная тонкая линия
swCenterMark.CenterLineFont = False
swCenterMark.Size = 0.003
swCenterMark.Gap = 0.001
Else
' Для отверстий 12 мм и БОЛЬШЕ — штрихпунктирная линия (осевой шрифт)
swCenterMark.CenterLineFont = True
swCenterMark.Size = 0.006
swCenterMark.Gap = 0.0015
End If
swCenterMark.ScaleByView = True ' Масштабирование по виду
swModel.ForceRebuild3 False
MsgBox "Центровая метка вставлена. Диаметр: " & Round(dblDiameterMM, 2) & " мм"
End Sub