[Бродяга]

Доброго времени суток!
Опять я и опять с вопросом чайника.
На форумах не нашел, м.б. не увидел.
Подскажите кто может, как на из VBA выбратьвсе объекты в заданной области (известны координаты ее углов). Желательно усложнить выбор для отбора только тех объектов которые замкнуты). Очень нужно для формирования списка объектов innerloop при заполнении области штриховкой.
Очень срочно, как всегда с уважением готов прочитать любые варианты :shock:

[den001]

Код:

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

Public Sub ClearSelectionSets()
  For i = 1 To ThisDrawing.SelectionSets.Count
    ThisDrawing.SelectionSets.Item(0).Clear
    ThisDrawing.SelectionSets.Item(0).Delete
  Next
End Sub

Sub asdf()
  Dim Sset As AcadSelectionSet, Entry As AcadEntity
  ClearSelectionSets
  Set Sset = ThisDrawing.SelectionSets.Add("NameSset")
  '...
  Sset.Select acSelectionSetCrossing, Point1, Point2 ' Секущей рамкой
  'или 
  Sset.Select acSelectionSetWindow, Point1, Point2 ' Обычной рамкой
  
  For Each Entry In Sset
    'и так далее
  Next
  Sset.Delete
End Sub

Что касаемо выбора определенных объектов и т.п. - нужно создавать фильтр, но выбирать можно только однотипные объекты (напр., полилинии), несколько видов объектов невозможно (кажись). Зато туда можно запихать слой, цвет и т.д.

[Бродяга]

Большое спасибо, дальше попробую разобраться сам

[Бродяга]

Опять затык вышел
Може кто подскажет - как проверить объекты на замыкание (напр. полилинию, пересечение линии, дуги и т.д.). Весь внимание :shock:

[Бродяга]

Совсем запутался, может кто поможет.
Вроде все проходит но на выходе когда запускаю в процедуре

Set outerLoop(0) = objspase.AddPolyline(point_kk)
objhatch.AppendOuterLoop (outerLoop)
If vir = False Then
objhatch.AppendInnerLoop (innerLoop)
End If

на команде objhatch.AppendInnerLoop (innerLoop) выдает сообщение: "метод 'FppendInnerloop' of object 'acadHatch2' filed".
ладноб ругался на пустой innerLoop, так при полном - та же картинка. :roll:
Вроде все проверил, объекты есть (в основном полилинии, но все же замкнутые. Очень срочно, в прочем как всегда

Процедура для выбора объектов в квадратной области. по двум точкам.
Private Function asdf(t1x As Variant, t1y As Variant, t1z As Variant, t2x As Variant, t2y As Variant, t2z As Variant) As Boolean
Dim Sset As AcadSelectionSet, Entry As AcadEntity
Dim intcnt As Integer
Dim varMax(0 To 2) As Double
Dim varMin(0 To 2) As Double
varMax(0) = t1x: varMax(1) = t1y: varMax(2) = t1z
varMin(0) = t2x: varMin(1) = t2y: varMin(2) = t2z
ClearSelectionSets
Set Sset = ACADApp.ActiveDocument.SelectionSets.Add("NameSset")
Sset.Select acSelectionSetWindow, varMax, varMin
intcnt = 0
ReDim innerLoop(1)
For Each Entry In Sset
ReDim innerLoop(intcnt)
Set innerLoop(intcnt) = Entry
intcnt = intcnt + 1
Next
asdf = IsEmpty(innerLoop(0))
End Function

[den001]

Очень долго не разбирался, но одна ошибка налицо:

Код:

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

ReDim innerLoop(intcnt)

должно быть

Код:

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

ReDim Preserve innerLoop(intcnt)

Иначе получаем пустой массив, с единственным intcnt-м объектом.
Полилинию проверить на замкнутость элементарно:

Код:

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

Dim plobj As AcadLWPolyline
if plobj.Closed then полилиния замкнута :)

Это уже в сторону: отчего в функцию не передать точку как точку, а не как три переменных?

Код:

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

Private Function asdf(pnt1 as ACAD_POINT, pnt2 as ACAD_POINT) As Boolean
Sset.Select acSelectionSetWindow, pnt1, pnt2

[Бродяга]

спасибо, побрую. Уменя уже поздно, но завтра обязательно сообщу о результатах.

[Бродяга]

C точкой пытался, но при попытке считать саму точку с контура или заливки (getbondarybox) у меня выдается ошибка. Не понял по чему, в соседней процедуре, правда на тестовом объекте проходит без запинок. а тут в начале прошло. потом как отрезало, "некорректные данные и все тут. Поспешил. потому и по отдельным цыфрам решил, на этом объекте даже вернее будет.

