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


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