[lerok1789]

Здравствуйте.
Подскажите, пожалуйста, как в автокаде можно создать блок, который при вставке в модели будет выравниваться перпендикулярно полилинии.
То есть есть полилиния (ось газопровода) на которую нужно разместить блоки, так что бы они выравнивались вдоль этой линии.

[Сергей812]

блок не знает о полилинии, по которой он должен выровняться)

[lerok1789]

Сообщение от Сергей812 блок не знает о полилинии, по которой он должен выровняться)

Тогда только вручную ровнять каждый вставляемый элемент?
Видела блоки пилонов, которые вставлялись горизонтально или вертикально, в зависимости от оси. С осью газопровода так не получится сделать?

[Сергей812]

видел когда то лиспы, которые выравнивали примитивы "скопом" по указанному объекту. Попробуйте поискать.

[Boxa]

Сообщение от lerok1789 Подскажите, пожалуйста, как в автокаде можно создать блок, который при вставке в модели будет выравниваться перпендикулярно полилинии.

Вам нужен параметр "Выравнивание" и сунуть его в базовую точку блока

[lerok1789]

Спасибо попробую

[zenon]

Может это поможет?
https://www.lee-mac.com//objectalign.html
или это
https://www.lee-mac.com//autoblockbreak.html

[Dinoxromniy]

Сообщение от lerok1789 есть есть полилиния (ось газопровода) на которую нужно разместить блоки, так что бы они выравнивались вдоль этой линии

Если речь именно про линию без дуг, можно воспользоваться кодом VBA ниже. Код вставляет блок под названием "1", который нужно создать в документе предварительно. Запустите код, выделите полилинию, потом укажите необходимое количество точке на полилинии - если код в состоянии, он вставит под необходимым углом. Если промахнулись мимо полилинии - просто вставляет. Вопрос в какую сторону крутить до перпендикулярности вы не поднимали, соответственно направление произвольное.

Код:

[Выделить все]

Sub blref_rot_pline()
Dim blrObj As AcadBlockReference
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim ssObj As AcadSelectionSet
Dim insPnt As Variant
Dim i As Integer
Dim intOM As Integer
Dim points() As Double
intOM = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 2659
    FilterType(0) = 0
    FilterData(0) = "LWPOLYLINE"
    For Each ssObj In ThisDrawing.SelectionSets
    If ssObj.Name = "qw" Then
        ssObj.Delete
        Exit For
    End If
    Next
    Set ssObj = ThisDrawing.SelectionSets.Add("qw")
    ssObj.SelectOnScreen FilterType, FilterData
        If ssObj.count > 0 Then
        ReDim points(UBound(ssObj.Item(0).Coordinates)) As Double
        points = ssObj.Item(0).Coordinates
        
        End If
        On Error Resume Next
        insPnt = ThisDrawing.Utility.GetPoint(, "Укажите точку вставки")
        Do While Err.Number = 0
          Set blrObj = ThisDrawing.ModelSpace.InsertBlock(insPnt, "1", 1, 1, 1, 0)
          If UBound(blrObj.IntersectWith(ssObj.Item(0), acExtendNone)) > 0 Then
              For i = 0 To UBound(points) - 2 Step 2
                 
                      If (points(i + 2) - points(i)) = 0 Then
                        If points(i) = insPnt(0) And Abs(points(i + 3) - points(i + 1)) > Abs(points(i + 3) - insPnt(1)) And Abs(points(i + 3) - points(i + 1)) > Abs(points(i + 1) - insPnt(1)) Then
                            blrObj.Rotation = -3.14 / 2
                            Exit For
                        End If
                      ElseIf Abs(insPnt(1) - ((points(i + 3) - points(i + 1)) / (points(i + 2) - points(i)) * (insPnt(0) - points(i)) + points(i + 1))) < 0.001 Then
                        blrObj.Rotation = blrObj.Rotation + Atn((points(i + 3) - points(i + 1)) / (points(i + 2) - points(i)))
                        Debug.Print i
                        Exit For
                      End If
              Next i
          End If
            insPnt = 0
            insPnt = ThisDrawing.Utility.GetPoint(, "Укажите точку вставки")
       Loop

            ThisDrawing.SetVariable "OSMODE", intOM

    Set ssObj = Nothing
End Sub