Тема: LISP. Растяжение/сжатие 3D тел в указанной плоскости на заданную величину
;|====================================================
Растяжение/сжатие 3D тел в указанной плоскости на заданную величину
Программа Дениса Флюстикова "Stretch_Den"
Попытка сделать по просьбе Владимира Мадюшкина аналог программы
"QD3D STRETCH", триал версия предсталена на
http://www.cadopolis.com/autocad_addons/quick-draw-3d-stretch.shtml
Программа тестировалась на AutoCAD 2008/09
Макрос для кнопки: ^C^C^P(load "Stretch3D_Den");Stretch3D_Den
Замечания и предложения по адресу fd-@mail.ru
====================================================|;
(defun C:Stretch3D_Den (/ *error* cecolor osmode aa1
aa2 aa3 aa4 aa5 aa6 aa7 aa8 aa9)
(setq cecolor (getvar "CECOLOR")
osmode (getvar "OSMODE")
aa1 (getvar "VIEWDIR"))
(if (and (equal (car aa1) 0 0.00001)
(equal (cadr aa1) 0 0.00001)
(> (caddr aa1) 0))(progn
(if (setq aa1 (ssget "_i" '((0 . "3DSOLID"))))
(princ (strcat "\nВыбрано объектов: " (itoa (sslength aa1))))(progn
(princ "\nВыбор 3D тел для преоразования")
(setq aa1 (ssget '((0 . "3DSOLID"))))
))
(if aa1
(if (setq aa2 (getpoint "\nПервая точка плоскости растяжения/сжатия:"))
(if (setq aa3 (getpoint aa2 "\nВторая точка плоскости (плоскость перпендикулярна XY):"))(progn
(grdraw aa2 aa3 7)
(vl-load-com)
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(defun *error* (msg)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (and (>= (atof (getvar "ACADVER")) 16.2)(< (atof (getvar "ACADVER")) 17.1))
(vla-sendcommand (vla-get-activedocument
(vlax-get-acad-object)) "_.undo 1 ")
(command nil nil nil nil "_.undo" 1))
(princ "\nВыход во время обработки данных\n")
)
(command "_.undo" "_m"
"_ucs" "_z" aa2 aa3)
(setvar "ORTHOMODE" 1)
(initget 1)
(if (vl-catch-all-error-p
(setq aa4 (vl-catch-all-apply 'getpoint
(list "\nПервая точка вектора, определяющая сторону растяжения/сжатия:"))))
(setq aa4 nil)(progn
(initget 1)
(if (vl-catch-all-error-p
(setq aa5 (vl-catch-all-apply 'getpoint
(list aa4 "\nВторая точка вектора, определяющая растяжение или сжатие и их величину:"))))
(setq aa4 nil)
(setq aa7 (trans (mapcar '+ aa4 '(0 0)) 1 0)
aa5 (trans (mapcar '+ aa5 '(0 0)) 1 0)
aa4 (distance aa7 aa5))
)))
(redraw)
(command "_.undo" "_b")
(if aa4 (progn
(setq aa7 (trans aa7 0 1)
aa5 (trans aa5 0 1))
(if (> (sin (angle aa2 aa3)) 0)
(setq aa6 aa2 aa2 aa3 aa3 aa6))
(if (> (sin (- (angle aa2 aa3)(angle aa2 aa7))) 0)
(setq aa6 aa2 aa2 aa3 aa3 aa6))
(if (> (distance aa2 aa7)(distance aa2 aa5))
(setq aa4 (- aa4)))
(setq aa9 (polar '(0 0 0) (+ (angle aa2 aa3)(/ pi 2)) aa4))
(setvar "OSMODE" 0)
(repeat (setq aa5 (sslength aa1))
(setq aa5 (1- aa5)
aa6 (ssname aa1 aa5)
aa7 (entlast)
aa8 (entget aa6))
(while (entnext aa7)
(setq aa7 (entnext aa7)))
(if (> aa4 0)(progn
(command "_.section" aa6 "" "3" aa2 aa3 "@0,0,1")
(if (setq aa7 (entnext aa7))(progn
(if (/= (cdr (assoc 70 (tblsearch "Layer" (cdr (assoc 8 aa8))))) 4)(progn
(if (and (>= (atof (getvar "ACADVER")) 16)(assoc 420 aa8))
(setq aa8 (cdr (assoc 420 aa8))
aa8 (strcat "RGB:" (rtos (logand (lsh aa8 -16) 255)) ","
(rtos (logand (lsh aa8 -8) 255)) ","
(rtos (logand aa8 255))))
(if (setq aa8 (assoc 62 aa8))
(setq aa8 (rtos (cdr aa8)))
(setq aa8 "256")))
(setvar "CECOLOR" aa8)))
(command "_.extrude" aa7 "" "_d" '(0 0 0) aa9)
(setq aa8 (ssadd))
(while (entnext aa7)
(setq aa7 (entnext aa7)
aa8 (ssadd aa7 aa8)))
(command "_.slice" aa6 "" "3" aa2 aa3 "@0,0,1" "_b"
"_.move" (entlast) "" '(0 0 0) aa9
"_.union" aa6 aa8 (entlast) "")
)
(command "_.move" aa6 "" '(0 0 0) aa9)
)
)(progn
(if (/= (cdr (assoc 70 (tblsearch "Layer" (cdr (assoc 8 aa8))))) 4)(progn
(if (and (>= (atof (getvar "ACADVER")) 16)(assoc 420 aa8))
(setq aa8 (cdr (assoc 420 aa8))
aa8 (strcat "RGB:" (rtos (logand (lsh aa8 -16) 255)) ","
(rtos (logand (lsh aa8 -8) 255)) ","
(rtos (logand aa8 255))))
(if (setq aa8 (assoc 62 aa8))
(setq aa8 (rtos (cdr aa8)))
(setq aa8 "256")))
(setvar "CECOLOR" aa8)))
(command "_.slice" aa6 "" "3" aa2 aa3 "@0,0,1" "_b")
(if (setq aa7 (entnext aa7))(progn
(command "_.move" aa7 "" '(0 0 0) aa9
"_.slice" aa7 "" "3" aa2 aa3 "@0,0,1" "_b"
"_.erase" aa7 "")
(if (setq aa7 (entnext aa7))
(command "_.union" aa6 aa7 ""))
)
(command "_.move" aa6 "" '(0 0 0) aa9)
)
))
)
))
(setvar "CECOLOR" cecolor)
(setvar "OSMODE" osmode)
(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
))))
)
(princ "\nУстановите один из стандартных ортогональных видов")
)
(princ)
)
