| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > VBA Как узнать предельные размеры контэйнера(прямоугольника) 3dSolid-а

VBA Как узнать предельные размеры контэйнера(прямоугольника) 3dSolid-а

Ответ
Поиск в этой теме
Непрочитано 26.02.2012, 18:25 #1
VBA Как узнать предельные размеры контэйнера(прямоугольника) 3dSolid-а
ferias
 
Регистрация: 26.02.2012
Сообщений: 10

Всем привет! Вопрос по программированию в VBA
есть 3DSolid (скажем мебельная плита определённой длины, ширины и толщины. Срезанная под любым углом с торца, просверленные отверстия, и т.д. и т.п.) который к World UCS лежит под произвольным углом. Хотелось бы узнать «контейнер» 3DSolid, только по отношению самой большой плоскости 3DSolid-а, а не по отношению к WorldUCS.

Решение вижу следующее:
- создаю новый слой
- копирую 3DSolid в новый слой, делая новый слой активным
- разбиваю 3DSolid на Region-и
- нахожу самый большой Region по площади в активном слое
- разбиваю этот Region на линии
- нахожу две самые длинные линии в активном слое
- привязываю UCS к этим линиям
- и поворачиваю 3DSolid с линиями так чтобы линии легли в плоскость X,Y World UCS
- используя функцию .GetBoundingBox узнаю размеры

Первая проблема:
- поскольку ThisDrawing.ModelSpace.Item(....) не поддерживает команду Explode, пытаюсь реализовать средствами ThisDrawing.SendCommand “_explode” & vbCr

Вопрос: как передать ThisDrawing.ModelSpace.Item(....) в ThisDrawing.SendCommand “_explode” & vbCr
Использование мыши исключить.

...Эотот вопрос я писал на другом форуме
http://forum.ru-board.com/topic.cgi?...=7170&start=20
Просмотров: 5195
 
Непрочитано 27.02.2012, 19:52
#2
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 813


Можно записать данные в *.SAT файл:
Код:
[Выделить все]
Public Sub testexport()
'Richard Binning
''http://forums.augi.com/showpost.php?p=39739&postcount=4
   Dim oSset As AcadSelectionSet
   Set oSset = ThisDrawing.PickfirstSelectionSet
   oSset.Clear
   oSset.SelectOnScreen
   Dim strPath As String
   strPath = ThisDrawing.GetVariable("dwgprefix")
   ThisDrawing.Export strPath & "SolidData", "SAT", oSset

End Sub
Потом попробуй его распарсить
Может это еще в тему, помотри алгоритм из проекта SolidLength.zip здесь:
http://www.cadtutor.net/forum/showth...and-ASCI-files

~'o'~
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 28.02.2012, 01:17
#3
ferias


 
Регистрация: 26.02.2012
Сообщений: 10


Спасибо. К сожалению, мой английский ограничивается любительским знанием VBA, думаю, что не стоит регестрироватся на форуме CadTutor, только для скачивания одного файла. Может у вас есть возможность выложить этот файл на этом форуме?
В любом случаи, попробую копать в сторону ".sat" формата.
ferias вне форума  
 
Непрочитано 28.02.2012, 01:49
#4
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 813


Меня точно убьют за то что таскаю оттуда
Задно пища для ума:
http://local.wasp.uwa.edu.au/~pbourk...ts/sat/sat.pdf


~'o'~
Вложения
Тип файла: zip 777.zip (27.5 Кб, 57 просмотров)
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 28.02.2012, 02:04
#5
ferias


 
Регистрация: 26.02.2012
Сообщений: 10


Огромное спасибо. Если код будет продвигатся, обязательно выложу.
ferias вне форума  
 
Автор темы   Непрочитано 02.03.2012, 03:54
#6
ferias


 
Регистрация: 26.02.2012
Сообщений: 10


Пытаюсь разобратся с форматом ".sat". К сожалению не могу разобратся с терменологией(английского незнаю, поэтому, создаю файлы с небольшим отличием в объектах и анализирую). Возможно у кого-то есть хоть какая-то литература на русском языке?

И опять таки, возвращаясь к уже заданому вопросу, неужели невозможно програмно(без использованя мыши), просто "взорвать" "3dsolid" !?
ferias вне форума  
 
