[Омская птица]

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

[Alan]

Правильнее наверное эту тему наверное в Программирование...
Без проверки, на вскидку.

Код:

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

 ;;;  ===========; считывание отрезков в список  ======================
      (setq i	 0
	    pi2	 (/ pi 2)
	    pi_2 (/ pi -2)
	    ss	 (ssget	"_X"
			'((0 . "LINE"))
		 ) ;_ конец ssget
      ) ;_ setq
(while (setq el (ssname ss i)) ; el -   примитив
	
(setq p1  (cdr (assoc 10 (entget el)))
      p2  (cdr (assoc 11 (entget el)))
      n_l (atoi (cdr (assoc 8 (entget el))))
      angl (angle p1 p2)
) ;_ конец setq
  (setq	list_pt	(list (polar p1 (- angl pi2) (/ n_l 2))
		      (polar p1 (- angl pi_2) (/ n_l 2))
		      (polar p2 (- angl pi_2) (/ n_l 2))
		      (polar p2 (- angl pi2) (/ n_l 2))
		) ;_ конец list
  ) ;_ конец setq
(setq e	(entmake (list '(0 . "LWPOLYLINE")
		       '(100 . "AcDbEntity")
		       '(67 . 0)
		       '(410 . "Model")
		       (cons 8 "0")
		       '(100 . "AcDbPolyline")
		       (cons 43 0)
;;;		       (cons 62 1) - группа цвета, сейчас "по слою", в слое "0"
		       (cons 90 (length list_pt))
		       (cons 10 (nth 0 list_pt))
		       (cons 10 (nth 1 list_pt))
		       (cons 10 (nth 2 list_pt))
		       (cons 10 (nth 3 list_pt))
		       '(70 . 1) ;closed pline
		 ) ;_ конец list
	) ;_ конец entmake
) ;_ конец setq
(setq i (1+ i)))

Файл на котором проверял приложил

[Омская птица]

Спасибо за труд! Скажите пожалуйста как сие загрузить? Сделал _appload, а как вызвать?

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

http://dwg.ru/pub/9

[Alan]

Сообщение от Омская птица Сделал _appload, а как вызвать?

Я не оформлял это программой/командой. После загрузки текста выполняется построение прямоугольников по отрезкам.
Оформить командой?

[Омская птица]

Сообщение от Alan После загрузки текста выполняется построение прямоугольников по отрезкам

Копирую в командную строку и получается вот что:

Код:

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

Выберите объекты:

                  ОТРЕЗОК            Слой: "250"
                                     Пространство: Пространство модели
Масштаб типа линий =     100.0
                   Метка = 2a7
                от точки, X=  38586.6  Y=  21497.5  Z=      0.0
                до точки, X=  37629.5  Y=  21497.5  Z=      0.0
          Длина =    957.1, Угол в плоскости XY =    180
                  Дельта X =      -957.1, Дельта Y =         0.0, Дельта Z =    
     0.0

                  ОТРЕЗОК            Слой: "250"
                                     Пространство: Пространство модели
Масштаб типа линий =     100.0
                   Метка = 2a6
                от точки, X=  38223.7  Y=  21057.7  Z=      0.0
                до точки, X=  38586.6  Y=  21497.5  Z=      0.0
          Длина =    570.2, Угол в плоскости XY =     50
                  Дельта X =       362.9, Дельта Y =       439.8, Дельта Z =    
     0.0

                  ОТРЕЗОК            Слой: "250"
                                     Пространство: Пространство модели
Нажмите ENTER для продолжения:
Масштаб типа линий =     100.0
                   Метка = 2a5
                от точки, X=  38862.8  Y=  20768.8  Z=      0.0
                до точки, X=  38223.7  Y=  21057.7  Z=      0.0
          Длина =    701.4, Угол в плоскости XY =    156
                  Дельта X =      -639.2, Дельта Y =       288.9, Дельта Z =    
     0.0

                  ОТРЕЗОК            Слой: "250"
                                     Пространство: Пространство модели
