首尾相连直线转多段线程序

langjs

;贡献一个首尾相连直线转多段线程序，程序虽小感觉比CAD自带的PE命令好用，支持面域,多线,区域覆盖直接转多段线。

(defun c:pee (/ ent ent1 i j la name name1 ss ss0 ss1)
  (setvar "cmdecho" 0)
  (setvar "peditaccept" 1)
  (if (setq ss0 (ssget))
    (progn (setq ss (ssadd))
      (repeat (setq i (sslength ss0))
        (setq name (ssname ss0 (setq i (1- i)))  ent (entget name))
        (if (member (cdr (assoc 0 ent)) (list "REGION" "WIPEOUT" "MLINE"))
          (progn (setq la (cdr (assoc 8 ent)))
            (command "explode" name)
            (if (setq ss1 (ssget "p"))
              (repeat (setq j (sslength ss1))
                (setq name1 (ssname ss1 (setq j (1- j))) ent1 (entget name1))
                (entmod (subst (cons 8 la) (assoc 8 ent1) ent1))
                (setq ss (ssadd name1 ss))))))
        (setq ss (ssadd name ss)))
      (command "PEDIT" "M" ss "" "J" 0.0 "")))
  (princ)
)

广易精通

(defun c:gp (/ *error* s2 n e ty wd index pt rad r1 r2 old_lay date1 ffg oos)
(setvar "cmdecho" 0)
(defun *error* (msg)
  (if oos
   (setvar "osmode" oos)
  )
  (if old_lay
   (setvar "clayer" old_lay)
  )
)
(setq oos (getvar "osmode"))
(setvar "osmode" 0)
(setq old_lay (getvar "clayer"))
(prompt "\n请选择要连接成多义线的线(line,arc,circle,lwpolyline)<退出>:")
(setq s2 (ssget '((-4 . "<AND") (0 . "LINE,LWPOLYLINE,ARC,CIRCLE")
    (-4 . "AND>")
   )
   )
)
(if (/= s2 nil)
  (progn
   (setq date1 (getvar "CDATE"))
   (setq wd (getdist "多义线宽度<0>:")
  wd (if wd
      wd
      0
     )
   )
   (setq n (sslength s2))
   (setq index 0)
   (repeat n
    (setq e (ssname s2 index)
   ent (entget e)
   index (+ 1 index)
   ty (assoc 0 ent)
    )
    (if (= "LWPOLYLINE" (cdr ty))
     (progn
      (command ".change" s2 "" "P" "C" "bylayer" "")
      (setq ffg (cdr (assoc 70 ent)))
      (if (= ffg 0)
       (command ".pedit" e "j" s2 "" "w" wd "")
       (command ".pedit" e "w" wd "")
      )
     )
    )
    (if (= "LINE" (cdr ty))
     (progn
      (command ".change" s2 "" "P" "C" "bylayer" "")
      (command ".pedit" e "y" "j" s2 "" "w" wd "")
     )
    )
    (if (= "CIRCLE" (cdr ty))
     (progn
      (setq pt (cdr (assoc 10 ent)))
      (setq rad (cdr (assoc 40 ent)))
      (setq r1 (- (* rad 2) wd))
      (setq r2 (+ (* rad 2) wd))
      (if (> wd (* 2 rad))
       (progn
(setq r1 0)
(setq r2 (* rad 2))
       )
      )
      (command ".change" s2 "" "P" "C" "bylayer" "")
      (command "_donut" r1 r2 pt "")
      (entdel e)
     )
    )
    (if (= "ARC" (cdr ty))
     (progn
      (setq r1 (cdr (assoc 10 ent)))
      (setq r2 (cdr (assoc 40 ent)))
      (setq pt (cdr (assoc 50 ent)))
      (setq rad (cdr (assoc 51 ent)))
      (setq p1 (polar r1 pt r2))
      (setq p2 (polar r1 rad r2))
      (command ".change" s2 "" "P" "C" "bylayer" "")
      (command "_pline" p1 "_w" wd wd "_a" "_ce" r1 p2 "")
      (entdel e)
     )
    )
   )
   (setq n (itoa n)
  wd (rtos wd 2 0)
   )
   (prompt (strcat "\n共有\"" n "\"条线宽度变为\"" wd "\"的多义线。耗时\"" (rtos (* (- (getvar "CDATE") date1) 86400) 2 3)
     "\"秒。"
    )
   )
  )
)
(command "_clayer" old_lay)
(setvar "osmode" oos)
(setvar "cmdecho" 1)
(princ)
)
这个线宽不支持40

alexmai

lxl217114 发表于 2022-1-4 16:45
朗大师，如果可以直接点击选中“首尾相连的线/多段线”中间的任意一段，就可以执行这个程序那就更强大了。

;;;全屏幕自动连接线段
(Defun C:tt (/ Ssa Pt1 Pt2)
    (Setvar "Cmdecho" 0)
    (Setq Pt1 (Getvar "Vsmin"));屏幕左下
    (Setq Pt2 (Getvar "Vsmax"));屏幕右上
    (setq ssa (ssget "w" pt1 pt2  '((0 . "LINE,ARC,LWPOLYLINE,POLYLINE"))))
  (Vl-Cmdf "_pedit" "m" ssa "" "j" "0.0002" "")
  (Setvar "Cmdecho" 1)
  (Princ)
)

不用选搞定多段线

世井

支持一上

gaics

这个太强大了！

小溪向东流

刚好用到,学习学习

664571221

可不可以搞一个容差呀

广易精通

楼主，要是再加入线宽呢

xzd716

可以用上，不错！

lxl217114

朗大师，如果可以直接点击选中“首尾相连的线/多段线”中间的任意一段，就可以执行这个程序那就更强大了。

zhaozwf

非常不错，谢谢分享