Автор темы   Непрочитано 04.03.2012, 21:10
#7
ferias


 
Регистрация: 26.02.2012
Сообщений: 10


Ну вот, как говорится первый шаг

Код:
[Выделить все]
Sub explode_solid()
    Dim gr As AcadGroup
    Dim todos(0 To 0) As AcadEntity
    
    Set gr = ThisDrawing.Groups.Add("EXPLODESOLID")
    Set todos(0) = ThisDrawing.ModelSpace.Item(0)
    gr.AppendItems todos
    ThisDrawing.SendCommand "_EXPLODE" & vbCr & "g" & vbCr & gr.Name & vbCr & vbCr
    gr.Delete
End Sub
ferias вне форума  
 
Непрочитано 04.03.2012, 22:56
#8
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 813


К сожалению для моего слабого мозжечка это путь в никуда
Вижу только следующую возможную потугу:
Сохранить Handle солида в глобальной переменной
Открыть файл с использованием ObjectDbx методов,
взорвать солдид, взять все хэндлы полученных объектов и закрыть файл
Только не забудь что при этом ты потеряешь свойство
DwgPreview image для этого файла

PS
Мой тебе совет: завязывай с VBA
Быстрей переходи на Autolisp, VB.NET или C#

~'o'~
Олег (jr.) вне форума  
 
Непрочитано 05.03.2012, 00:51
#9
Александр Ривилис

программист, рыцарь ObjectARX
 
Регистрация: 09.05.2005
Киев
Сообщений: 2,405
Отправить сообщение для Александр Ривилис с помощью Skype™


Цитата:
Сообщение от Олег (jr.) Посмотреть сообщение
Только не забудь что при этом ты потеряешь свойство
DwgPreview image для этого файла
Чего вдруг? Он же чертеж сохранять не будет - не зачем.
Александр Ривилис вне форума  
 
Автор темы   Непрочитано 05.03.2012, 00:51
#10
ferias


 
Регистрация: 26.02.2012
Сообщений: 10


Понимаю что VBA угасает, но поскольку я не профисиональный програмист, а VBA дает возможность использовать Exel, Autocad и базу данных SQL, (и ещё, я VBA чуть-чуть знаю), то приоритетом стоит VBA перед Atolisp. Начал самостоятельное изучение C++, но поскольку нужно немало времени для его изучения, то наверное ещё не скоро получится создать хоть что-нибудь на C++ для AutoCad.
Так вот, мне кажется что я всётаки вижу "свет в конце тонеля", и быть может, хоть и через месяц, два, всё получится. Как говорится: - "было-бы желание".
- на данный момент разрабатываю возможность копирования объектов в новый документ что-бы не нарушить целестность оригинала.
- дальше, поэтапно, собираюсь действовать, согласну изначально задуманном плану, в любом случаи, искренне благодарен за помощь
ferias вне форума  
 
Непрочитано 05.03.2012, 15:33
#11
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 813


Цитата:
Сообщение от Александр Ривилис Посмотреть сообщение
Он же чертеж сохранять не будет
А это надо у автора спросить

~'o'~
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 06.03.2012, 00:31
#12
ferias


 
Регистрация: 26.02.2012
Сообщений: 10


В принципе, необходимости в этом нет, но если есть такая возможность, то можно воспользоваться, для просмотра(все ли в порядке).
ferias вне форума  
 
Непрочитано 13.03.2012, 19:33
#13
sasha_lif

Дизайнер-конструктор
 
Регистрация: 29.05.2004
Kiev
Сообщений: 1,187
<phrase 1=


А готовая программа не пригодится ?
Программа Деталировка
__________________
Kiev, Ukraine
sasha_lif вне форума  
 
Автор темы   Непрочитано 15.03.2012, 01:02
#14
ferias


 
Регистрация: 26.02.2012
Сообщений: 10


С файлом "testes"(смотреть вложение), демо-версия не работает? И поскольку makros приблежается к завершению, будет приятнее пользоватся частично своим творением.
Вложения
Тип файла: rar textes.rar (42.3 Кб, 46 просмотров)
ferias вне форума  
 
Автор темы   Непрочитано 19.03.2012, 01:52
#15
ferias


 
Регистрация: 26.02.2012
Сообщений: 10


