[dextron3]

Как лисп должен работать:

1. Выделяем множество замкнутых фигур
2. Выполняется оффсет всех фигур на 100мм внутрь
3. Вычерчиваются новые офсетные фигуры, а старые удаляются


Для чего нужно:
1. Подсчет подбетонки (обычно фундаментные ленты начерчены чтобы их найти объем достаточно площадь умножить на высоту, это легко, а вот чтобы найти объем подбетонки нужно офсетить прямоугольники внутри внутрь на 100мм, а с наружи наружу, кропотливая работа, затем находим площадь и умножаем на высоту вот и объем подбетонки

2. Для подсчета щебня, гравия и тп.
3. Нужный лисп для каждого конструктора
[ATTACH]1182320890.JPG[/ATTACH]

:roll: :roll: :roll: :roll: :roll:

[dextron3]

Alaspher, Спасибо!
Обнаружил "баг":
1) Если прямоугольник офсетецца на расстояние больше размеров выскакивает страшная ошибка типа:
Select objects:
Command:
Направление офсета [Внутрь/Наружу] <Внутрь>:
Укажи дистанцию <100>:
; error: Automation Error. Description was not provided.
Нельзя как то сделать чтобы вместо этого писалось:
Уважаемый пользователь автокада извините, но введенное число больше половины стороны прямоугольника, будьте внимательными.
Искренне Ваш автокад.
---
Здесь был я, и я прибрамшись. Дабы никого постараться не обидеть. Пост переформулировал. kpblc.

[Alaspher]

dextron3
Писать анализатор слишком сложно - автокад не сообщает, что привело к ошибке, т.е., что-бы это выяснить, придётся проводить полный анализ геометрии - не обязательно, что прямоугольники офсетятся.

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

Код:

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

(vl-load-com)
(defun c:ooff3 (/              adoc           pl:is-lwpoly-clock
                pl:obj-filter-select-manual   locs           asel           isclock
                isint          lays           isdel          tmp            ssel
                vl-err         vl-err-ent     isdele         vl-err-cnt
               )
  (defun pl:is-lwpoly-clock (lwpl / pnts angl)
    (setq pnts (mapcar (function cdr)
                       (vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget lwpl))
               )
          angl (mapcar (function angle) (cons (last pnts) pnts) pnts)
    )
    (minusp (apply (function +)
                   (mapcar (function (lambda (b)
                                       (cond ((< (abs b) pi) b)
                                             ((minusp b) (+ (* 2 pi) b))
                                             (t (+ (* -2 pi) b))
                                       )
                                     )
                           )
                           (mapcar (function -) angl (cons (last angl) angl))
                   )
            )
    )
  )
  (defun pl:obj-filter-select-manual (sel filter)
    (vla-selectonscreen
      sel
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbinteger (cons 0 (1- (length filter))))
        (mapcar (function car) filter)
      )
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbvariant (cons 0 (1- (length filter))))
        (mapcar (function cdr) filter)
      )
    )
  )
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        lays (vla-get-layers adoc)
        ssel (vla-get-selectionsets adoc)
  )
  (if (vl-catch-all-error-p
        (setq asel (vl-catch-all-apply (function vla-item) (list ssel "pl:ooff-sel")))
      )
    (setq asel (vla-add (vla-get-selectionsets adoc) "pl:ooff-sel"))
  )
  (vla-clear asel)
  (pl:obj-filter-select-manual asel '((0 . "LWPOLYLINE")))
  (vlax-for i asel
    (if (= :vlax-true (vla-get-lock (vla-item lays (vla-get-layer i))))
      (setq locs (cons i locs))
    )
  )
  (if locs
    (vla-removeitems
      asel
      (vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length locs)))) locs)
    )
  )
  (if (zerop (vla-get-count asel))
    (princ "\nНе выбрано полилиний на незаблокированных слоях.")
    (progn
      (initget "В Н _I O")
      (if (not (setq isint (getkword "\nНаправление офсета [Внутрь/Наружу] <Внутрь>: ")))
        (setq isint "I")
      )
      (if (/= (type pl:ooff-dist) 'real)
        (setq pl:ooff-dist 100.0)
      )
      (initget 6)
      (if (setq tmp (getdist (strcat "\nУкажи дистанцию <" (rtos pl:ooff-dist) ">: ")))
        (setq pl:ooff-dist tmp)
      )
      (vla-startundomark adoc)
      (vlax-for i asel
        (if (vl-catch-all-error-p
              (setq
                vl-err (vl-catch-all-apply
                         (function vla-offset)
                         (list
                           i
                           (if
                             (or (and (setq isclock (pl:is-lwpoly-clock (vlax-vla-object->ename i)))
                                      (= isint "I")
                                 )
                                 (and (/= isint "I") (not isclock))
                             )
                              pl:ooff-dist
                              (- pl:ooff-dist)
                           )
                         )
                       )
              )
            )
          (progn (setq vl-err-ent (cons i vl-err-ent))
                 (princ (strcat "\n" (vl-catch-all-error-message vl-err)))
          )
        )
      )
      (vla-endundomark adoc)
      (if (not (zerop (setq vl-err-cnt (length vl-err-ent))))
        (progn (vla-removeitems
                 asel
                 (vlax-safearray-fill
                   (vlax-make-safearray vlax-vbobject (cons 0 (1- (length vl-err-ent))))
                   vl-err-ent
                 )
               )
               (alert (strcat "При обработке "
                              (rtos vl-err-cnt 2 0)
                              " примитивов возникли ошибки!\nСмотри вывод в текстовом окне."
                      )
               )
        )
      )
      (if (not (zerop (vla-get-count asel)))
        (progn (vla-highlight asel :vlax-true)
               (initget "Д Н _Y N")
               (if (not (setq isdel (getkword "\nУдалить исходные примитивы [Да/Нет] <Да>: ")))
                 (setq isdel "Y")
               )
        )
      )
      (if (= isdel "Y")
        (progn (vla-startundomark adoc) (vla-erase asel) (vla-endundomark adoc))
        (vla-highlight asel :vlax-false)
      )
      (if (and (or (= isdel "Y") (zerop (vla-get-count asel))) (not (zerop vl-err-cnt)))
        (progn (foreach i vl-err-ent (vla-highlight i :vlax-true))
               (initget "Д Н _Y N")
               (if (not (setq isdele
                               (getkword
                                 "\nУдалить примитивы при обработке которых возникли ошибки [Да/Нет] <Нет>: "
                               )
                        )
                   )
                 (setq isdele "N")
               )
        )
      )
      (if (= isdele "Y")
        (progn (vla-startundomark adoc) (foreach i vl-err-ent (vla-erase i)) (vla-endundomark adoc))
        (foreach i vl-err-ent (vla-highlight i :vlax-false))
      )
    )
  )
  (princ)
)

[небольшая сервисная корректировка]

[корректировка ошибки, в результате которой, иногда выдавался лишний запрос на удаление необработанных примитивов, несмотря на их отсутствие]

[dextron3]

спасибо еще раз
работает

[Alaspher]

Пользователи сообщили о некритической ошибке - откорректировал.