[Бродяга]

Доброго всем времени суток!!!
Попытался с preserv, разницы никакой.
Блокирует с тем же сообщением. Только теперь выдаетеще "неверный ввод" при попытке установть границы в хатч.

[Бродяга]

может я как то в innerLoop неправильно добавляю объект???
Кто подскажет???

[den001]

При беглом осмотре криминала, вроде, нет. Нужно смотреть состав innerloop (Shift + F9). Вообще так вслепую довольно тяжело сказать. Да и еще разрыв во времени дело осложняет (я вот только проснулся ) Такое предложение: кинь мне почтой файл (у меня ACAD2006), весь код, и скажи, чего должно получиться, покопаюсь.

[den001]

Вобчем, вот процедура, которая гарантировано возвращает массив замкнутых объектов (тех, что наспех вспомнил) в указанной области. Даже немного подогнал под способ передачи точки в виде трех переменных. А со штриховкой нужно разбираться отдельно.

Код:

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

Sub asdf()
  Dim innerLoop() As AcadEntity
  Dim t1(2) As Double, t2(2) As Double
  pnt1 = ThisDrawing.Utility.GetPoint(, "Первый угол:")
  pnt2 = ThisDrawing.Utility.GetCorner(pnt1, "Противоположный угол:")
  For i = 0 To 2
    t1(i) = pnt1(i)
    t2(i) = pnt2(i)
  Next
  SelectClosedObject t1, t2, innerLoop
End Sub

Sub SelectClosedObject(Point1 As ACAD_POINT, Point2 As ACAD_POINT, ArrEnt() As AcadEntity)
Dim Sset As AcadSelectionSet, Entry As AcadEntity

  ClearSelectionSets
  Set Sset = ThisDrawing.SelectionSets.Add("SelClObj")
  Sset.Select acSelectionSetWindow, Point1, Point2
  obj = 0
  For Each Entry In Sset
    Add = False
    Select Case Entry.ObjectName
    Case "AcDbPolyline"
      If Entry.Closed Then Add = True
    Case "AcDbCircle", "AcDbEllipse"
      Add = True
    End Select
    If Add Then
      ReDim Preserve ArrEnt(obj)
      Set ArrEnt(obj) = Entry
      obj = obj + 1
    End If
  Next
  Sset.Delete
End Sub

[den001]

Штриховка всегда была зело геморройным объектом, и в VBA ситуация не меняется. Я программно со штриховкой до сей поры не работал. Но понял одну вещь: сначала нужно создать объект AcadHatch, затем добавить один замкнутый объект методом AppendOuterLoop. Вот потом можно с ней поизвращаться. И, наконец, чтобы она отобразилась - необходимо вычислить ее методом Evaluate.

Код:

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

Sub asdf()
  Dim innerLoop() As AcadEntity
  Dim t1(2) As Double, t2(2) As Double
  Dim Hatch As AcadHatch
  Set Hatch = ThisDrawing.ModelSpace.AddHatch(acPreDefinedGradient, "ANSI31", False)
  
  Do
    pnt1 = ThisDrawing.Utility.GetPoint(, "Первый угол:")
    pnt2 = ThisDrawing.Utility.GetCorner(pnt1, "Противоположный угол:")
    For i = 0 To 2
      t1(i) = pnt1(i)
      t2(i) = pnt2(i)
    Next
    SelectClosedObject t1, t2, innerLoop
    Hatch.AppendOuterLoop innerLoop
    Hatch.Evaluate
  Loop
End Sub

P.S. Выход из процедуры аварийный: Esc или правый клик.
P.P.S. Прилагаю доказательство работоспособности
[ATTACH]1173139315.dwg[/ATTACH]

[den001]

Блин, вот оно озарение! inner- или outerLoop - это не массив замкнутых объектов! Это один замкнутый объект (точнее - массив из одного объекта), или массив объектов, например отрезков, образующих замкнутый контур! (хелп повнимательней прочел ) Вот почему он выдавал ошибку!

Код:

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