На данный момент удалось повернуть выбранные объекты и выставить их в один ряд (makros aaaaaaaaaa). Продолжаю работать над определением габаритов. Возникла трудность в получении координат в нужном UCS (makros finalizar). Процедура "ThisDrawing.ModelSpace.Item(0).GetBoundingBox minExt, maxExt" точьки определяет правильно, но результаты выдает другие. Пытаюсь воспользоваться ".TranslateCoordinates" но немогу разобраться.
Прилагаю к коду два файла.
- "Eart_and_Water_Lda_Telhado_U" --> файл с которым тестировал код
- "Testes" --> файл с которым работаю, пытаясь получить габариты
Вложения
Тип файла: rar Exemplo.rar (378.5 Кб, 58 просмотров)
Тип файла: dvb Ver_medidas_solids.dvb (59.0 Кб, 37 просмотров)
ferias вне форума  
 
Автор темы   Непрочитано 21.03.2012, 18:41
1 | #16
ferias


 
Регистрация: 26.02.2012
Сообщений: 10


Оказывается, все работает нормально. Проблемой, если можно так считать, остаётся округление к максимальному числу после запятой в 15 символов.

Код:
[Выделить все]
Sub aaaaaaaaaa()
    Dim Msg As String, MyString As String
    Dim strPath As String
    Msg = "Эта процедура сохраняет активный документ, после ещё раз сохраняет его под новым именем," & vbCr
    Msg = Msg & "предлагает выбрать объекты для обработки и удаляет невыбранные объекты," & vbCr
    Msg = Msg & "следом обрабатывает оставшиеся объекты." & vbCr & vbCr
    Msg = Msg & "Вы действительно хотите продолжить?"
    Response = MsgBox(Msg, vbYesNo + vbCritical + vbDefaultButton2, "", "", 1000)
    If Response = vbYes Then
        ThisDrawing.Save
        strPath = ThisDrawing.GetVariable("dwgprefix")
        ThisDrawing.SaveAs (strPath & "Medidas_dos_objectos.dwg")
    Else
        Exit Sub
    End If
    Call z_Select_Objects
    Call z_trabalho
    Call finalizar
    ThisDrawing.Save
End Sub
Sub finalizar()
    Dim i As Long, ListagemObjectos() As String, j As Long, k As Long
    Dim minExt As Variant, maxExt As Variant
    
    j = ThisDrawing.ModelSpace.Count - 1
    ReDim ListagemObjectos(1 To 4, 0 To j)
    For i = 0 To j
        ThisDrawing.ModelSpace.Item(i).GetBoundingBox minExt, maxExt
        
        ListagemObjectos(1, i) = ThisDrawing.ModelSpace.Item(i).Layer
        ListagemObjectos(2, i) = Round(CDec(minExt(0) - maxExt(0)), 1)
        
        If ListagemObjectos(2, i) < 0 Then
            ListagemObjectos(2, i) = Mid(ListagemObjectos(2, i), 2, Len(ListagemObjectos(2, i)) - 1)
        Else
        End If
        
        ListagemObjectos(3, i) = Round(CDec(minExt(1) - maxExt(1)), 1)
        ListagemObjectos(4, i) = Round(CDec(minExt(2) - maxExt(2)), 1)
        For k = 2 To 4
            If ListagemObjectos(k, i) < 0 Then ListagemObjectos(k, i) = Mid(ListagemObjectos(k, i), 2, Len(ListagemObjectos(k, i)) - 1)
        Next k
    Next i
    Call vas_phc_clipboard_placas(ListagemObjectos())
End Sub
Private Sub vas_phc_clipboard_placas(ListagemObjectos() As String)
    Dim MyDataObj As New DataObject, para_colar As String
    
    para_colar = ""
    For i = 0 To UBound(ListagemObjectos, 2)
        For j = 1 To 3
            para_colar = para_colar & ListagemObjectos(j, i) & Chr(9)
        Next j
        If i = UBound(ListagemObjectos, 2) Then
            para_colar = para_colar & ListagemObjectos(4, i)
        Else
            para_colar = para_colar & ListagemObjectos(4, i) & Chr(13)
        End If
    Next i
    MyDataObj.Clear
    MyDataObj.SetText para_colar
    MyDataObj.PutInClipboard
    MsgBox para_colar