Масштаб типа линий =     100.0
                   Метка = 2a4
                от точки, X=  39331.7  Y=  21529.6  Z=      0.0
                до точки, X=  38862.8  Y=  20768.8  Z=      0.0
          Длина =    893.8, Угол в плоскости XY =    238
                  Дельта X =      -468.9, Дельта Y =      -760.9, Дельта Z =    
     0.0

                  ОТРЕЗОК            Слой: "300"
                                     Пространство: Пространство модели
Масштаб типа линий =     100.0
                   Метка = 2a3
                от точки, X=  38827.5  Y=  22210.2  Z=      0.0
                до точки, X=  39331.7  Y=  21529.6  Z=      0.0
          Длина =    847.0, Угол в плоскости XY =    307
                  Дельта X =       504.3, Дельта Y =      -680.6, Дельта Z =    
     0.0

                  ОТРЕЗОК            Слой: "100"
                                     Пространство: Пространство модели
Масштаб типа линий =     100.0
                   Метка = 2a2
                от точки, X=  37912.1  Y=  21433.3  Z=      0.0
                до точки, X=  38827.5  Y=  22210.2  Z=      0.0
          Длина =   1200.6, Угол в плоскости XY =     40
                  Дельта X =       915.4, Дельта Y =       776.9, Дельта Z =    
     0.0

                  ОТРЕЗОК            Слой: "250"
                                     Пространство: Пространство модели
Масштаб типа линий =     100.0
                   Метка = 241
                от точки, X=  37259.8  Y=  20856.2  Z=      0.0
                до точки, X=  37259.8  Y=  22635.8  Z=      0.0
          Длина =   1779.6, Угол в плоскости XY =     90
                  Дельта X =         0.0, Дельта Y =      1779.6, Дельта Z =    
     0.0

[Alan]

Оформил как команду.
1. Загрузи приложенный текст
2. Набери в комстроке nz_restang для выполнения

Прямоугольники НЕ строятся по отрезкам в слое 0 и с буквами в начале имени

[Омская птица]

Круто!!! Спасибо

[Rusakov.A.A.]

Полезный код! А как быть если необходимо преобразовать прямоугольник в линию?одна сторона всегда постоянной длины.

[Boxa]

Сообщение от Rusakov.A.A. Полезный код! А как быть если необходимо преобразовать прямоугольник в линию?одна сторона всегда постоянной длины.

Очевидно, писать другой полезный код...

[Profan]

В AutoCAD'е нет объекта "прямоугольник".

[Geor9e]

Offtop: Profan, раз пошла такая пьянка, объекта "линия" тоже нет

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

_.xline отменили?

[Geor9e]

Offtop: Кулик Алексей aka kpblc, так она же "ПРЯМАЯ" вроде

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

Offtop: Если не ошибаюсь, где-то она фигурировала как "Конструктивная линия".

[Geor9e]

Offtop: Кулик Алексей aka kpblc, у меня ещё понимает запрос "линияразметки" (но команда-то при этом всё равно "прямая")

[Teyso]

Коллеги, здравствуйте. Извините, что поднимаю старую тему, но нет желания плодить новые. Подскажите. В коде, который тут приведен, неизвестная сторона прямоугольника берется из названия слоя. Так как я не владею навыками программирования, то подскажите, как мне жёстко задать размер той стороны, вместо того, что она берёз значение из названия слоя? Подскажите хотя бы какая это строка в коде. Буду очень благодарен за помощь.

[Diman111]

Попробуй вместо n_l (atoi (cdr (assoc 8 (entget el))))
Вставить значение
n_l (значение)

[Alan]

Сообщение от Teyso жёстко задать размер той стороны, вместо того, что она берёз значение из названия слоя

Чтобы закрыть тему решением этого варианта:

