[LISP]点选line/arc串接与之首尾相连的line/arc成多义线

torcky

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Function: Select an Entity and program will add segments to polyline
;from EndPoint and StartPoint still the polyline is a loop or end;
;**********************************************
;Note isFlag: 0-- add segments to polyline from EndPoint
;             1-- do from StartPoint
;             2-- do nothing
;**********************************************
;In curve if epoint0(EndPoint)=spoint0(StartPoint)
;            then the curve is a loop;
;*******************
;AssocStSels0: a flag to determine there is segments or not;
;

(defun c:aw ( / ssa ent-p AssocStObj ColorChange) ; main
  (command "undo" "be")
  (setq oldos (getvar "osmode"))
  (setvar "osmode" 0 )
  (setvar"cmdecho" 0)

  (defun joinline(entline ); determine
  (setq epoint0(vlax-curve-getEndPoint(vlax-ename->vla-object entline)))
  (setq spoint0(vlax-curve-getstartPoint(vlax-ename->vla-object entline)))
  (if (vl-every '< (mapcar 'abs (mapcar '- epoint0 spoint0) )'(0.001 0.001 0.001))
    (setq AssocStObj nil)
    (progn
      (cond
 ((= 0 isFlag)(joinline1 entline epoint0 ))
        ((= 1 isFlag)(joinline1 entline spoint0 ))
 )
      )
    )
  )

  (defun joinline1(entline spoint ); do
  (setq pp1 (mapcar '+ spoint '(0.001 0.001 0))
        pp2 (mapcar '- spoint '(0.001 0.001 0))
        AssocStSels (ssget "c" pp1 pp2)
        AssocStSels(ssdel entline AssocStSels)
        AssocStSels0(sslength AssocStSels))
  (if (and(= 1 isFlag)(= 0 AssocStSels0)) (setq isFlag 2))
  (if (and(= 0 isFlag)(= 0 AssocStSels0)) (setq isFlag 1))
  (if   (= 1 AssocStSels0)
    (progn
      (setq AssocStObj (ssname AssocStSels 0))

(setq AssPro(cdr(assoc 0 (entget AssocStObj))))
      (if (or (= ent-p "LWPOLYLINE") (= ent-p "POLYLINE"))
 (progn
   (command "pedit" entline "j" AssocStObj "" "")
   (setq ssa (ssadd ))
   (setq ssa (ssname (ssget "l")0))
   (setq ent-p (cdr (assoc 0 (entget ssa))))
 )
 (progn
   (command "pedit" entline "y" "j" AssocStObj "" "")
   (setq ssa (ssadd ))
   (setq ssa (ssname (ssget "l")0))
   (setq ent-p (cdr (assoc 0 (entget ssa))))
 )
      )

(if (= AssPro "SPLINE")

(cond

((= 0 isFlag )(setq isFlag 1))

((= 1 isFlag )(setq isFlag 2))

(t(setq isFlag 2))

)

)
    )
        )

(if (= 2 isFlag) (setq AssocStObj nil)(setq AssocStObj t))

  (if (= 0 isFlag) (setq AssocStSels nil))
  )
 
  (setq ssa (car(entsel  "\nPick a Line:"))
   ent-p (cdr (assoc 0 (entget ssa))))
  (setq AssocStSels0 0 isFlag 0)
  (if  (or(= ent-p "LINE")(= ent-p "ARC")(= ent-p"LWPOLYLINE" ))
    (progn
      (joinline ssa )
      (while AssocStObj
 (joinline ssa )
 )

(initget "Yes No" )
  (setq ColorChange (getkword "\nChange the LWPOLYLINE's Color into Red[Yes/No]<N>:"))
  (cond
    ((= ColorChange "Yes")(command "change" ssa "" "p" "c" 230 ""))
    )

    )
    (prompt "\nPlease Select a line or arc!\n")
    )
    (setvar "osmode" oldos)
  (command "undo" "e")
  (prompt "\n*****Designed by TANG.J.Z!*****")
  (princ)
)

紫云飞

不错哦，好东东

HuaiYu

学习中.....

Ea

Cad2006 -> Join

xtjd

;我也来一个

;只有同一个图层的才可以串联

(defun c:qj(/ ss ss_all ped)
  (setvar "cmdecho" 0)
  (setq ped (getvar "peditaccept"))
  (setvar "peditaccept" 1)
  (setq ss (entsel))
  (if ss
    (if (/= (cdr (assoc 70 (entget (car ss)))) 1)
      (progn
        (setq ss_all (ssget "X" (list(assoc 8 (entget (car ss))))))
        (command ".pedit" ss "j" ss_all "" "")
      )
    )
  )
  (setvar "peditaccept" ped)
  (prin1)
)

HuaiYu

我也来一个简单一点的，请指点

(defun c:dx (/ en old-cmdecho flag pt1 pt2 pt3 pt4)
  (vl-load-com)
  (setq *AcadObj*      (vlax-get-acad-object)
 *AcadDocument* (vla-get-activedocument *AcadObj*)
 *mspace*       (vla-get-modelspace *AcadDocument*)
  )
  (setq en     (car (entsel "Select object: "))
 old-cmdecho (getvar "cmdecho")
 flag     t
  )
  (vla-startundomark *acadDocument*)
  (setvar "cmdecho" 0)
  (if (and en (not (vlax-curve-isclosed (vlax-ename->vla-object en))))
    (progn
      (setq pt1 (vlax-curve-getstartpoint (vlax-ename->vla-object en))
     pt2 (vlax-curve-getendpoint (vlax-ename->vla-object en))
      )
      (while flag
 (setq ss1 (ssget "c" pt1 pt2))
 (if (equal (assoc 0 (entget en)) (cons 0 "LWPOLYLINE"))
   (command "pedit" en "j" ss1 "" "")
   (command "pedit" en "y" "j" ss1 "" "")
 )
 (setq en (entlast))
 (setq pt3 (vlax-curve-getstartpoint (vlax-ename->vla-object en))
       pt4 (vlax-curve-getendpoint (vlax-ename->vla-object en))
 )
 (if (or (and (equal pt1 pt3) (equal pt2 pt4)) (vlax-curve-isclosed (vlax-ename->vla-object en)))
   (setq flag nil)
   (setq pt1 pt3
  pt2 pt4
   )
 )    ; end if
      )     ; end while
    )     ;end progn
  )     ;end if 
  (setvar "cmdecho" old-cmdecho)
  (vla-endundomark *AcadDocument*)
  (prin1)
)

torcky

判断是否继续的条件更简单了。很好！

但是要考虑若有spline夹在其中可能会造成死循环。你再试试！

 

HuaiYu

是的了，还是 你 考虑的周详，我把 判断语句改成

(and en    ;不为空
    (not (vlax-curve-isclosed (vlax-ename->vla-object en))) ;不闭合
    (not (equal (vla-get-objectname (vlax-ename->vla-object en)) "AcDbSpline")) ;不为 Spline
      )就可以避免了

lijiao

4楼的方法最简单。