End Sub



'Следующими процедурами:
'- сохраняем активный документ
'- пересохраняем документ с новым именем
'- предлагаем пользователю выбрать объекты для дальнейшей обработки
'- из выбраных объектов, выбираем только 3dSolid-ы, из которых, создаём новый блок
'- удаляем все объекты в пространстве листа
'- вставляем созданный блок
'- разбиваем вставленный блок
'- удаляем дубликат
'- перебираем все объекты поочерёдно следующим образом
'- копируем объекты
'- разбиваем копии на регионы
'- ищем самый большой регион по площади
'- разбиваем его на линии
'- выбираем две самые длинные линии
'- на одной из линий на концах ставим точьки
'- на другой линии на одном конце ставим третью точьку
'- по этим точькам поворачиваем объекты, после перемещаем его


Private Sub z_Select_Objects()
    Dim SelSet As AcadSelectionSet, i As Long
    Dim unidade(0 To 0) As AcadEntity
    If ThisDrawing.SelectionSets.Count > 0 Then
        For i = 0 To ThisDrawing.SelectionSets.Count - 1
            If ThisDrawing.SelectionSets(i).Name = "Set_vas" Then
                ThisDrawing.SelectionSets(i).Delete
                Exit For
            Else
            End If
        Next i
    Else
    End If
    Set SelSet = ThisDrawing.SelectionSets.Add("Set_vas")
    SelSet.SelectOnScreen
    For i = SelSet.Count - 1 To 0 Step -1
        If SelSet.Item(i).ObjectName = "AcDb3dSolid" Then
        Else
            Set unidade(0) = SelSet.Item(i)
            SelSet.RemoveItems unidade
        End If
    Next i
    'MsgBox SelSet.Count
    
    Dim strBlkName As String
    Dim objNewBlock As AcadBlock
    
    strBlkName = "block_for_export"
    
    Call BlockNameIncrement(strBlkName)
    Set objNewBlock = BlockSelSet(SelSet, strBlkName)
    SelSet.Delete
    
    For i = ThisDrawing.ModelSpace.Count - 1 To 0 Step -1
        ThisDrawing.ModelSpace.Item(i).Delete
    Next i
    
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
    
    Dim blockRefObj As AcadBlockReference
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, "block_for_export", 1#, 1#, 1#, 0)
    blockRefObj.Explode
    blockRefObj.Delete
    objNewBlock.Delete
End Sub
Private Sub novo()
    Dim temp_doc As AcadDocument
    Set temp_doc = AutoCAD.Documents.Add("aa_vas.dwt")
End Sub
Private Sub BlockNameIncrement(strName As String)
  Dim objBlocks As AcadBlocks
  Dim objBlock As AcadBlock
  Dim strValue As String
  Dim intCnt As Integer
  Dim blnFound As Boolean
  
  Set objBlocks = ThisDrawing.Blocks
  strValue = strName
  Do
    For Each objBlock In objBlocks
      If objBlock.Name = strValue Then
        blnFound = True
        intCnt = intCnt + 1
        strValue = strName & intCnt
        Exit For
      Else
        blnFound = False
      End If
    Next objBlock
  Loop Until Not blnFound
  strName = strValue
End Sub

Public Function BlockSelSet(objSelSet As AcadSelectionSet, strName As String) As AcadBlock
  Dim objBlks As AcadBlocks
  Dim objTemp As AcadBlock
  Dim objArray() As AcadEntity
  Dim intCnt As Integer
  
  Dim point(0 To 2) As Double
  point(0) = 0#: point(1) = 0#: point(2) = 0#
  
  Set objBlks = ThisDrawing.Blocks
  For intCnt = 0 To objSelSet.Count - 1
    ReDim Preserve objArray(intCnt)
    Set objArray(intCnt) = objSelSet(intCnt)
  Next intCnt
  Set objTemp = objBlks.Add(point, strName)
  ThisDrawing.CopyObjects objArray, objTemp
  Set BlockSelSet = objTemp
  Set objBlks = Nothing
  Set objTemp = Nothing
