Тема: LISP. Прерисовка полилинии с возможностью ее продолжения
Указываете полилинию и програма ее перерисовывает с (вроде) всеми свойствами исходной полилинии, исходная полилиния удаляется. Возможны глюки: функция коректно работает в мировой ПСК и так сказать паралельной ей.
(defun c:con_pline (/ ARC ELEVATIONS ENTITY ENTITY_LST
LAST_POINT OLD_ANGDIR OLD_CMDECHO
OLD_OSMODE OLD_PLINEWID OLD_PROPERTIS)
(setq old_osmode (getvar "osmode"))
(setq old_plinewid (getvar "plinewid"))
(setq old_cmdecho (getvar "cmdecho"))
(setq old_angdir (getvar "angdir"))
(cond
((vl-catch-all-error-p
(setq entity
(vl-catch-all-apply 'entsel
'("\nSelect pline for continue: "))))
(princ))
((not entity) (princ))
((not (eq "LWPOLYLINE" (cdr (assoc 0
(setq entity_lst (entget (car entity)))))))
(princ "\nThis not pline.") (princ))
((not (equal '(210 0.0 0.0 1.0)
(assoc 210 entity_lst)))
(princ "\nThis pline is not in WCS.") (princ))
(t
(setq old_propertis (+runa_mopc (car entity)))
(setvar "cmdecho" 0)
(setvar "angdir" 0)
(setq elevations (list (cdr (assoc 38 entity_lst))))
(entdel (car entity))
(setq entity_lst (vl-remove-if-not
(function
(lambda (x)
(member (car x)
'(10 40 41 42))))
entity_lst)
last_point (nth (- (length entity_lst) 4)
entity_lst)
entity_lst (reverse (cddddr
(reverse entity_lst))))
(setvar "osmode" 0)
(vl-cmdf "_pline")
(mapcar
(function (lambda (x)
(cond
((= (car x) 10)
(vl-cmdf (trans (append (cdr x) elevations) 0 1)))
((= (car x) 40) (vl-cmdf "_w" (cdr x)))
((= (car x) 41) (vl-cmdf (cdr x)))
((= (car x) 42)
(cond
((zerop (cdr x)) (if arc (progn (vl-cmdf "_l")
(setq arc nil))))
(arc (vl-cmdf "_a" (/ (* 720 (atan (cdr x))) pi)))
(t (vl-cmdf "_a" "_a" (/ (* 720 (atan (cdr x))) pi))
(setq arc t))
))
)))
entity_lst)
(setvar "angdir" old_angdir)
(setvar "cmdecho" old_cmdecho)
(vl-cmdf (trans (cdr last_point) 0 1))
(setvar "osmode" old_osmode)
(while (+runa_bit_in_flag 1 (getvar "CMDACTIVE"))
(vl-cmdf pause))
(setvar "cmdecho" 0)
(+runa_mopc old_propertis)
(setvar "plinewid" old_plinewid)
(setvar "cmdecho" old_cmdecho)
)
)
)(defun +runa_bit_in_flag (bit flag / ) ;| (+runa_bit_in_flag 1 3) |; (= (logand bit flag) bit))
(defun +runa_mopc (ent_name /
C_COLOR C_LAYER C_LINE_TYPE
C_LINE_TYPE_SCALE
C_LINE_WEIGHT OLD_PROPERTIS I)
;|
(+runa_mopc (car (entsel)))
(+runa_mopc (+runa_mopc (car (entsel))))
Reval - old propertis (layer linetype scale etc.)
|;
(setq old_propertis (list (cons 8 (getvar "clayer"))
(cons 6 (getvar "celtype"))
(cons 62 (getvar "cecolor"))
(cons 370 (getvar "celweight"))
(cons 48 (getvar "celtscale"))
))
(if (not (listp ent_name)) (setq ent_name (entget ent_name)))
(setq c_layer (cdr (assoc 8 ent_name)))
(setq c_line_type (if (setq i (assoc 6 ent_name))
(cdr i) "BYLAYER"))
(setq c_color
(if (setq i (assoc 62 ent_name))
(if (eq (type (setq i (cdr i))) 'STR) i (itoa i))
"BYLAYER"))
(setq c_line_weight (if (setq i (assoc 370 ent_name))
(cdr i) -1))
(setq c_line_type_scale (if (setq i (assoc 48 ent_name))
(cdr i) 1.0))
(setvar "clayer" c_layer)
(setvar "celtype" c_line_type)
(setvar "cecolor" c_color)
(setvar "celweight" c_line_weight)
(setvar "celtscale" c_line_type_scale)
old_propertis
)Две последние функции - так сказать библиотечные. Коментарии - крякозяблы пришлось вырезать.
Вызов функции _CON_PLINE
Макрос ^C^C_con_pline
и т.д.
Перед вызовом нужно загрузить все три функции.
ЗЫ. Похоже влезло как надо. Ваши выводы господа?
