楼主能否给出那个经典的多段线相接的程序或者链接？
沾楼主的光，请楼主不要介意，发个支持直线、圆弧、多义线的(defun c:tt ( / ss pda en fuzz val)
(vl-load-com)
(setq val (getvar "cmdecho"))
(setvar "cmdecho" 0)
(if (and (setq en (car (entsel "\n选择第一条线:")))
(wcmatch (cdr (assoc 0 (entget en))) "ARC,LINE,*POLYLINE")
(setq en (vlax-ename->vla-object en))
(/= "AcDb3dPolyline" (vla-get-ObjectName en))
)
(progn
(if (null (setq fuzz (getdist "\n输入模糊距离<0>: ")))
(setq fuzz 0)
)
(setq ss (ssadd))
(foreach item
(setq lst (ChainSelectFromAny en (+ fuzz 1e-6)))
(ssadd (vlax-vla-object->ename item) ss)
)
(mip:mark)
(vl-catch-all-apply
'(lambda ()
(if (setq pda (getvar "PEDITACCEPT"))
(progn
(setq pda (getvar "peditaccept"))
(setvar "peditaccept" 1)
(command "_pedit" "_M" ss "" "_j" "_j" "_b" fuzz "")
(setvar "peditaccept" pda)
)
(command "_pedit" "_M" ss "" "_Y" "_j" "_j" "_b" fuzz "")
)
)
)
(setq lst (vl-remove-if 'vlax-erased-p lst))
(if (setq ss nil ss (mip:get-last-ss))
(progn
(if lst (foreach item lst (ssadd (vlax-vla-object->ename item) ss)))
(setq fuzz 0)
(while (setq en (ssname ss fuzz))
(if (/= (cdr (assoc 0 (entget en))) "LWPOLYLINE")
(ssdel en ss)
(setq fuzz (1+ fuzz))
)
)
(sssetfirst ss ss)
)
)
(setq ss nil)
)
(princ "\n需选择LINE, ARC or Polyline")
)
(setvar "cmdecho" val)
(princ)
)
(defun ChainSelectFromAny (pt fuzz / chain_list couple ept line_list ln loop pda spt ss ln1 cycl)
(vl-load-com)
(cond
((= (type pt) 'ENAME)
(setq ln (vlax-ename->vla-object pt)
pt nil
)
)
((= (type pt) 'VLA-OBJECT)
(setq ln pt pt nil)
)
(t nil)
)
(if (setq ss (ssget "_I") ss nil ss (ssget "_X" '((0 . "ARC,LINE,*POLYLINE"))))
(progn
(if pt
(progn
(setq ln1
(vla-addLine
(if (and (zerop (vla-get-ActiveSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
(= :vlax-false (vla-get-MSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
)
(vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(vlax-3D-point pt)
(vlax-3D-point (mapcar '- pt '(1 1 0)))
)
)
(setq ln ln1)
)
)
(setq spt (vlax-curve-getStartPoint ln)
ept (vlax-curve-getEndPoint ln)
)
(setq line_list (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
chain_list nil
chain_list (cons ln chain_list)
)
(setq line_list (vl-remove-if '(lambda (x) (eq "AcDb3dPolyline" (vla-get-ObjectName x))) line_list))
(setq loop t cycl 0)
(while loop
(while
(setq couple
(vl-remove-if-not
(function (lambda (x)
(or (equal (vlax-curve-getStartPoint x) (vlax-curve-getStartPoint ln) fuzz)
(equal (vlax-curve-getStartPoint x) (vlax-curve-getEndPoint ln) fuzz)
(equal (vlax-curve-getEndPoint x) (vlax-curve-getStartPoint ln) fuzz)
(equal (vlax-curve-getEndPoint x) (vlax-curve-getEndPoint ln) fuzz)
)
)
)
line_list
)
)
(grtext -1 (strcat "正在连线，请稍等 - " (itoa (setq cycl (1+ cycl)))))
(if couple
(progn
(setq chain_list (append couple chain_list))
(setq line_list (vl-remove ln line_list))
(setq ln (car chain_list))
)
(setq line_list (cdr line_list))
)
)
(setq loop nil)
)
)
)
(setq chain_list (vl-remove ln1 chain_list))
(if (= (type ln1) 'VLA-OBJECT)
(vl-catch-all-apply 'vla-erase (list ln1))
)
(vl-cmdf "_.redraw")
chain_list
)
(defun mip:mark (/ val)
(setq val (getvar "cmdecho")) (setvar "cmdecho" 0)
(if (setq *mip:mark (entlast)) nil
(progn (entmake '((0 . "point") (10 0.0 0.0 0.0)))
(setq *mip:mark (entlast))
(entdel *mip:mark)
)
)
(setvar "cmdecho" val)
(princ)
)
(defun mip:get-last-ss (/ ss tmp val)
(setq val (getvar "cmdecho"))
(setvar "cmdecho" 0)
(if *mip:mark
(progn
(setq ss (ssadd))
(while
(setq *mip:mark (entnext *mip:mark))
(ssadd *mip:mark ss)
)
(command "._select" ss "")
(setq tmp ss ss nil)
)
(alert "*mip:mark not set. \n run (mip:mark) before mip:get-last-ss.")
)
(setvar "cmdecho" val)
tmp
)
不可能，我用的也是cad2006
支持框选。
(defun hh:ELg (/ PET SS1 ss)
(setq ss (ssget '((0 . "ARC,*LINE"))))
(setq pet (getvar "PEDITACCEPT"))
(setvar "PEDITACCEPT" 1)
(command "select" ss "")
(while (setq ss1 (ssget "_p" '((0 . "ARC,*LINE"))))
(command "_pedit" (ssname ss1 0) "j" ss1 "" "")
)
(setvar "PEDITACCEPT" pet)
(princ "\n* 圆、线、弧已经转成多段线 *\n")
)
自贡黄明儒 发表于 2012-6-12 11:33 static/image/common/back.gif
(defun hh:ELg (/ PET SS1 ss)
(setq ss (ssget '((0 . "ARC,*LINE"))))
(setq pet (getvar "PEDITAC ...
谢谢指点！
zyhandw 发表于 2012-6-11 17:48 static/image/common/back.gif
谢谢指点！
(defun c:pj ( / peditaccept ss )
(if (setq ss (ssget "_:L" '((0 . "ARC,LINE,LWPOLYLINE"))))
(progn
(setq peditaccept (getvar 'peditaccept))
(setvar 'peditaccept 1)
(command "_.pedit" "_M" ss "" "_J" "" "")
(setvar 'peditaccept peditaccept)
)
)
(princ)
)
1993063 发表于 2012-6-13 12:19 static/image/common/back.gif
(defun c:pj ( / peditaccept ss )
(if (setq ss (ssget "_:L" '((0 . "ARC,LINE,LWPOLYLINE"))))
...
谢谢回复，不过，试用并看了下程序，该程序好像只适合有共同点的线的连接吧
在CAD2004中其实就有连接多段线的功能了。
PEDIT命令有一个“J”参数，还可以指定模糊距离和合并类型。如下：
输入模糊距离或 [合并类型(J)] <0.0000>:
输入合并类型 [延伸(E)/添加(A)/两者都(B)] <延伸>:
程序很好，希望在写一个合并共线但是直线顶点不相接的直线的程序，谢谢啦~~