End Function
'----------------------------
'----------------------------
'----------------------------
'----------------------------
'----------------------------
'----------------------------
'----------------------------
Private Sub z_trabalho()
    Dim solidObj As Acad3DSolid, origem As Acad3DSolid
    Dim lista() As String
    Dim i As Long, j As Long, activo As Long, r As Long
    Dim layerObj As AcadLayer
    Dim point_1 As Variant, point_2 As Variant, point_3 As Variant
    Dim Line_1 As AcadLine, Line_2 As AcadLine
    Dim startPoint() As Double
    Dim endPoint_1() As Double
    Dim endPoint_2() As Double
    Dim pp_1 As AcadPoint, pp_2 As AcadPoint, pp_3 As AcadPoint, pp_temp As AcadPoint
    Dim SelSet As AcadSelectionSet
    Dim distBetween As Long
    Dim pt_1 As Variant, pt_2 As Variant, pt_3 As Variant
    
    distBetween = 0
    
    If ThisDrawing.SelectionSets.Count > 0 Then
        For i = 0 To ThisDrawing.SelectionSets.Count - 1
            If ThisDrawing.SelectionSets(i).Name = "Set_vas" Then
                ThisDrawing.SelectionSets(i).Delete
                Exit For
            Else
            End If
        Next i
    Else
    End If
    Set SelSet = ThisDrawing.SelectionSets.Add("Set_vas")
    SelSet.Clear
    
    Call ObjectsForWork(lista())
    Call LayerExist(layerObj)
    ThisDrawing.ActiveLayer = layerObj
    
    For i = 0 To UBound(lista)
        For j = 0 To ThisDrawing.ModelSpace.Count
            If ThisDrawing.ModelSpace.Item(j).Handle = lista(i) Then
                activo = j
                Exit For
            Else
            End If
        Next j
        
        Set origem = ThisDrawing.ModelSpace.Item(activo)
        Set solidObj = ThisDrawing.ModelSpace.Item(activo).Copy
        solidObj.Layer = layerObj.Name
        Call ExplodeObject(solidObj)
        Call escolha(point_1, point_2, point_3)
        
        Call creatPoint(point_1, pp_1)
        Call creatPoint(point_2, pp_2)
        Call creatPoint(point_3, pp_3)
        
        pt_1 = pp_1.Coordinates
        pt_2 = pp_2.Coordinates
        
        If CDec(pt_1(0)) = CDec(pt_2(0)) And CDec(pt_1(1)) = CDec(pt_2(1)) Then Call RotateObject(pp_1, pp_2, pp_3, origem, 5)
        
        Call RotateObject(pp_1, pp_2, pp_3, origem, 2)
        Call RotateObject(pp_1, pp_2, pp_3, origem, 0)
        Call RotateObject(pp_1, pp_2, pp_3, origem, 2)
        Call RotateObject(pp_1, pp_2, pp_3, origem, 1)
        
        Set pp_temp = pp_2
        Set pp_2 = pp_3
        Set pp_3 = pp_temp
        
        Call RotateObject(pp_1, pp_2, pp_3, origem, 2)
        Call RotateObject(pp_1, pp_2, pp_3, origem, 1)
        
        Call RotateObject(pp_1, pp_2, pp_3, origem, 6)
        Call MoveObject(origem, pp_1, distBetween)
        
        pp_1.Delete
        pp_2.Delete
        pp_3.Delete
        '........................
    Next i
    ZoomAll
    ThisDrawing.Regen (True)
    
End Sub
Private Sub MoveObject(origem As Acad3DSolid, pp_1 As AcadPoint, distBetween As Long)
    Dim temp(0 To 2) As Double
    Dim pt_1 As Variant
    
    temp(0) = 0: temp(1) = distBetween: temp(2) = 0
    distBetween = distBetween + 50 ' 50 это расстояние между центрами объектов, изменить при необходимости
    pt_1 = pp_1.Coordinates
    origem.Move pt_1, temp
    
