[gizmo_zx]

Добрый день.
Огромное спасибо всем за помощь на этом форуме, особенно Алексею..

Появился очередной вопрос:
Как нарисовать полилинию (на VBA),
хотел сздать массив точек getpoint `том, но сталкнулся с тем что не знаю размерность массива? и как организовать цикл с выходом из запроса этих самых точек.
пробовал запустить команду _pline в консоль, но VBA макрос при этом не приостанавливается...(по сравнению с лиспом, но в лиспе я еще меньше понимаю)
И как запустить из одного макроса друго, сколько не искал так и не нашел, подозреваю что как-то аналогично EXcel...
Жду любых подсказок

[Sleekka]

1) бросай ты этот вба пока не позно
2) vlide + F1 - неповерю чтобы там такого примера не было. в zwcad-е точно есть =)

[Кулик Алексей aka kpblc]

Есть несколько вариантов:
1. Постоянно запрашивать новую точку (вершину) полилинии и постоянно переназначать Coordinates. Весьма утомительное занятие - прежде всего из-за необходимости отслеживать ошибки ввода. Следом пойдет преобразование координат.
2. Тупо запустить ThisDrawing.SendCommand "_.pline", и потом через

Код:

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

While ThisDrawing.GetVariable("cmdactive") <> 0
  ThisDrawing.SendCommand "\??"
Loop

Но что посылать в SendCommand для имитации ожидания ввода - не помню, а найти с ходу не смог.
P.S. На лиспе решение устроит?

[gizmo_zx]

На липсе вобщем -то устроит,
только у меня полная задача (по общирнее)
моя задача:
1) считать у блока атрибут "grup_n"
2) нарисовать полилинию
3) добавить к гиперссылке гиперлинии значение атрибута "grup_n"
4.1) выйти по Esc
4.2) организовать циклический выбор других полилий
4.3) добавить в их гиперссылку значение атрибута "grup_n", если его там еще нет.
4.4) выйти по Esc.

может на VBA я бы это еще и осилил, с вашей помощью,а вот на лиспе точно никак

[Кулик Алексей aka kpblc]

1) в общем-то проблем не вызовет.
2) руками?
3) что за гиперлиния? Добавлять в адрес, я так понимаю?
4.1) выходить по Esc из какого места?
4.2) вообще всех? Или требовать указания обрабатываемых полилиний?
4.3) А если есть, но другое?
4.4) Откуда выходить-то? И почему именно Esc?

[gizmo_zx]

Сообщение от Кулик Алексей aka kpblc 1) в общем-то проблем не вызовет. 2) руками? 3) что за гиперлиния? Добавлять в адрес, я так понимаю? 4.1) выходить по Esc из какого места? 4.2) вообще всех? Или требовать указания обрабатываемых полилиний? 4.3) А если есть, но другое? 4.4) Откуда выходить-то? И почему именно Esc?

2) вызвать команду _pline
3) Про гиперлинию это бред моего воспаленного мозга
(Гиперссылка + полилиния) * = гиперлиния

добавить гипперсылку в только что нарисованную линию (пункт 2), вероятно по этому просто команду _pline вероятно не получится...
4.1) выйти по Esc из любого места программы (типа прервать выполнение команды), если выходить во время
"ThisDrawing.Utility.GetEntity objBlk, varPoint, strPrompt"
вылазиет ошибка VBA и пугает окружающих
4.2) требовать указания обрабатываемых полилиний
4.3) добавить в их гиперссылку значение атрибута "grup_n", если его там еще нет. Если есть, но другие то добавить к имеющимся.

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

4.4) с учетом 4.1 отпадает, по "esc" просто привычнее и только, хотя не очень важно по какой кнопке прерывать команду

код для пункта 1 (считать у блока атрибут "grup_n") тоже сделал.
хотелось бы объединить 2, 3 и 4

код прорисовки полилинии нашел:

Код:

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

Public Sub DynPolyline()
' draw lwpolyline interactively
Dim pickPt As Variant
Dim dblCoors() As Double
Dim i As Long
Dim oPoly As AcadLWPolyline

i = 0
On Error Resume Next
pickPt = ThisDrawing.Utility.GetPoint(, vbCr & "First point: ")
If Err = 0 Then
    ReDim dblCoors(1)
    dblCoors(i) = pickPt(0): dblCoors(i + 1) = pickPt(1)
    Do Until Err.Number <> 0
        i = i + 2
        pickPt = ThisDrawing.Utility.GetPoint(pickPt, vbCr & "Pick next point or press Enter to stop: ")
        ReDim Preserve dblCoors(UBound(dblCoors) + 2)
        dblCoors(i) = pickPt(0): dblCoors(i + 1) = pickPt(1)
        If oPoly Is Nothing Then
            Set oPoly = ThisDrawing.ModelSpace.AddLightWeightPolyline(dblCoors)
        Else
            oPoly.Coordinates = dblCoors
        End If
    Loop
    Dim lngResp As Long
    lngResp = MsgBox("Do you want to close polyline?", vbYesNo, "Close Mode")
    If lngResp = 6 Then
    oPoly.Closed = True
    End If
End If
End Sub

[Кулик Алексей aka kpblc]

Для построения корректной полилинии требуется не менее 2 вершин, а у тебя построение начинается уже с 1.

[Кулик Алексей aka kpblc]

Вариант на лиспе:

Код:

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

(defun test (/ adoc fun_conv-vla-to-list blk att pline selset)

  (defun fun_conv-vla-to-list (value / res)
    (cond
      ((= (type value) 'variant)
       (setq res (fun_conv-vla-to-list (vlax-variant-value value)))
       )
      ((and (= (type value) 'safearray)
            (>= (vlax-safearray-get-u-bound value 1) 0)
            ) ;_ end of and
       (setq res (vlax-safearray->list value))
       )
      ((and (= (type value) 'vla-object)
            (vlax-property-available-p value 'count)
            ) ;_ end of and
       (vlax-for item value
         (setq res (cons item res))
         ) ;_ end of vlax-for
       (setq res (reverse res))
       )
      ) ;_ end of cond
    res
    ) ;_ end of defun

  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (if (and (= (type (setq blk (vl-catch-all-apply
                                (function (lambda ()
                                            (prompt "\nУкажи блок <Отмена> : ")
                                            (ssget "_+.:S:E" '((0 . "INSERT") (66 . 1)))
                                            ) ;_ end of lambda
                                          ) ;_ end of function
                                ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'pickset
              ) ;_ end of =
           (setq blk (vlax-ename->vla-object (ssname blk 0)))
           (setq attr (car (vl-remove-if-not
                             (function
                               (lambda (x)
                                 (wcmatch (strcase (vla-get-tagstring x)) "GRUP_N")
                                 ) ;_ end of lambda
                               ) ;_ end of function
                             ((lambda ()
                                (apply (function append)
                                       (mapcar (function fun_conv-vla-to-list)
                                               (list (vla-getattributes blk)
                                                     (vla-getconstantattributes blk)
                                                     ) ;_ end of list
                                               ) ;_ end of mapcar
                                       ) ;_ end of append
                                ) ;_ end of lambda
                              )
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of car
                 ) ;_ end of setq
           ) ;_ end of and
    (progn
      (command "_.pline")
      (while (/= (getvar "cmdactive") 0)
        (command pause)
        ) ;_ end of while
      (setq pline (vlax-ename->vla-object (entlast)))
      (vla-add (vla-get-hyperlinks pline) (vla-get-textstring attr))
      (if (setq selset (ssget '((0 . "*POLYLINE"))))
        (foreach ent (mapcar (function vlax-ename->vla-object)
                             ((lambda (/ tab item)
                                (repeat (setq tab  nil
                                              item (sslength selset)
                                              ) ;_ end setq
                                  (setq tab (cons (ssname selset (setq item (1- item))) tab))
                                  ) ;_ end of repeat
                                ) ;_ end of lambda
                              )
                             ) ;_ end of mapcar
          (foreach hyper (fun_conv-vla-to-list (vla-get-hyperlinks ent))
            (vla-delete hyper)
            ) ;_ end of foreach
          (vla-add (vla-get-hyperlinks ent) (vla-get-textstring attr))
          ) ;_ end of foreach
        ) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

Не проверяется корректность выхода из команды рисования полилинии. Имеющиеся гиперссылки удаляются.

[gizmo_zx]

спасибо, попробую применить