非常感谢你们两个！ 你好，Marko，
是否可以自定义lisp，以便在新线段上添加点和顶点。我的意思是在每个插入点下有一个多段线顶点。
非常感谢。 (defun c:divplsegs+vtxs ( / add_vtx trunc clean_poly ss ssh mind i pl ep k j dk dj d n dd m p ptlst )
(vl-load-com)
(defun add_vtx ( obj add_pt ent_name / bulg )
(vla-addVertex
obj
(1+ (fix add_pt))
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 1))
(list
(car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
(cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
)
)
)
)
(setq bulg (vla-GetBulge obj (fix add_pt)))
(vla-SetBulge obj
(fix add_pt)
(/
(sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
(cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
)
)
(vla-SetBulge obj
(1+ (fix add_pt))
(/
(sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
(cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
)
)
(vla-update obj)
)
(defun trunc ( expr lst )
(if (and lst
(not (equal (car lst) expr))
)
(cons (car lst) (trunc expr (cdr lst)))
)
)
(defun clean_poly ( ent / e_lst p_lst vtx1 vtx2 )
(setq e_lst (entget ent))
(cond
((= "LWPOLYLINE" (cdr (assoc 0 e_lst)))
(setq p_lst (vl-remove-if-not
'(lambda (x)
(or (= (car x) 10)
(= (car x) 40)
(= (car x) 41)
(= (car x) 42)
)
)
e_lst
)
e_lst (vl-remove-if
'(lambda (x)
(member x p_lst)
)
e_lst
)
)
(if (= 1 (cdr (assoc 70 e_lst)))
(while (equal (car p_lst) (assoc 10 (reverse p_lst)))
(setq p_lst (reverse (cdr (member (assoc 10 (reverse p_lst))
(reverse p_lst)
)
)
)
)
)
)
(while p_lst
(setq e_lst (append e_lst (trunc (assoc 10 (cdr p_lst)) p_lst))
p_lst (member (assoc 10 (cdr p_lst)) (cdr p_lst))
)
)
(entmod e_lst)
)
((and (= "POLYLINE" (cdr (assoc 0 e_lst)))
(zerop (logand 240 (cdr (assoc 70 e_lst))))
)
(setq e_lst (cons e_lst nil)
vtx1 (entnext ent)
vtx2 (entnext vtx1)
)
(while (= (cdr (assoc 0 (entget vtx1))) "VERTEX")
(if (= (cdr (assoc 0 (entget vtx2))) "SEQEND")
(if
(or (not
(equal (assoc 10 (entget vtx1))
(assoc 10 (last (reverse (cdr (reverse e_lst)))))
)
)
(zerop (logand 1 (cdr (assoc 70 (last e_lst)))))
)
(setq e_lst (cons (entget vtx1) e_lst))
)
(if
(not
(equal (assoc 10 (entget vtx1)) (assoc 10 (entget vtx2)) 1e-9)
)
(setq e_lst (cons (entget vtx1) e_lst))
)
)
(setq vtx1 vtx2
vtx2 (entnext vtx1)
)
)
(setq e_lst (reverse (cons (entget vtx1) e_lst)))
(entdel ent)
(mapcar 'entmake e_lst)
)
(T (princ "\nEntité non valide."))
)
(princ)
)
(prompt "\nSelect 2d polylines...")
(setq ss (ssget "_:L" '((0 . "*POLYLINE") (-4 . "<not") (-4 . "&=") (70 .(-4 . "not>"))))
(setq ssh (ssadd))
(initget 7)
(setq mind (getdist "\nSpecify min. distance for segments division: "))
(setq i -1)
(while (setq pl (ssname ss (setq i (1+ i))))
(if (eq (cdr (assoc 0 (entget pl))) "POLYLINE")
(progn
(command "_.convertpoly" "_l" pl "")
(ssadd pl ssh)
)
)
(setq ep (vlax-curve-getendparam pl))
(setq k -1.0)
(while (< (setq k (1+ k)) ep)
(setq j (1+ k))
(setq dk (vlax-curve-getdistatparam pl k))
(setq dj (vlax-curve-getdistatparam pl j))
(setq d (- dj dk))
(setq n (fix (/ d mind)))
(if (> n 1)
(progn
(setq dd (/ d (float n)))
(setq m -1.0)
(repeat n
(setq p (vlax-curve-getpointatdist pl (+ dk (* dd (setq m (1+ m))))))
(entmake (list '(0 . "POINT") (cons 10 p)))
(setq ptlst (cons p ptlst))
)
)
(progn
(setq p (vlax-curve-getpointatdist pl dk))
(entmake (list '(0 . "POINT") (cons 10 p)))
(setq ptlst (cons p ptlst))
)
)
)
(entmake (list '(0 . "POINT") (cons 10 (vlax-curve-getendpoint pl))))
(setq ptlst (cons p ptlst))
(foreach p (reverse ptlst)
(vl-catch-all-apply 'add_vtx (list (vlax-ename->vla-object pl) (vlax-curve-getparamatpoint pl (vlax-curve-getclosestpointto pl p)) pl))
)
(setq ptlst nil)
(clean_poly pl)
)
(setq i -1)
(while (setq pl (ssname ssh (setq i (1+ i))))
(command "_.convertpoly" "_h" pl "")
)
(princ)
)
M.R。
页:
1
[2]