End Sub
Private Sub RotateObject(pp_1 As AcadPoint, pp_2 As AcadPoint, pp_3 As AcadPoint, origem As Acad3DSolid, x As Byte)
    Dim pt_1 As Variant, pt_2 As Variant, pt_4 As Variant
    Dim rotateAngle As Double
    Dim Line_1 As AcadLine
    
    pt_1 = pp_1.Coordinates
    pt_4 = pp_1.Coordinates
    
    If x = 5 Or x = 6 Then
        If x = 5 Then
            pt_4(1) = CDec(pt_4(1) + 100)
        Else
            pt_4(0) = CDec(pt_4(0) + 100)
        End If
        rotateAngle = 2 * Atn(1)
    Else
        pt_2 = pp_2.Coordinates
        pt_2(2) = pt_1(2)
        Set Line_1 = ThisDrawing.ModelSpace.AddLine(pt_1, pt_2)
        Line_1.Layer = "Temporario"
        pt_4(x) = CDec(pt_4(x) + Line_1.Length)
        If x = 2 Then
            rotateAngle = Line_1.Angle
        Else
            rotateAngle = 2 * Atn(1)
        End If
        Line_1.Delete
    End If
    
    rotateAngle = CDec("-" & rotateAngle)
    
    If rotateAngle = 0 Then Exit Sub
    
    origem.Rotate3D pt_1, pt_4, rotateAngle
    pp_1.Rotate3D pt_1, pt_4, rotateAngle
    pp_2.Rotate3D pt_1, pt_4, rotateAngle
    pp_3.Rotate3D pt_1, pt_4, rotateAngle
End Sub
Private Sub getCoordinatesPoints(startPoint() As Double, endPoint_1() As Double, endPoint_2() As Double, pp_1 As AcadPoint, pp_2 As AcadPoint, pp_3 As AcadPoint)
    ReDim startPoint(0 To 2)
    ReDim endPoint_1(0 To 2)
    ReDim endPoint_2(0 To 2)
    startPoint = pp_1.Coordinates
    endPoint_1 = pp_2.Coordinates
    endPoint_2 = pp_3.Coordinates
End Sub
Private Sub ExplodeObject(solidObj As Acad3DSolid)
    Dim gr As AcadGroup
    Dim todos(0 To 0) As AcadEntity
    If ThisDrawing.Groups.Count > 0 Then ThisDrawing.Groups.Delete
    Set gr = ThisDrawing.Groups.Add("EXPLODESOLID")
    Set todos(0) = solidObj
    gr.AppendItems todos
    ThisDrawing.SendCommand "_EXPLODE" & vbCr & "g" & vbCr & gr.Name & vbCr & vbCr
    gr.Delete
End Sub
Private Sub LayerExist(layerObj As AcadLayer)
    Dim bool As Boolean
    bool = True
    For i = 0 To ThisDrawing.Layers.Count - 1
        If ThisDrawing.Layers(i).Name = "Temporario" Then
            bool = False
            Set layerObj = ThisDrawing.Layers(i)
        Else
        End If
    Next i
    If bool Then Set layerObj = ThisDrawing.Layers.Add("Temporario")
End Sub
Private Sub ObjectsForWork(lista() As String)
    Dim i As Long
    ReDim lista(0 To ThisDrawing.ModelSpace.Count - 1)
    Dim ListAndVolume() As String
    ReDim ListAndVolume(1 To 2, 0 To ThisDrawing.ModelSpace.Count - 1)
    
    For i = 0 To ThisDrawing.ModelSpace.Count - 1
        ListAndVolume(2, i) = ThisDrawing.ModelSpace.Item(i).Volume
        ListAndVolume(1, i) = ThisDrawing.ModelSpace.Item(i).Handle
    Next i
    
    Call BubbleSort(ListAndVolume)
    
    For i = 0 To ThisDrawing.ModelSpace.Count - 1
        lista(i) = ListAndVolume(1, i)
    Next i