Sub asdf()
  Dim innerLoop() As AcadEntity
  Dim t1(2) As Double, t2(2) As Double
  Dim Hatch As AcadHatch
  Set Hatch = ThisDrawing.ModelSpace.AddHatch(acPreDefinedGradient, "ANSI31", False)
  ReDim innerLoop(0)
  ThisDrawing.Utility.GetEntity innerLoop(0), pnt
  Hatch.AppendOuterLoop innerLoop
  Hatch.Evaluate
  Do
    pnt1 = ThisDrawing.Utility.GetPoint(, "Первый угол:")
    pnt2 = ThisDrawing.Utility.GetCorner(pnt1, "Противоположный угол:")
    For i = 0 To 2
      t1(i) = pnt1(i)
      t2(i) = pnt2(i)
    Next
    SelectClosedObject t1, t2, innerLoop
    Hatch.AppendInnerLoop innerLoop
    Hatch.Evaluate
  Loop
End Sub

В прилагаемом файле красный контур состоит из отрезков.
(чтобы выбирались отрезки в SelectClosedObjects после "AcDbEllipse" добавляем через запятую "AcDbLine")
[ATTACH]1173141208.dwg[/ATTACH]

[Бродяга]

Доброго времени суток!!!
Из-за всех энтих общественных нагрузок взял бы да отменил праздники вовсе. Как праздник, так ни до чего не доберешься. А тут еще сеть накрылась. В общем только сейчас дорвался .
У меня рунается на
ClearSelectionSets, не понял почему, но это пол беды.
Все это работает для ОДНОГО замкнутого объекта. Т.е. если есть четыре взаимопересекающихся отрезка (но замкнтых не на концах а в точках пересечения), то выдается "неверны ввод", то же самое, если в зону попадает хотя бы два замкнтых объеката, независящих друг от друга. в общем теперь нужен способ как то отбирать все эти объекты по одному что ли :roll: . Не понятно как. В одной зоне часто оказываются разные объекты, иногда и не ззамкныте и просто линии, не относящиеся к штриховке. Блин, ну и геморой, в каде то как то это реализовано по одному щелчку мышки!!!
p.s. При задании координат совпадающих с объектом для outerloop процедура начинает вносить в список и линии внешнего объекта, что так же ведет к ошибке, как это обойти???

[Бродяга]

тьфу!тьфу. Наверно еще с праздников не очухался.
Увидел процедуру в предидущем сообщении, но уже после отправки своего. Попоробую запустить!

[den001]

Нда, со штриховкой и без VBA геморрою хватало, а тут совсем весело
Такая идея - для пересекающихся отрезков через SendCommand создать контур, и уже этот контур добавлять в innerLoop. Я сделал для нормальных условий (МСК, плоскость XY, вид сверху). Также подкорректировал SelectClosedObject, чтобы не выбирались два замкнутых объекта.

Код:

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

Public Sub ClearSelectionSets()
  For i = 0 To ThisDrawing.SelectionSets.Count - 1
    ThisDrawing.SelectionSets.Item(0).Clear
    ThisDrawing.SelectionSets.Item(0).Delete
  Next
End Sub

Function ChgStr(ByVal StringToChange, KeyString, StringToInsert, Optional NoCaps As Boolean)
    nr = 0
    Do
        If NoCaps Then nr = InStr(nr + 1, LCase(StringToChange), LCase(KeyString)) Else nr = InStr(nr + 1, StringToChange, KeyString)
        If IsNumeric(StringToInsert) Then StringToInsert = Trim(Str(StringToInsert))
        If nr > 0 Then
            StringToChange = Left(StringToChange, nr - 1) + StringToInsert + Right(StringToChange, Len(StringToChange) - nr - (Len(KeyString) - 1))
            nr = nr + Len(StringToInsert)
        End If
    Loop Until nr = 0
    ChgStr = StringToChange
End Function

Sub SelectClosedObject(Point1 As ACAD_POINT, Point2 As ACAD_POINT, ArrEnt() As AcadEntity)
Dim Sset As AcadSelectionSet, Entry As AcadEntity, Line As AcadLine
  ClearSelectionSets
  Set Sset = ThisDrawing.SelectionSets.Add("SelClObj")
  Sset.Select acSelectionSetWindow, Point1, Point2
  obj = 0
  For Each Entry In Sset
    Add = False: Cont = False
    Select Case Entry.ObjectName
    Case "AcDbPolyline"
      If Entry.Closed Then Add = True
    Case "AcDbCircle", "AcDbEllipse"
      Add = True
    Case "AcDbLine"
      Add = True: Cont = True
    End Select
    If Add Then
      PrevObjName = Entry.ObjectName
      If Entry.ObjectName <> PrevObjName Then Exit For
      ReDim Preserve ArrEnt(obj)
      Set ArrEnt(obj) = Entry
      If Not Cont Then Exit For
      obj = obj + 1
    End If
  Next
  obj = UBound(ArrEnt)
  If obj > 1 Then
    For i = 0 To obj
      If ArrEnt(i).ObjectName = "AcDbLine" Then
        Set Line = ArrEnt(i)
        Xc = Line.StartPoint(0) + (Line.EndPoint(0) - Line.StartPoint(0)) / 2
        Yc = Line.StartPoint(1) + (Line.EndPoint(1) - Line.StartPoint(1)) / 2
        Xcm = Xcm + Xc: Ycm = Ycm + Yc
      End If
    Next
    Xcm = Xcm / (obj + 1): Ycm = Ycm / (obj + 1)
    ThisDrawing.SendCommand "_-boundary " & Trim(ChgStr(Str(Xcm), ",", ".")) & "," & Trim(ChgStr(Str(Ycm), ",", ".")) & vbCrLf
    Sset.Clear
    Sset.Select acSelectionSetLast
    ReDim ArrEnt(0)
    Set ArrEnt(0) = Sset(0)
  End If
  Sset.Delete
