Изменение базовых точек 3D блоков в координату 0,0,0. С последующим их экспортом в разные файлы

slav008 · 21.12.2022, 23:41

Привет всем!!! Как можно поменять базовые точки всех существующих 3D блоков в чертеже в координату 0,0,0. Каждый блок с уникальным именем, статический, без атрибутов. Это необходимо для их экспорта в разные файлы. Каждый блок в свой файл.

----- добавлено через ~1 ч. -----
Понравилась программа ЛиМака http://www.lee-mac.com/changeblockinsertion.html, но поскольку знания Лиспа нулевые отредактировать ее для своей задачи не получается, а именно превратить программу в которой нужно "проклацать" каждый блок по отдельности и задать координату т.вставки 0,0,0 в программу в которой выберешь блоки (а их может быть более 1000) и т.вставки блоков станет 0,0,0

Dinoxromniy · 22.12.2022, 08:50

Попробуйте код ниже.

Цитата:

Сообщение от slav008

всех существующих 3D блоков в чертеже в координату 0,0,0

Всех вставленных в чертеже, я полагаю.

Цитата:

Сообщение от slav008

Каждый блок с уникальным именем, статический, без атрибутов.

Соответственно, если есть такая уверенность - код подразумевает, что так оно и есть. Кроме того - у вас нет залоченных и замороженных слоев.

Код:

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

Sub bl_mov()

    Dim mySset As AcadSelectionSet, objblockRef As AcadBlockReference, vrtPoint As Variant
    Dim objEntity As AcadEntity
    Dim point1(0 To 2) As Double
    point1(0) = 0: point1(1) = 0: point1(2) = 0
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    
    For i = ThisDrawing.SelectionSets.Count - 1 To 0 Step -1
        If ThisDrawing.SelectionSets.Item(i).Name = "q1" Then ThisDrawing.SelectionSets.Item(i).Delete
    Next i

    ThisDrawing.SelectionSets.Add ("q1")
    Set mySset = ThisDrawing.SelectionSets.Item("q1")
    FilterType(0) = 0
    FilterData(0) = "INSERT"
    mySset.SelectOnScreen FilterType, FilterData

     
    
     For Each objblockRef In mySset
            For Each objEntity In ThisDrawing.Blocks.Item(objblockRef.Name)
                    objEntity.Move point1, objblockRef.insertionPoint
            Next objEntity
        objblockRef.Move objblockRef.insertionPoint, point1
        
     Next objblockRef
     
     Set mySset = Nothing
End Sub

Кулик Алексей aka kpblc · 22.12.2022, 09:16

Dinoxromniy, ты уверен, что твой код делает именно то, что просит ТС?
По основному вопросу : штатных средств я не знаю.

Dinoxromniy · 22.12.2022, 09:23

Цитата:

Сообщение от Кулик Алексей aka kpblc

Dinoxromniy, ты уверен, что твой код делает именно то, что просит ТС?

Да по большому счету моя уверенность-то ни на что не влияет - не то имеет ввиду, пояснит я думаю.

Кулик Алексей aka kpblc · 22.12.2022, 09:28

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

Dinoxromniy · 22.12.2022, 09:42

Цитата:

Сообщение от Кулик Алексей aka kpblc

Если я правильно понимаю, у тебя просто сдвигается вхождение блока.

Не совсем - сначала в определении блока сдвигаем все примитивы на радиус вектор (который от нуля до точки вставки вхождения). Потом - да, двигаем вхождение на ту же величину с обратным знаком, чтобы вхождение заняло свое начальное положение, а точка вставки сдвинулась в ноль. Результат - точка вставки в нуле, примитивы вхождения находятся на своем изначальном месте.

Кулик Алексей aka kpblc · 22.12.2022, 09:46

Цитата:

Сообщение от Dinoxromniy

Попробуйте код ниже.

Всех вставленных в чертеже, я полагаю.

Соответственно, если есть такая уверенность - код подразумевает, что так оно и есть. Кроме того - у вас нет залоченных и замороженных слоев.

Код:

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

Sub bl_mov()

    Dim mySset As AcadSelectionSet, objblockRef As AcadBlockReference, vrtPoint As Variant
    Dim objEntity As AcadEntity
    Dim point1(0 To 2) As Double
    point1(0) = 0: point1(1) = 0: point1(2) = 0
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    
    For i = ThisDrawing.SelectionSets.Count - 1 To 0 Step -1
        If ThisDrawing.SelectionSets.Item(i).Name = "q1" Then ThisDrawing.SelectionSets.Item(i).Delete
    Next i

    ThisDrawing.SelectionSets.Add ("q1")
    Set mySset = ThisDrawing.SelectionSets.Item("q1")
    FilterType(0) = 0
    FilterData(0) = "INSERT"
    mySset.SelectOnScreen FilterType, FilterData

     
    
     For Each objblockRef In mySset
            For Each objEntity In ThisDrawing.Blocks.Item(objblockRef.Name)
                    objEntity.Move point1, objblockRef.insertionPoint
            Next objEntity
        objblockRef.Move objblockRef.insertionPoint, point1
        
     Next objblockRef
     
     Set mySset = Nothing
