[b_anton]

Доброго вечера!

Мастера нужна помощь в написании лиспа. Имеется некий многоугольник в виде полилинии. Хочется построить прямоугольники в количестве равном количеству сторон многоугольника. Ширина каждого прямоугольника равна длине каждой стороны многоугольника. Высота одинаковая и вводится руками. Прямоугольники распологаюся через определенное растояние (например через 1000 мм) на одной линии с базовой точкой указанной на экране.
И (если это возможно) хотелось бы добавить обозначение углов многоугольника в соответствие с обозначением углов прямоугольников.

Заранее спасибо за любую помощь!
ACAD 2010

результат на картинке. (ЗЫ: простановка размеров не нужна - они для понимания)

[Олег (jr.)]

Сообщение от b_anton Потом сам попробую нумерацию добавить, может чего получиться

Покажи картинку

[b_anton]

картинка в самом первом посте. Обозначение углов

[Олег (jr.)]

Пробуй с обозначениями

Код:

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

;;; Programm for the dimensioning of all the polygon/polyline segments
;;; and creating the running rectangles by length of every segment
;;; Polyline must be closed or opened
;;; Copyrights (c) 2005 Fatty T.O.H. * all rights removed
;;; A2005 / Windows XP / 7
;;; Thanks to Matt W. for the correction

;;; possible macro for button:
;;; ^C^C^P(progn (terpri)(if (not C:RECS)(load "RECS.lsp"))(princ)(C:RECS))
;;; last edited 05/03/2013

(defun C:RECS (/ *Error* ;|*Debug*|;  acsp adoc cnt coors epar idx get-vexs gap group-by-num hgt
	                               num mark p pick pl pos q range segm sides spar ss tht wid)
 
;thanks to Robert R.Bell for the credit of error handler function
  (vl-load-com)
  (defun *Error* (msg)
    
  (cond	((not msg))
	((member msg '("Function cancelled" "quit / exit abort")))
	((princ (strcat "\nError: " msg))
	 ;|(cond (*Debug* (vl-bt)))|; ; for debug only
	)
  )
(setvar "nomutt" 0)
  (vla-endundomark
	(vla-get-activedocument (vlax-get-acad-object))
      )
)

  ;; helpers : 

  ;; gile
    (defun range (lst from to / result)
  (repeat (1+ (- (setq to (min (1- (length lst)) to)) from))
    (setq result (cons (nth to lst) result)
	  to	 (1- to)
    ) ;_ end of setq
  ) ;_ end of repeat
  result
) ;_ end of defun
  
  (if (< (atof (getvar "ACADVER")) 15.06)(progn
  (alert "Impossible to use this lisp \nin version less than A2000")(exit)(princ))
  (progn
  (vl-load-com)
  (or adoc (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (or acsp (setq acsp
		  (if (or (= (getvar "TILEMODE") 1)
			  (> (getvar "CVPORT") 1))
  (vla-get-modelspace adoc)
  (vla-get-paperspace adoc)
  )
	)
      )
  ;; 			основная чaсть программы			 ;;
  (princ "\nВыбрать полигон")
  (setvar "nomutt" 1)
  (if 
  (setq ss (ssget "_:S:E:L" '((0 . "*POLYLINE"))))
  (progn
   (vla-startundomark adoc)
   (setvar "nomutt" 0)
  (setq	pl (vlax-ename->vla-object (setq pline (ssname ss 0))))
 (setq pick(cadr (last (last (ssnamex ss)))))
 
      (setq pick (vlax-curve-getclosestpointto pl pick))
      (setq pos (fix (vlax-curve-getparamatpoint pl pick)))
   (setq mark (getstring "\nСуффикс обозначения точек: "))
   (setq tht (getdist (strcat "\nВысота текста <" (rtos (getvar "textsize") 2 1) ">: ")))
   (if (not tht)(setq tht (getvar "textsize")))
   (setq epar (vlax-curve-getendparam pl)
	 spar (vlax-curve-getstartparam pl)
	 sides nil)
   (setq idx 0)
   (while (< spar epar)
    ; (if (< spar (- epar 1))
    (vl-catch-all-apply
       'vla-addtext (list acsp (strcat mark (itoa (setq idx (1+ idx)))) (vlax-3d-point (vlax-curve-getpointatparam pl spar)) tht))
     (setq segm (- (vlax-curve-getdistatparam pl (1+ spar))(vlax-curve-getdistatparam pl spar)))
     (setq sides (cons segm sides))
     (setq spar (1+ spar)))
     (setq sides (reverse sides))

      (if (not (zerop pos))
	(setq sides (append (range sides pos (1- (length sides)))(range sides 0 (- pos 1))))
	)
      (setq num (length sides))
      (setq hgt (getdist "\nВысота прямоугольников: "))
      (setq gap (getdist "\nРасстояние между прямоугольниками: "))
      (setq p (getpoint "\nПервая точка: "))
      (setq cnt 0)
      (repeat num
	(setq wid (nth cnt sides))
	(entmakex
	  (append
	    (list '(0 . "LWPOLYLINE")
		  '(100 . "AcDbEntity")
		  '(100 . "AcDbPolyline")
		  '(90 . 4)
		  '(70 . 1)
		  (cons 10 (setq p (trans p 1 0)))
	    ) ;_ end of list
	    (mapcar
	      (function (lambda (x) (cons 10 (mapcar '+ p x))))
	      (list (list wid 0. 0.) (list wid hgt 0.) (list 0. hgt 0.))
	    ) ;_ end of mapcar

	  ) ;_ end of append
	) ;_ end of entmakex
	(setq p (mapcar '+ p (trans (list (+ wid gap) 0. 0.) 1 0)))
	(setq cnt (1+ cnt))
      ) ;_ end of repeat 
  	)
  	)
	)
	)
  (*Error* nil)  
  (princ)
)
 
(prompt "\n\t---\tСтарт команды: RECS  \t---")
(prin1)
 (or (vl-load-com)(princ))

[b_anton]

Олег (jr.) жму руку. работает на ура!

[Олег (jr.)]

Ну слава Богу,
Пока