End Sub
Private Sub escolha(point_1 As Variant, point_2 As Variant, point_3 As Variant)
    Dim j As Long, regions() As String, i As Long, ind As Boolean
    ReDim regions(1 To 2, 0 To 0) As String
    Dim k As AcadRegion
    
    For j = 0 To ThisDrawing.ModelSpace.Count - 1
        If ThisDrawing.ModelSpace.Item(j).ObjectName = "AcDbRegion" Then
            If UBound(regions, 2) = 0 Then
                If regions(2, 0) = "" Then
                    
                    regions(2, 0) = ThisDrawing.ModelSpace.Item(j).Area
                    regions(1, 0) = ThisDrawing.ModelSpace.Item(j).Handle
                Else
                    ReDim Preserve regions(1 To 2, 0 To UBound(regions, 2) + 1)
                    i = UBound(regions, 2)
                    regions(2, i) = ThisDrawing.ModelSpace.Item(j).Area
                    regions(1, i) = ThisDrawing.ModelSpace.Item(j).Handle
                End If
            Else
                ReDim Preserve regions(1 To 2, 0 To UBound(regions, 2) + 1)
                i = UBound(regions, 2)
                regions(2, i) = ThisDrawing.ModelSpace.Item(j).Area
                regions(1, i) = ThisDrawing.ModelSpace.Item(j).Handle
            End If
        Else
        End If
    Next j
    
    If UBound(regions, 2) = 0 Then If regions(2, 0) = "" Then Stop 'MsgBox "Регионов нет!"
    Call BubbleSort(regions)
    
    ind = False
    For i = 0 To UBound(regions, 2)
        For j = 0 To ThisDrawing.ModelSpace.Count - 1
            If regions(1, i) = ThisDrawing.ModelSpace.Item(j).Handle Then
                Set k = ThisDrawing.ModelSpace.Item(j)
                Call explode_region(ind, k, point_1, point_2, point_3)
                If ind Then Exit For
            Else
            End If
        Next j
        If ind Then Exit For
    Next i
    'Call deleteObjectsInLayer
End Sub
Private Sub BubbleSort(List() As String)
    Dim First As Long, Last As Long, j As Long, i As Long, temp_1 As String, temp_2 As String
    First = LBound(List, 2): Last = UBound(List, 2)
    For i = First To Last - 1
        For j = i + 1 To Last
            If CDec(List(2, i)) < CDec(List(2, j)) Then
                temp_1 = List(2, j)
                temp_2 = List(1, j)
                List(2, j) = List(2, i)
                List(1, j) = List(1, i)
                List(2, i) = temp_1
                List(1, i) = temp_2
            Else
            End If
        Next j
    Next i
End Sub
Private Sub explode_region(ind As Boolean, k As AcadRegion, point_1 As Variant, point_2 As Variant, point_3 As Variant)
    Dim explodedObjects As Variant, i As Long, j As Long, col() As String
    Dim L As AcadLine
    ReDim col(1 To 2, 0 To 0)
    
    explodedObjects = k.Explode
    For i = 0 To UBound(explodedObjects)
        If explodedObjects(i).ObjectName = "AcDbLine" Then
            If col(2, 0) = "" Then
                col(2, 0) = explodedObjects(i).Length
                col(1, 0) = i
            Else
                ReDim Preserve col(1 To 2, 0 To UBound(col, 2) + 1)
                j = UBound(col, 2)
                col(2, j) = explodedObjects(i).Length
                col(1, j) = i
            End If
        Else
        End If
    Next
    Call BubbleSort(col)
    If UBound(col, 2) > 0 Then
        point_1 = explodedObjects(CDec(col(1, 0))).startPoint
        point_2 = explodedObjects(CDec(col(1, 0))).EndPoint
        point_3 = explodedObjects(CDec(col(1, 1))).EndPoint
        ind = True
        Call deleteObjectsInLayer
    Else
    End If
End Sub
Private Sub deleteObjectsInLayer()
    Dim j As Long
    For j = ThisDrawing.ModelSpace.Count - 1 To 0 Step -1
        If ThisDrawing.ModelSpace.Item(j).Layer = ThisDrawing.ActiveLayer.Name Then
            ThisDrawing.ModelSpace.Item(j).Delete
        Else
        End If
    Next j
End Sub
Private Sub creatPoint(p As Variant, pp As AcadPoint)
    Dim point As AcadPoint
    Set point = ThisDrawing.ModelSpace.AddPoint(p)
    point.Layer = "0"
    Set pp = point
End Sub
'----------------------------
'----------------------------
ferias вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > VBA Как узнать предельные размеры контэйнера(прямоугольника) 3dSolid-а

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
VBA Как узнать, какие версии автокада установлены _mikka Программирование 4 01.02.2012 21:02
Как программно на VBA узнать текст последней команды autocada maximiliam Программирование 5 14.01.2010 11:15
VBA - как узнать закрытый ли контур To Thuc Программирование 4 18.06.2007 16:55
как узнать сколько layout в файле текущем DWG файле VBA sf Программирование 1 09.03.2005 12:36