End Sub

В твоем коде показано только перемещение вхождения, насколько я вижу

Dinoxromniy · 22.12.2022, 09:49

Цитата:

Сообщение от Кулик Алексей aka kpblc

For Each objEntity In ThisDrawing.Blocks.Item(objblockRef.Name)
objEntity.Move point1, objblockRef.insertionPoint
Next objEntity

Это перемещения всех примитивов внутри определения

Цитата:

Сообщение от Кулик Алексей aka kpblc

objblockRef.Move objblockRef.insertionPoint, point1

Это перемещения вхождения, при этом направление перемещения противоположное - в первом случае из point1 (это точка 0,0,0) в точку вставки текущего вхождения, во втором случае - наоборот.

В коде два разных .move есть.

Кулик Алексей aka kpblc · 22.12.2022, 10:11

А, да, сорян.

slav008 · 22.12.2022, 11:21

Благодарю Вас, Dinoxromniy, Кулик Алексей aka kpblc за помощь. В ходе тестирования данной программы, часть блоков действительно осталась на своих местах, а часть разлетелась, Вероятно те блоки у которых выставлен поворот отличный от 0. Подскажите пожалуйста как можно учесть фактор поворота блока?

тестировал на данном файле:
3D_JunctionBoxes.dwg

Dinoxromniy · 22.12.2022, 11:31

Цитата:

Сообщение от slav008

Подскажите пожалуйста как можно учесть фактор поворота блока?

Ну тут вопрос - какой конечный результат требуется получить: вот текущее положение блока должно стать исходным, т.е. поворот должен стать равным 0, а точка вставки вхождения - 0,0,0 , при этом блок должен визуально выглядеть как до обработки кодом - верно?

----- добавлено через ~17 мин. -----
slav008, попробуйте так:

Код:

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

Sub bl_rot_mov()

    Dim mySset As AcadSelectionSet, objblockRef As AcadBlockReference, vrtPoint As Variant
    Dim objEntity As AcadEntity
    Dim point1(0 To 2) As Double
    point1(0) = 0: point1(1) = 0: point1(2) = 0
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    
    For i = ThisDrawing.SelectionSets.Count - 1 To 0 Step -1
        If ThisDrawing.SelectionSets.Item(i).Name = "q1" Then ThisDrawing.SelectionSets.Item(i).Delete
    Next i

    ThisDrawing.SelectionSets.Add ("q1")
    Set mySset = ThisDrawing.SelectionSets.Item("q1")
    FilterType(0) = 0
    FilterData(0) = "INSERT"
    mySset.SelectOnScreen FilterType, FilterData

     
    
     For Each objblockRef In mySset
        If objblockRef.Rotation <> 0 Then
            For Each objEntity In ThisDrawing.Blocks.Item(objblockRef.Name)
                    objEntity.Rotate point1, objblockRef.Rotation
            Next objEntity
            objblockRef.Rotate objblockRef.InsertionPoint, -objblockRef.Rotation
        End If
            For Each objEntity In ThisDrawing.Blocks.Item(objblockRef.Name)
                    objEntity.Move point1, objblockRef.InsertionPoint
            Next objEntity
        objblockRef.Move objblockRef.InsertionPoint, point1
        
     Next objblockRef
     
     Set mySset = Nothing
End Sub

slav008 · 22.12.2022, 11:35

Цитата:

Сообщение от Dinoxromniy

Ну тут вопрос - какой конечный результат требуется получить: вот текущее положение блока должно стать исходным, т.е. поворот должен стать равным 0, а точка вставки вхождения - 0,0,0 , при этом блок должен визуально выглядеть как до обработки кодом - верно?

Блоки должны остаться на своих местах, поворот блоков как был до обработки кодом и визуально выглядеть как до обработки кодом

slav008 · 22.12.2022, 16:28

Цитата:

Сообщение от Dinoxromniy

Ну тут вопрос - какой конечный результат требуется получить: вот текущее положение блока должно стать исходным, т.е. поворот должен стать равным 0, а точка вставки вхождения - 0,0,0 , при этом блок должен визуально выглядеть как до обработки кодом - верно?

----- добавлено через ~17 мин. -----
slav008, попробуйте так:

Признателен Вам, Dinoxromniy за решение данной задачи. В Прикрепленном файле остаются все же блоки которые "Улетают" со своих координат. Это блоки с вложенным блоком с 1 или с n-степенями вложенности (блок в блоке). Попытка взорвать вложенные блоки и выполнить код над этим "улетающим" блоком но уже с примитивами не привели к положительному результату.

Прошу Вас посмотреть вложение:
V8335-3D_JunctionBoxes (2).dwg

Можно ли не применяя манипуляции _explode к вложениям блоков решить задачу?

Dinoxromniy · 24.12.2022, 17:38

Цитата:

Сообщение от slav008

Это блоки с вложенным блоком с 1 или с n-степенями вложенности (блок в блоке).

Да. Тут еще беда, что блоки как я понимаю вставлены в разных плоскостях (несилен в 3д), поэтому и двигать / устранять поворот нужно в этих же системах координат.
Соответственно, попробуйте алгоритм ниже, вроде похоже на правду - он перепишет блоки в текущей системе координат. Насколько я вижу, у вас в файле некоторые боксы пересекаются, это так и должно быть?

