虚线分解为线段 V1.2（2018.12.6）目前支持图元：直线、多段线、圆弧、圆！

fangmin723 · 发表于 2018-12-4 10:25

本帖最后由 fangmin723 于 2020-12-1 09:23 编辑

;;;将虚线分解成段线

至于这个功能干什么用，用在什么地方，这个问题已经被问了四五遍了，我在本帖中已经回复过了，想知道的话，你可以翻阅查看
http://bbs.mjtd.com/forum.php?mo ... amp;fromuid=7316343
虚线分解为线段 V1.2（2018.12.6）目前支持图元有：直线、多段线、圆弧、圆！
注：测试平台- AutoCAD2017 和中望CAD2014；V1.2上传文件为vlx，欢迎下载测试！！！

;;;将虚线分解成段线 V 1.0 by 忘霄 702099480@qq.com
(defun c:zxfj(/ ang ept llen lsac ltp ltpdis ltplen ltplst mept mspt n obj recd slen spt)
(setq
obj (vlax-ename->vla-object (car (entsel "\n请选择分解的虚线：")))
ang (vla-get-Angle obj)
spt (vlax-safearray->list (vlax-variant-value (vla-get-StartPoint obj)))
ept (vlax-safearray->list (vlax-variant-value (vla-get-EndPoint obj)))
llen (vla-get-Length obj)
ltp (vla-get-Linetype obj)
lsac (vla-get-LinetypeScale obj)
ltplst (entget (tblobjname "LTYPE" ltp))
)
(foreach X ltplst
(if (= (car x) 49)
(if (> (cdr x) 0)
(setq ltplen (cdr x))
(setq ltpdis (abs (cdr x)))
)
)
)
(setq ltplen (* ltplen lsac) ltpdis (* ltpdis lsac) n 0 recd 0)
(if (> llen (+ ltplen ltpdis))
(progn
(setq n (fix (/ (- llen ltpdis) (+ ltplen ltpdis))))
(cond
((< (setq slen (rem (- llen ltpdis) (+ ltplen ltpdis))) ltplen)
(setq slen (- llen ltpdis (* (+ ltplen ltpdis) (- n 1))))
(entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 (setq mept (polar spt ang (/ slen 2.0))))))
(repeat (- n 1)
(entmake (list '(0 . "LINE") (cons 10 (setq mspt (polar mept ang ltpdis))) (cons 11 (setq mept (polar mspt ang ltplen)))))
)
(entmake (list '(0 . "LINE") (cons 10 (polar mept ang ltpdis)) (cons 11 ept)))
(vla-Delete obj)
)
(T
(if (= n 0)
(progn
(entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 (setq mept (polar spt ang (/ (- llen ltpdis) 2.0))))))
(entmake (list '(0 . "LINE") (cons 10 (polar mept ang ltpdis)) (cons 11 ept)))
(vla-Delete obj)
)
(progn
(entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 (setq mept (polar spt ang (/ slen 2.0))))))
(repeat n
(entmake (list '(0 . "LINE") (cons 10 (setq mspt (polar mept ang ltpdis))) (cons 11 (setq mept (polar mspt ang ltplen)))))
)
(entmake (list '(0 . "LINE") (cons 10 (polar mept ang ltpdis)) (cons 11 ept)))
(vla-Delete obj)
)
)
)
)
)
(progn
(entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 ept)))
(vla-Delete obj)
)
)
(princ)
)

;;;将虚线分解成段线 V 1.0 by 忘霄 <a href="mailto:702099480@qq.com" target="_blank">702099480@qq.com</a> 
(defun c:zxfj(/ ang ept llen lsac ltp ltpdis ltplen ltplst mept mspt n obj recd slen spt) 
  (setq 
    obj (vlax-ename->vla-object (car (entsel "\n请选择分解的虚线："))) 
    ang (vla-get-Angle obj) 
    spt (vlax-safearray->list (vlax-variant-value (vla-get-StartPoint obj))) 
    ept (vlax-safearray->list (vlax-variant-value (vla-get-EndPoint obj))) 
    llen (vla-get-Length obj) 
    ltp (vla-get-Linetype obj) 
    lsac (vla-get-LinetypeScale obj) 
    ltplst (entget (tblobjname "LTYPE" ltp)) 
  ) 
  (foreach X ltplst 
    (if (= (car x) 49) 
      (if (> (cdr x) 0) 
        (setq ltplen (cdr x)) 
        (setq ltpdis (abs (cdr x))) 
      ) 
    ) 
  ) 
  (setq ltplen (* ltplen lsac) ltpdis (* ltpdis lsac) n 0 recd 0) 
  (if (> llen (+ ltplen ltpdis)) 
    (progn 
      (setq n (fix (/ (- llen ltpdis) (+ ltplen ltpdis)))) 
      (cond 
        ((< (setq slen (rem (- llen ltpdis) (+ ltplen ltpdis))) ltplen) 
          (setq slen (- llen ltpdis (* (+ ltplen ltpdis) (- n 1)))) 
          (entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 (setq mept (polar spt ang (/ slen 2.0)))))) 
          (repeat (- n 1) 
            (entmake (list '(0 . "LINE") (cons 10 (setq mspt (polar mept ang ltpdis))) (cons 11 (setq mept (polar mspt ang ltplen))))) 
          ) 
          (entmake (list '(0 . "LINE") (cons 10 (polar mept ang ltpdis)) (cons 11 ept))) 
          (vla-Delete obj) 
        ) 
        (T 
          (if (= n 0) 
            (progn 
              (entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 (setq mept (polar spt ang (/ (- llen ltpdis) 2.0)))))) 
              (entmake (list '(0 . "LINE") (cons 10 (polar mept ang ltpdis)) (cons 11 ept))) 
              (vla-Delete obj) 
            ) 
            (progn 
              (entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 (setq mept (polar spt ang (/ slen 2.0)))))) 
              (repeat n 
                (entmake (list '(0 . "LINE") (cons 10 (setq mspt (polar mept ang ltpdis))) (cons 11 (setq mept (polar mspt ang ltplen))))) 
              ) 
              (entmake (list '(0 . "LINE") (cons 10 (polar mept ang ltpdis)) (cons 11 ept))) 
              (vla-Delete obj) 
            ) 
          ) 
        ) 
      ) 
    ) 
    (progn 
      (entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 ept))) 
      (vla-Delete obj) 
    ) 
  ) 
  (princ) 
)

虚线分解为线段 V1.2.vlx

xyp1964 · 发表于 2023-10-12 23:05

;; 宽多段线外边界 wmf方式

llsheng_73 · 发表于 2018-12-8 23:30

meja 发表于 2018-12-8 17:06
关键是如何恢复成线

恢复成线应该比较困难，当然也不是完全不可逆转

如果在分解线的基础上增加一些信息，比如这一系列图元编组或者记录相关的所有图元句柄，以及分解前的线型及线型比例线宽等，那么就可能根据任意一条线找出相关信息重新绘制出分解前的线条，并且删除相关的这一堆线

meja · 发表于 2018-12-23 16:16

llsheng_73 发表于 2018-12-8 23:30
恢复成线应该比较困难，当然也不是完全不可逆转

如果在分解线的基础上增加一些信息，比如这一系列图元 ...

可以考虑延长分解的线段，使用glue程序合并，当然，圆弧的问题无法完美解决，我试过直线段可以的

liunian0524 · 发表于 2018-12-4 10:39

感谢楼主分享

liwen888888 · 发表于 2018-12-4 10:39

感谢楼主分享

ynhh · 发表于 2018-12-4 10:42

感谢楼主分享谢谢你

ketxu · 发表于 2018-12-4 11:08

Thanks for sharing ^^

yoyoho · 发表于 2018-12-4 11:19

感谢楼主分享程序!!!!

qyming · 发表于 2018-12-4 11:37

感谢楼主分享

lingduwx · 发表于 2018-12-4 11:45

非常谢谢分享

wblx · 发表于 2018-12-4 12:50

感谢楼主分享

langjs · 发表于 2018-12-4 13:35

这是干吗用的啊

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

[源码] 虚线分解为线段 V1.2（2018.12.6）目前支持图元：直线、多段线、圆弧、圆！

本帖子中包含更多资源

本帖子中包含更多资源