End Sub

Sub asdf()
  Dim innerLoop() As AcadEntity
  Dim t1(2) As Double, t2(2) As Double
  Dim Hatch As AcadHatch
  
'  On Error Resume Next
  
  Set Hatch = ThisDrawing.ModelSpace.AddHatch(acPreDefinedGradient, "ANSI31", False)
  ReDim innerLoop(0)
  ThisDrawing.Utility.GetEntity innerLoop(0), pnt
  Hatch.AppendOuterLoop innerLoop
  Hatch.Evaluate
  Do
    pnt1 = ThisDrawing.Utility.GetPoint(, "Первый угол:")
    pnt2 = ThisDrawing.Utility.GetCorner(pnt1, "Противоположный угол:")
'    If Err.Number <> 0 Then Exit Sub
    For i = 0 To 2
      t1(i) = pnt1(i)
      t2(i) = pnt2(i)
    Next
    SelectClosedObject t1, t2, innerLoop
    Hatch.AppendInnerLoop innerLoop
    Hatch.Evaluate
  Loop
End Sub

[ATTACH]1173426570.dwg[/ATTACH]

[den001]

Еще мысли по этому поводу: если есть массив с несколькими замкунтыми объектами, то, собственно, проблем никаких: просто в цикле по одному объекту из него добавлять в innerLoop. Только из SelectClosedObject нужно убрать ограничение на (число объектов) = 1.

Код:

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

  Dim innerLoop() As AcadEntity, ArrEnt() As AcadEntity
  
  SelectClosedObject t1, t2, ArrEnt
  For Ent = 0 To UBound(ArrEnt)
    Set innerLoop(0) = ArrEnt(Ent)
    Hatch.AppendInnerLoop innerLoop
    Hatch.Evaluate
  Next

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

[Бродяга]

Доброго времени суток!
У меня какой то геморой с командой SendCommand. Тут на многих машинах стоит русский автокад 2006, и он ну ни вкакую непринимает команды на английском, к тому же мой админ вааще предпочел 2005, а у того другой синтаксис ввода команды (там как у тебя "_-BHATCH",, а в 2006 "_BHATCH", т.е. без префикса) и иначе "неизвестная команда". на моем английском компе вроде без проблем. Проверял в свое время именно на BHATCH, но скорее всего будут мелкие проблемки и для boundary. В чем проблема не разбирался, да и значения не имеет, скорее всего просто из-за ломанных версий . Изменить ситуацию с версиями не могу, не я диктую условия, работают кто на чем больше привык, что больше нравится. :wink:
Сброшенное тобой вроде заработало (без отрезков), так что решил оставить до лучших времен. А пока просто закрыл отрезки для выбора в массив, поработаю с отдельными объектами.
Время совсем поджало, хотел на выходных поработать, да тут как назло два дня пурга была, из дома не выгребся. Обидно, говорят на месте работы только легкий снежок шел.
Если все сработает, пущу в обкатку уже сегодня, а то начальство плеш проело.
Огромное спасибо за помощь. Самому мне пришлось бы долго разбираться с этим гемороем, если конечно вообще бы разобрался
Ну до связи

[den001]

Хм. Странно. У меня 2006-й русский, прекрасно понимает и _bhatch и _-bhatch. С отрезками действительно геморрой. Я сделал для случая, когда только одна область, образованная пересекающимися отрезками, да еще пересекающимися краями (чтобы точка пересечения была не дальше середины отрезка). И, опять же, с помощью SendCommand. Ну да ладно, и без них жить можно. Пиши, если что.