Код:

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

Sub bl_rot_mov_exp_w()

    Dim mySset As AcadSelectionSet, objblockRef As AcadBlockReference, newBlockRef As AcadBlockReference, vrtPoint As Variant, strName As String
    Dim objEntity As AcadEntity, objBlock As AcadBlock, newBlock As AcadBlock, f As Boolean
    Dim point1(0 To 2) As Double
    point1(0) = 0: point1(1) = 0: point1(2) = 0
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant, I As Integer
    Dim explodedObjects As Variant


    
    
    For I = ThisDrawing.SelectionSets.Count - 1 To 0 Step -1
        If ThisDrawing.SelectionSets.Item(I).Name = "q1" Then ThisDrawing.SelectionSets.Item(I).Delete
    Next I

    ThisDrawing.SelectionSets.Add ("q1")
    Set mySset = ThisDrawing.SelectionSets.Item("q1")
    FilterType(0) = 0
    FilterData(0) = "INSERT"
    mySset.Select acSelectionSetAll, , , FilterType, FilterData
    

        For Each objblockRef In mySset
        If Not ThisDrawing.Blocks.Item(objblockRef.Name).IsXRef Then
        
           Set newBlock = ThisDrawing.Blocks.Add(point1, objblockRef.Name & "_new")
           
          
           
           
           Set newBlockRef = ThisDrawing.ModelSpace.InsertBlock(point1, newBlock.Name, 1, 1, 1, 0)
           newBlockRef.Layer = objblockRef.Layer
           newBlockRef.XScaleFactor = objblockRef.XScaleFactor
           newBlockRef.YScaleFactor = objblockRef.YScaleFactor
           newBlockRef.ZScaleFactor = objblockRef.ZScaleFactor
           newBlockRef.TrueColor = objblockRef.TrueColor
           explodedObjects = objblockRef.Explode
           objblockRef.Delete
            ThisDrawing.CopyObjects explodedObjects, newBlock
             For I = UBound(explodedObjects) To LBound(explodedObjects) Step -1
                explodedObjects(I).Delete
             Next I

           
           
           
         End If
        Next objblockRef
  mySset.Clear
  mySset.Select acSelectionSetAll, , , FilterType, FilterData
 For Each objblockRef In mySset
 If Not ThisDrawing.Blocks.Item(objblockRef.Name).IsXRef Then
       Set objBlock = ThisDrawing.Blocks.Item(objblockRef.Name)
            Do
                    f = False
                        For Each objEntity In objBlock
                                If objEntity.ObjectName = "AcDbBlockReference" Then
                                    objEntity.Explode
                                    objEntity.Delete
                                    f = True
                                    Exit For
                                End If
                        Next objEntity
            Loop While f
       
            
        End If
      
Next objblockRef

For Each objblockRef In mySset
If Not ThisDrawing.Blocks.Item(objblockRef.Name).IsXRef Then
ThisDrawing.Blocks.Item(Left(objblockRef.Name, Len(objblockRef.Name) - 4)).Delete
    ThisDrawing.Blocks.Item(objblockRef.Name).Name = Left(objblockRef.Name, Len(objblockRef.Name) - 4)
    End If
Next objblockRef

     
     Set mySset = Nothing
     Set objBlock = Nothing
     Set newBlock = Nothing
     Set newBlockRef = Nothing
End Sub

Добавлено:
Кстати, блоки у вас вроде бы все же повторяются, есть две пары одинаковых.

21.12.2022, 23:41		#1
Изменение базовых точек 3D блоков в координату 0,0,0. С последующим их экспортом в разные файлы slav008 Регистрация: 11.06.2020 Сообщений: 7 Привет всем!!! Как можно поменять базовые точки всех существующих 3D блоков в чертеже в координату 0,0,0. Каждый блок с уникальным именем, статический, без атрибутов. Это необходимо для их экспорта в разные файлы. Каждый блок в свой файл. ----- добавлено через ~1 ч. ----- Понравилась программа ЛиМака http://www.lee-mac.com/changeblockinsertion.html, но поскольку знания Лиспа нулевые отредактировать ее для своей задачи не получается, а именно превратить программу в которой нужно "проклацать" каждый блок по отдельности и задать координату т.вставки 0,0,0 в программу в которой выберешь блоки (а их может быть более 1000) и т.вставки блоков станет 0,0,0
Просмотров: 1296

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Какой язык перспективен для инженера-конструктора с условием	The_Mercy_Seat	Программирование	705	17.03.2021 14:19
Изменение атрибутов блоков находящихся на одном слое на одном слое	AlexKey	AutoCAD	13	24.08.2013 09:03
Поворот блоков в 3D (multirotate)	ASLYS	Программирование	12	06.07.2007 16:44
имена точек при работе в 3D	Романчо	AutoCAD	1	20.06.2006 17:05
В 3d orbit элементы модели разъезжаются в разные стороны	kolbasa	AutoCAD	5	04.12.2003 19:17