Загрузка данных


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