Код:

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

 (defun c:nz_restang
		    (/	   i	 oldl  osmd  pi2   pi_2	 rr1   rr2
		     n_l   c_l	 ss    el    p1	   p2	 n_l   angl
		     list_pt
		    )
    (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  ) ;_ end of vla-startundomark

  (setq	i    0
	oldl (getvar "CLAYER")
	osmd (getvar "osmode")
;;;  (setvar "CECOLOR" col)
	pi2  (/ pi 2)
	pi_2 (/ pi -2)
;;;  ===========; считывание отрезков в список  ======================
;;;	ss   (ssget "_X"
;;;		    '((0 . "LINE"))
;;;	     ) ;_ конец ssget
	rr1  nil
	rr2  nil
  ) ;_ setq
  (setvar "osmode" 0)
;;; выбор объектов LINE
  (setq ss (ssget '((0 . "LINE"))))

			      ; длина списка
;;;  (princ)
;;;  начало построения прямоугольников
  (if ss
    (progn
      (setq i (sslength ss))
      (prompt (strcat "\nВы выбрали "
		      (itoa i)
		      " примитив"
		      (dl_sp i)
	      ) ;_ конец strcat
      )			      ; prompt &strcat
      (setq i	0
	    n_l	(getint "\n Введите ширину прямоугольника <40>:")
	    n_l	(if n_l
		  n_l
		  40
		) ;_ конец if
      ) ;_ конец setq

;;;      цикл по примитивам
      (while (setq el (ssname ss i)) ; el -   примитив 


	(setq p1   (cdr (assoc 10 (entget el)))
	      p2   (cdr (assoc 11 (entget el)))
;;;	    n_l	 (atoi (cdr (assoc 8 (entget el))))
	      c_l  (cdr (assoc 8 (entget el)))
	      angl (angle p1 p2)
	) ;_ конец setq
	(if (eq n_l 0)
	  nil
	  (progn
	    (setq
	      list_pt (list (polar p1 (- angl pi2) (/ n_l 2))
			    (polar p1 (- angl pi_2) (/ n_l 2))
			    (polar p2 (- angl pi_2) (/ n_l 2))
			    (polar p2 (- angl pi2) (/ n_l 2))
		      ) ;_ конец list
	    ) ;_ конец setq
	    (entmake (list '(0 . "LWPOLYLINE")
			   '(100 . "AcDbEntity")
			   '(67 . 0)
			   '(410 . "Model")
			   (cons 8 c_l)
			   '(100 . "AcDbPolyline")
			   (cons 43 0)
;;;			 (cons 62 3)
;;;			      ;- группа цвета, сейчас "по слою", в слое в котором отрезок
			   (cons 90 (length list_pt))
			   (cons 10 (nth 0 list_pt))
			   (cons 10 (nth 1 list_pt))
			   (cons 10 (nth 2 list_pt))
			   (cons 10 (nth 3 list_pt))
			   '(70 . 1) ;closed pline
		     ) ;_ конец list
	    ) ;_ конец entmake
	  ) ;_ конец progn
	) ;_ конец if

	(setq i (1+ i))
      ) ;_ конец while
    ) ;_ конец progn
    (prompt "\n Не выбраны примитивы типа Line в этом чертеже")
  ) ;_ конец if


  (setvar "osmode" osmd)
;;;  (setvar "CECOLOR" col)
  (setvar "CLAYER" oldl)
  (vla-endundomark adoc)
  (princ)
) ;_ конец defun
;;;--------------------------; функция для окончания слова примитив

(defun dl_sp (i / ii)
			      ; длина списка
  (setq
    ii (strlen (itoa i))
			      ; для определения окончания слова примитив
    ii (atoi (substr (itoa i) ii 1))
  ) ;_ конец setq
			      ;                    (print ii)
  (cond
    ((and (> i 10) (< i 15)) "ов")
    ((= ii 1) "")
    ((and (> ii 1) (< ii 5)) "а")
    ((or (< ii 1) (> ii 4)) "ов")
  )			      ; cond
) ;_ конец defun
(princ "\n:: Type \"nz_restang\" для выполнения ::")

[aafeoktistov]

Сообщение от Alan Чтобы закрыть тему решением этого варианта: Код: [Выделить все] (defun c:nz_restang (/ i oldl osmd pi2 pi_2 rr1 rr2 n_l c_l ss el p1 p2 n_l angl list_pt ) (vl-load-com) (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))) ) ;_ end of vla-startundomark (setq i 0 oldl (getvar "CLAYER") osmd (getvar "osmode") ;;; (setvar "CECOLOR" col) pi2 (/ pi 2) pi_2 (/ pi -2) ;;; ===========; считывание отрезков в список ====================== ;;; ss (ssget "_X" ;;; '((0 . "LINE")) ;;; ) ;_ конец ssget rr1 nil rr2 nil ) ;_ setq (setvar "osmode" 0) ;;; выбор объектов LINE (setq ss (ssget '((0 . "LINE")))) ; длина списка ;;; (princ) ;;; начало построения прямоугольников (if ss (progn (setq i (sslength ss)) (prompt (strcat "\nВы выбрали " (itoa i) " примитив" (dl_sp i) ) ;_ конец strcat ) ; prompt &strcat (setq i 0 n_l (getint "\n Введите ширину прямоугольника <40>:") n_l (if n_l n_l 40 ) ;_ конец if ) ;_ конец setq ;;; цикл по примитивам (while (setq el (ssname ss i)) ; el - примитив (setq p1 (cdr (assoc 10 (entget el))) p2 (cdr (assoc 11 (entget el))) ;;; n_l (atoi (cdr (assoc 8 (entget el)))) c_l (cdr (assoc 8 (entget el))) angl (angle p1 p2) ) ;_ конец setq (if (eq n_l 0) nil (progn (setq list_pt (list (polar p1 (- angl pi2) (/ n_l 2)) (polar p1 (- angl pi_2) (/ n_l 2)) (polar p2 (- angl pi_2) (/ n_l 2)) (polar p2 (- angl pi2) (/ n_l 2)) ) ;_ конец list ) ;_ конец setq (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(67 . 0) '(410 . "Model") (cons 8 c_l) '(100 . "AcDbPolyline") (cons 43 0) ;;; (cons 62 3) ;;; ;- группа цвета, сейчас "по слою", в слое в котором отрезок (cons 90 (length list_pt)) (cons 10 (nth 0 list_pt)) (cons 10 (nth 1 list_pt)) (cons 10 (nth 2 list_pt)) (cons 10 (nth 3 list_pt)) '(70 . 1) ;closed pline ) ;_ конец list ) ;_ конец entmake ) ;_ конец progn ) ;_ конец if (setq i (1+ i)) ) ;_ конец while ) ;_ конец progn (prompt "\n Не выбраны примитивы типа Line в этом чертеже") ) ;_ конец if (setvar "osmode" osmd) ;;; (setvar "CECOLOR" col) (setvar "CLAYER" oldl) (vla-endundomark adoc) (princ) ) ;_ конец defun ;;;--------------------------; функция для окончания слова примитив (defun dl_sp (i / ii) ; длина списка (setq ii (strlen (itoa i)) ; для определения окончания слова примитив ii (atoi (substr (itoa i) ii 1)) ) ;_ конец setq ; (print ii) (cond ((and (> i 10) (< i 15)) "ов") ((= ii 1) "") ((and (> ii 1) (< ii 5)) "а") ((or (< ii 1) (> ii 4)) "ов") ) ; cond ) ;_ конец defun (princ "\n:: Type \"nz_restang\" для выполнения ::")

Здравствуйте! А подскажите пожалуйста как сделать еще автоматический поворот получившегося прямоугольника в горизонтальную плоскость если линия от которой он строится вертикальная? Заранее спасибо!

[Alan]

Сообщение от aafeoktistov А подскажите пожалуйста как сделать еще автоматический поворот получившегося прямоугольника в горизонтальную плоскость если линия от которой он строится вертикальная?

В ЛИСПе можно всё. Возникает конечно вопрос:"Зачем это?" Но не думаю, что это задача поставлена преподом... может кому и для дела.
Достаточно добавить анализ угла между точками начала и конца отрезка - смотри строки 58, 88 и 89. И поворачивать в случае необходимости

Код:

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

 (defun c:nz_restang
		    (/	   i	 oldl  osmd  pi2   pi_2	 rr1   rr2
		     n_l   c_l	 ss    el    p1	   p2	 n_l   angl
		     angl_d list_pt
		    )
    (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  ) ;_ end of vla-startundomark

  (setq	i    0
	oldl (getvar "CLAYER")
	osmd (getvar "osmode")
;;;  (setvar "CECOLOR" col)
	pi2  (/ pi 2)
	pi_2 (/ pi -2)
;;;  ===========; считывание отрезков в список  ======================
;;;	ss   (ssget "_X"
;;;		    '((0 . "LINE"))
;;;	     ) ;_ конец ssget
	rr1  nil
	rr2  nil
  ) ;_ setq
  (setvar "osmode" 0)
;;; выбор объектов LINE
  (setq ss (ssget '((0 . "LINE"))))

			      ; длина списка
;;;  (princ)
;;;  начало построения прямоугольников
  (if ss
    (progn
      (setq i (sslength ss))
      (prompt (strcat "\nВы выбрали "
		      (itoa i)
		      " примитив"
		      (dl_sp i)
	      ) ;_ конец strcat
      )			      ; prompt &strcat
      (setq i	0
	    n_l	(getint "\n Введите ширину прямоугольника <40>:")
	    n_l	(if n_l
		  n_l
		  40
		) ;_ конец if
      ) ;_ конец setq

;;;      цикл по примитивам
      (while (setq el (ssname ss i)) ; el -   примитив 


	(setq p1    (cdr (assoc 10 (entget el)))
	      p2    (cdr (assoc 11 (entget el)))
;;;	    n_l	 (atoi (cdr (assoc 8 (entget el))))
	      c_l   (cdr (assoc 8 (entget el)))
	      angl  (angle p1 p2)
;;;			      ; преобразование углов из  радианов в градусы
	     angl_d (* 180 (/ angl pi))
	) ;_ конец setq
	(if (eq n_l 0)
	  nil
	  (progn
	    (setq
	      list_pt (list (polar p1 (- angl pi2) (/ n_l 2))
			    (polar p1 (- angl pi_2) (/ n_l 2))
			    (polar p2 (- angl pi_2) (/ n_l 2))
			    (polar p2 (- angl pi2) (/ n_l 2))
		      ) ;_ конец list
	    ) ;_ конец setq
	    (entmake (list '(0 . "LWPOLYLINE")
			   '(100 . "AcDbEntity")
			   '(67 . 0)
			   '(410 . "Model")
			   (cons 8 c_l)
			   '(100 . "AcDbPolyline")
			   (cons 43 0)
;;;			 (cons 62 3)
;;;			      ;- группа цвета, сейчас "по слою", в слое в котором отрезок
			   (cons 90 (length list_pt))
			   (cons 10 (nth 0 list_pt))
			   (cons 10 (nth 1 list_pt))
			   (cons 10 (nth 2 list_pt))
			   (cons 10 (nth 3 list_pt))
			   '(70 . 1) ;closed pline
		     ) ;_ конец list
	    ) ;_ конец entmake
;;; анализ угла между точками начала и конца отрезка
	    (if (or (= angl_d 90.) (= angl_d 270.))
	      (command "_ROTATE" (entlast) "" p1 "-90."))
	  ) ;_ конец progn
	) ;_ конец if

	(setq i (1+ i))
      ) ;_ конец while
    ) ;_ конец progn
    (prompt "\n Не выбраны примитивы типа Line в этом чертеже")
  ) ;_ конец if


  (setvar "osmode" osmd)
;;;  (setvar "CECOLOR" col)
  (setvar "CLAYER" oldl)
  (vla-endundomark adoc)
  (princ)
) ;_ конец defun
;;;--------------------------; функция для окончания слова примитив

(defun dl_sp (i / ii)
			      ; длина списка
  (setq
    ii (strlen (itoa i))
			      ; для определения окончания слова примитив
    ii (atoi (substr (itoa i) ii 1))
  ) ;_ конец setq
			      ;                    (print ii)
  (cond
    ((and (> i 10) (< i 15)) "ов")
    ((= ii 1) "")
    ((and (> ii 1) (< ii 5)) "а")
    ((or (< ii 1) (> ii 4)) "ов")
  )			      ; cond
) ;_ конец defun
(princ "\n:: Type \"nz_restang\" для выполнения ::")

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

Выделение (да и вообще любое форматирование) внутри Lisp-кода здесь не работает. Лучше уж номера строк укажи )))

[Alan]

Сообщение от Кулик Алексей aka kpblc Выделение (да и вообще любое форматирование) внутри Lisp-кода здесь не работает.

Привет. А в предпросмотре работало. Сейчас подправлю

[aafeoktistov]

Я может чего то не понимаю, но созданный прямоугольник не поворачивается. Возможно я не совсем правильно описал задачу. Суть в том что все линии в моем случае в основном либо под 180 либо под 90 градусов. Но вот конечные прямоугольники из них надо повернуть строго на 90 если конечно линия уже не горизонтальная. Извиняюсь за сумбур, просто не пойму как это решить.

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

[Alan]

Сообщение от aafeoktistov Возможно я не совсем правильно описал задачу.

Да, с этим у тебя наверное проблема

Сообщение от aafeoktistov Но вот конечные прямоугольники из них надо повернуть строго на 90 если конечно линия уже не горизонтальная.

Я вроде так и сделал.
Нарисуй несколько (3-4) линий, построй вручную прямоугольники и приложи к посту.

Сообщение от aafeoktistov при выполнении лиспа почему то сбрасываются все настроенные привязки...

Этого НЕ должно быть! Перед построением я запоминаю объектные привязки и после построений возвращаю назад.
Запомнил:
(setq osmd (getvar "osmode"))
Вернул:
(setvar "osmode" osmd)

[aafeoktistov]

Сообщение от Alan Да, с этим у тебя наверное проблема Я вроде так и сделал. Нарисуй несколько (3-4) линий, построй вручную прямоугольники и приложи к посту. Этого НЕ должно быть! Перед построением я запоминаю объектные привязки и после построений возвращаю назад. Запомнил: (setq osmd (getvar "osmode")) Вернул: (setvar "osmode" osmd)

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

П.С. привязки больше не сбрасывает вроде

[Alan]

Сообщение от aafeoktistov Прикладываю файл.

Чертеж, который прислал, использовал как постановку задачи. В нём куча мусора, много слоёв и примитивов, на выключенных слоях, сумашедшие координаты и т.д.. Не стал чистить и т.п.
На новом чертеже вычертил 4 отрезка (они красного цвета). Применил программку. Результат прикладываю

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

Сообщение от aafeoktistov Красным показал как хотелось бы видеть конечный результат.

А с какого перепугу результат должен быть повернут? Поворачивай исходные данные, и дальше уже строй что надо. И, Alan, зачем так сложно? Можно же и без таких мучений обойтись
Как вариант (особо не тестировал):

Код:

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

 (vl-load-com)

(defun c:rect-by-line (/ selset width adoc elist start end ang)
  (if (and (= (type (setq selset (vl-catch-all-apply (function (lambda () (ssget '((0 . "LINE"))))))))
              'pickset
           ) ;_ end of =
           (= (type (setq width (vl-catch-all-apply
                                  (function (lambda ()
                                              (initget 6)
                                              (cond ((getdist "\nВведите ширину создаваемого прямоугольника <40> : "))
                                                    (t 40.)
                                              ) ;_ end of cond
                                            ) ;_ end of lambda
                                  ) ;_ end of function
                                ) ;_ end of vl-catch-all-apply
                    ) ;_ end of setq
              ) ;_ end of type
              'real
           ) ;_ end of =
      ) ;_ end of and
    (progn (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
           (foreach ent ((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
                        )
             (setq elist (entget ent)
                   start (trans (cdr (assoc 10 elist)) 0 1)
                   start (cdr (assoc 10 elist))
                   end   (trans (cdr (assoc 11 elist)) 0 1)
                   end   (cdr (assoc 11 elist))
                   ang   (angle start end)
             ) ;_ end of setq
             (entmakex (vl-remove-if-not
                         (function cdr)
                         (list '(0 . "LWPOLYLINE")
                               '(100 . "AcDbEntity")
                               (assoc 67 elist)
                               (assoc 410 elist)
                               (assoc 8 elist)
                               '(100 . "AcDbPolyline")
                               '(43 . 0)
                               '(90 . 4)
                               (assoc 62 elist)
                               (cons 10 (polar start (- ang (* pi 0.5)) (* width 0.5)))
                               (cons 10 (polar start (+ ang (* pi 0.5)) (* width 0.5)))
                               (cons 10 (polar end (+ ang (* pi 0.5)) (* width 0.5)))
                               (cons 10 (polar end (- ang (* pi 0.5)) (* width 0.5)))
                               '(70 . 1)
                         ) ;_ end of list
                       ) ;_ end of vl-remove-if-not
             ) ;_ end of entmakex
           ) ;_ end of foreach
           (vla-endundomark adoc)
    ) ;_ end of progn
  ) ;_ end of if
  (princ)
) ;_ end of defun

----- добавлено через ~19 мин. -----
Только сейчас сообразил - можно и без vl-remove-if обойтись Но показывать решение сейчас мне лениво.

[aafeoktistov]

Сообщение от Alan Чертеж, который прислал, использовал как постановку задачи. В нём куча мусора, много слоёв и примитивов, на выключенных слоях, сумашедшие координаты и т.д.. Не стал чистить и т.п. На новом чертеже вычертил 4 отрезка (они красного цвета). Применил программку. Результат прикладываю

Я вижу как у Вас получается но у меня почему то с тем же лиспом результат не такой... Можете скинуть Ваш лисп? В любом случае спасибо за помощь.

П.С. На счет поворота это просто попытка решения одной специфической задачи.

[Alan]

Сообщение от Кулик Алексей aka kpblc Alan, зачем так сложно?

Ну у тебя даже ночью ВСЁ просто!!!
А я по стариковски...

----- добавлено через ~57 мин. -----

Сообщение от aafeoktistov у меня почему то с тем же лиспом результат не такой...

Ты же не показал результат, который получается, а прислал хотелку. Я сразу не разобрался, пришлось Алексея aka kpblc будить, чтобы он глянул.
У тебя прямоугольник отскакивает вдаль... потому что у тебя назначена ПСК. Если перевести в Мировую (_UCS), то всё работает с моим опубликованным ЛИСПом.
Вариант для ПСК я подправлю и выложу.

P.S. Алексей, извини. Не стал копаться с исправлениями текста, просто добавил пару строк переназначения _UCS , если пользовательская
Подправленный текст:

Код:

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

 (defun c:nz_restang
		    (/	   i	 oldl  osmd  pi2   pi_2	 rr1   rr2
		     n_l   c_l	 ss    el    p1	   p2	 n_l   angl
		     angl_d list_pt
		    )
    (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  ) ;_ end of vla-startundomark

  (setq	i    0
	oldl (getvar "CLAYER")
	osmd (getvar "osmode")
;;;  (setvar "CECOLOR" col)
	pi2  (/ pi 2)
	pi_2 (/ pi -2)
;;;  ===========; считывание отрезков в список  ======================
;;;	ss   (ssget "_X"
;;;		    '((0 . "LINE"))
;;;	     ) ;_ конец ssget
	rr1  nil
	rr2  nil
  ) ;_ setq
;;;					; если ПСК не мировая
  (if (= (getvar "worlducs") 0)
    (progn
      (setq flag t)
	(command "_UCS" "_W")
    ) ;_ конец progn
  ) ;_ конец if  
(setvar "osmode" 0)
;;; выбор объектов LINE
  (setq ss (ssget '((0 . "LINE"))))

			      ; длина списка
;;;  (princ)
;;;  начало построения прямоугольников
  (if ss
    (progn
      (setq i (sslength ss))
      (prompt (strcat "\nВы выбрали "
		      (itoa i)
		      " примитив"
		      (dl_sp i)
	      ) ;_ конец strcat
      )			      ; prompt &strcat
      (setq i	0
	    n_l	(getreal "\n Введите ширину прямоугольника <40>:")
	    n_l	(if n_l
		  n_l
		  40.
		) ;_ конец if
      ) ;_ конец setq

;;;      цикл по примитивам
      (while (setq el (ssname ss i)) ; el -   примитив 


	(setq p1    (cdr (assoc 10 (entget el)))
	      p2    (cdr (assoc 11 (entget el)))
;;;	      p3 p1
;;;	    n_l	 (atoi (cdr (assoc 8 (entget el))))
	      c_l   (cdr (assoc 8 (entget el)))
	      angl  (angle p1 p2)
;;;			      ; преобразование углов из  радианов в градусы
	      angl_d (* 180 (/ angl pi))
	) ;_ конец setq
	(if (eq n_l 0)
	  nil
	  (progn
	    (setq
	      list_pt (list (polar p1 (- angl pi2) (/ n_l 2))
			    (polar p1 (- angl pi_2) (/ n_l 2))
			    (polar p2 (- angl pi_2) (/ n_l 2))
			    (polar p2 (- angl pi2) (/ n_l 2))
		      ) ;_ конец list
	    ) ;_ конец setq
	    (entmake (list '(0 . "LWPOLYLINE")
			   '(100 . "AcDbEntity")
			   '(67 . 0)
			   '(410 . "Model")
			   (cons 8 c_l)
			   '(100 . "AcDbPolyline")
			   (cons 43 0)
;;;			 (cons 62 3)
;;;			      ;- группа цвета, сейчас "по слою", в слое в котором отрезок
			   (cons 90 (length list_pt))
			   (cons 10 (nth 0 list_pt))
			   (cons 10 (nth 1 list_pt))
			   (cons 10 (nth 2 list_pt))
			   (cons 10 (nth 3 list_pt))
			   '(70 . 1) ;closed pline
		     ) ;_ конец list
	    ) ;_ конец entmake
	    (if	(or (= angl_d 90.) (= angl_d 270.))
	      (command "_ROTATE" (entlast) "" p1 "-90.")
	    ) ;_ конец if
	  ) ;_ конец progn
	) ;_ конец if

	(setq i (1+ i))
      ) ;_ конец while
    ) ;_ конец progn
    (prompt "\n Не выбраны примитивы типа Line в этом чертеже")
  ) ;_ конец if


  (setvar "osmode" osmd)
;;;  (setvar "CECOLOR" col)
  (setvar "CLAYER" oldl)
  ;;;					; если ПСК не мировая
  (if flag
      (command "_UCS" "_P")
  ) ;_ конец if
  
  (vla-endundomark adoc)

  (princ)
) ;_ конец defun
;;;--------------------------; функция для окончания слова примитив

(defun dl_sp (i / ii)
			      ; длина списка
  (setq
    ii (strlen (itoa i))
			      ; для определения окончания слова примитив
    ii (atoi (substr (itoa i) ii 1))
  ) ;_ конец setq
			      ;                    (print ii)
  (cond
    ((and (> i 10) (< i 15)) "ов")
    ((= ii 1) "")
    ((and (> ii 1) (< ii 5)) "а")
    ((or (< ii 1) (> ii 4)) "ов")
  )			      ; cond
) ;_ конец defun
(princ "\n:: Type \"nz_restang\" для выполнения ::")

[aafeoktistov]

Большое Вам человеческое спасибо!)

[Alan]

Сообщение от aafeoktistov Можете скинуть Ваш лисп?

Конечно так красиво ка Алексей я не напишу. Но по его примеру я избавился от командных методов.
А также добавил, что повернутый прямоугольник всегда рисуется от нижнего конца отрезка вправо. См.картинку.
Если надо могу дать откорректированный ЛИСП. Или предыдущее решение устраивает?