共线直线并批量连接-------多段线连接-------Join

zyhandw · 发表于 2012-6-11 09:18:51

楼主能否给出那个经典的多段线相接的程序或者链接？

gzxl · 发表于 2012-6-11 13:34:50

沾楼主的光，请楼主不要介意，发个支持直线、圆弧、多义线的

(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
)

(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 
)

gzxl · 发表于 2012-6-11 21:31:04

不可能，我用的也是cad2006

smartstar · 发表于 2012-6-12 06:09:40

支持框选。

自贡黄明儒 · 发表于 2012-6-12 11:33:07

(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")
)

zyhandw · 发表于 2012-6-12 11:48:51

自贡黄明儒发表于 2012-6-12 11:33
(defun hh:ELg (/ PET SS1 ss)
(setq ss (ssget '((0 . "ARC,*LINE"))))
(setq pet (getvar "PEDITAC ...

谢谢指点！

1993063 · 发表于 2012-6-13 12:19:10

zyhandw 发表于 2012-6-11 17:48
谢谢指点！

(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)
)

zyhandw · 发表于 2012-6-13 14:38:44

1993063 发表于 2012-6-13 12:19
(defun c:pj ( / peditaccept ss )
(if (setq ss (ssget "_:L" '((0 . "ARC,LINE,LWPOLYLINE"))))
...

谢谢回复，不过，试用并看了下程序，该程序好像只适合有共同点的线的连接吧

caddog · 发表于 2012-6-14 10:43:45

在CAD2004中其实就有连接多段线的功能了。
PEDIT命令有一个“J”参数，还可以指定模糊距离和合并类型。如下：
输入模糊距离或 [合并类型(J)] <0.0000>:
输入合并类型 [延伸(E)/添加(A)/两者都(B)] <延伸>:

tm20038175 · 发表于 2012-6-17 12:59:24

程序很好，希望在写一个合并共线但是直线顶点不相接的直线的程序，谢谢啦~~

账号		自动登录	找回密码
密码			注册

共线直线并批量连接-------多段线连接-------Join

点评

点评

点评

评分

评分