转换多段线

print1985 · 发表于 2013-4-4 22:29:31

敢问楼主转换为pl线的目的是？

nzl1116 · 发表于 2013-4-5 08:48:20

仅支持闭合多段线

(defun PLConvert (PLEntName / PtsLst0 PtsLst1 MinLeng LinLeng PtsLst2 Pnt0 Pnt1 Pnt2 Pnt3 Pnt4 Pnt5)
(setq PtsLst0 (mapcar 'cdr
(vl-remove-if
'(lambda (x) (/= 10 (car x)))
(entget PLEntName)
)
)
PtsLst1 (append (cdr PtsLst0) (list (car PtsLst0)))
MinLeng (apply '+ (mapcar 'distance PtsLst1 PtsLst0))
PtsLst1 (mapcar 'list PtsLst0 PtsLst1)
)
(foreach x PtsLst1
(if (< (setq LinLeng (apply 'distance x)) MinLeng)
(setq MinLeng LinLeng
PtsLst2 x
)
)
)
(setq Pnt0 (car PtsLst2)
Pnt1 (cadr PtsLst2)
Pnt2 (mapcar '* (mapcar '+ Pnt0 Pnt1) '(0.5 0.5 0.5))
PtsLst0 (append (member Pnt0 PtsLst0)
(reverse (cdr (member Pnt0 (reverse PtsLst0))))
)
PtsLst0 (append (cddr PtsLst0) PtsLst2)
Pnt3 Pnt1
PtsLst1 (list Pnt2)
)
(while (not (equal Pnt3 Pnt0))
(setq Pnt4 (car PtsLst0)
Pnt5 (cadr PtsLst0)
Pnt2 (polar Pnt2 (angle Pnt3 Pnt4) (distance Pnt3 Pnt4))
)
(if (vlax-curve-getParamAtPoint PLEntName Pnt2)
(setq Pnt2 (polar Pnt2 (angle Pnt4 Pnt3) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
Pnt2 (polar Pnt2 (angle Pnt5 Pnt4) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
)
(setq Pnt2 (polar Pnt2 (angle Pnt3 Pnt4) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
Pnt2 (polar Pnt2 (angle Pnt4 Pnt5) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
)
)
(setq Pnt3 Pnt4
PtsLst0 (cdr PtsLst0)
)
)
(setq PtsLst1 (reverse PtsLst1)
PtsLst1 (mapcar '(lambda (x) (cons 10 x)) PtsLst1)
PtsLst2 (length PtsLst1)
PtsLst1 (mapcar '(lambda (x) (list (cons 40 MinLeng) (cons 41 MinLeng) x)) PtsLst1)
PtsLst1 (cddr (apply 'append PtsLst1))
)
(entmake
(append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (100 . "AcDbPolyline") (8 . "0") (62 . 6) (70 . 0))
(list (cons 90 PtsLst2))
PtsLst1
)
)
)

(defun PLConvert (PLEntName / PtsLst0 PtsLst1 MinLeng LinLeng PtsLst2 Pnt0 Pnt1 Pnt2 Pnt3 Pnt4 Pnt5) 
  (setq        PtsLst0        (mapcar        'cdr 
                        (vl-remove-if 
                          '(lambda (x) (/= 10 (car x))) 
                          (entget PLEntName) 
                        ) 
                ) 
        PtsLst1        (append (cdr PtsLst0) (list (car PtsLst0))) 
        MinLeng        (apply '+ (mapcar 'distance PtsLst1 PtsLst0)) 
        PtsLst1        (mapcar 'list PtsLst0 PtsLst1) 
  ) 
  (foreach x PtsLst1 
    (if        (< (setq LinLeng (apply 'distance x)) MinLeng) 
      (setq MinLeng LinLeng 
            PtsLst2 x 
      ) 
    ) 
  ) 
  (setq        Pnt0        (car PtsLst2) 
        Pnt1        (cadr PtsLst2) 
        Pnt2        (mapcar '* (mapcar '+ Pnt0 Pnt1) '(0.5 0.5 0.5)) 
        PtsLst0        (append        (member Pnt0 PtsLst0) 
                        (reverse (cdr (member Pnt0 (reverse PtsLst0)))) 
                ) 
        PtsLst0        (append (cddr PtsLst0) PtsLst2) 
        Pnt3        Pnt1 
        PtsLst1        (list Pnt2) 
  ) 
  (while (not (equal Pnt3 Pnt0)) 
    (setq Pnt4 (car PtsLst0) 
          Pnt5 (cadr PtsLst0) 
          Pnt2 (polar Pnt2 (angle Pnt3 Pnt4) (distance Pnt3 Pnt4)) 
    ) 
    (if (vlax-curve-getParamAtPoint PLEntName Pnt2) 
      (setq Pnt2    (polar Pnt2 (angle Pnt4 Pnt3) (* MinLeng 0.5)) 
            PtsLst1 (cons Pnt2 PtsLst1) 
            Pnt2    (polar Pnt2 (angle Pnt5 Pnt4) (* MinLeng 0.5)) 
            PtsLst1 (cons Pnt2 PtsLst1) 
      ) 
      (setq Pnt2    (polar Pnt2 (angle Pnt3 Pnt4) (* MinLeng 0.5)) 
            PtsLst1 (cons Pnt2 PtsLst1) 
            Pnt2    (polar Pnt2 (angle Pnt4 Pnt5) (* MinLeng 0.5)) 
            PtsLst1 (cons Pnt2 PtsLst1) 
      ) 
    ) 
    (setq Pnt3          Pnt4 
          PtsLst0 (cdr PtsLst0) 
    ) 
  ) 
  (setq PtsLst1 (reverse PtsLst1) 
        PtsLst1 (mapcar '(lambda (x) (cons 10 x)) PtsLst1) 
        PtsLst2 (length PtsLst1) 
        PtsLst1 (mapcar '(lambda (x) (list (cons 40 MinLeng) (cons 41 MinLeng) x)) PtsLst1) 
        PtsLst1 (cddr (apply 'append PtsLst1)) 
        ) 
  (entmake 
    (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (100 . "AcDbPolyline") (8 . "0") (62 . 6) (70 . 0)) 
            (list (cons 90  PtsLst2)) 
            PtsLst1 
    ) 
  ) 
)

yjr111 · 发表于 2013-4-5 10:03:21

nzl1116 发表于 2013-4-5 08:48
仅支持闭合多段线

很棒，不过有些情况会出错，比如下面简单图形

nzl1116 · 发表于 2013-4-5 10:10:53

yjr111 发表于 2013-4-5 10:03
很棒，不过有些情况会出错，比如下面简单图形

这简单,稍微修复下就可以了

nzl1116 · 发表于 2013-4-5 10:37:40

(defun PLConvert (PLEntName / PtsLst0 PtsLst1 MinLeng LinLeng PtsLst2 Pnt0 Pnt1 Pnt2 Pnt3 Pnt4 Pnt5)
;;获取闭合多段线所有顶点的坐标
(setq PtsLst0 (mapcar 'cdr
(vl-remove-if
'(lambda (x) (/= 10 (car x)))
(entget PLEntName)
)
)
;;将起点后置
PtsLst1 (append (cdr PtsLst0) (list (car PtsLst0)))
;;初始化最小长度为闭合多段线的总长
MinLeng (apply '+ (mapcar 'distance PtsLst1 PtsLst0))
;;获取多段线每一段的点对表
PtsLst1 (mapcar 'list PtsLst0 PtsLst1)
)
;;搜索最小长度的那一段
(foreach x PtsLst1
(if (< (setq LinLeng (apply 'distance x)) MinLeng)
(setq MinLeng LinLeng
PtsLst2 x
)
)
)
;;最小长度那一段的前一点
(setq Pnt0 (car PtsLst2)
;;最小长度那一段的后一点
Pnt1 (cadr PtsLst2)
;;最小长度那一段的中点
Pnt2 (mapcar '* (mapcar '+ Pnt0 Pnt1) '(0.5 0.5 0.5))
PtsLst0 (append (member Pnt0 PtsLst0)
(reverse (cdr (member Pnt0 (reverse PtsLst0))))
)
;;循环后置，将Pnt0、Pnt1两点放在点表的后面
PtsLst0 (append (cddr PtsLst0) PtsLst2)
;;初始化变量Pnt3
Pnt3 Pnt1
;;初始化变量PtsLst1，这个变量按顺序保存将要绘制的多段线的所有点
PtsLst1 (list Pnt2)
;;修复部分
Pnt4 (car PtsLst0)
Pnt5 (polar Pnt2 (angle Pnt3 Pnt4) (* MinLeng 0.25))
)
(if (setq LinLeng (bpoly Pnt5))
(if (= (vlax-curve-getarea LinLeng)
(vlax-curve-getarea PLEntName)
)
(entdel LinLeng)
(progn
(entdel LinLeng)
(setq PtsLst0 (reverse PtsLst0)
PtsLst0 (append (cddr PtsLst0) (list Pnt1 Pnt0))
Pnt3 Pnt0
Pnt0 Pnt1
)
)
)
(setq PtsLst0 (reverse PtsLst0)
PtsLst0 (append (cddr PtsLst0) (list Pnt1 Pnt0))
Pnt3 Pnt0
Pnt0 Pnt1
)
)
;;如果相对起点Pnt3是最小长度那一段的前一点，那么停止循环
(while (not (equal Pnt3 Pnt0))
;;获取相对终点Pnt4
(setq Pnt4 (car PtsLst0)
;;点Pnt5和点Pnt4一起使用，作为前进或后退的方向
Pnt5 (cadr PtsLst0)
;;根据相对起点Pnt3和相对终点Pnt4的长度和方向移动点Pnt2
Pnt2 (polar Pnt2 (angle Pnt3 Pnt4) (distance Pnt3 Pnt4))
)
;;如果移动后点Pnt2在原多段线上，那么先在Pnt3 Pnt4方向上后退半个最小长度，再在Pnt4 Pnt5方向上后退半个最小长度；
;;相反地，点Pnt2不在原多段线上，那么先在Pnt3 Pnt4方向上前进半个最小长度，再在Pnt4 Pnt5方向上前进半个最小长度。
;;这么做的目的是始终使点Pnt2和下一次循环的相对起点保持对齐，距离是半个最小长度，并把两次调整过的点存储到PtsLst1表中。
(if (vlax-curve-getParamAtPoint PLEntName Pnt2)
(setq Pnt2 (polar Pnt2 (angle Pnt4 Pnt3) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
Pnt2 (polar Pnt2 (angle Pnt5 Pnt4) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
)
(setq Pnt2 (polar Pnt2 (angle Pnt3 Pnt4) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
Pnt2 (polar Pnt2 (angle Pnt4 Pnt5) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
)
)
;;设置下一次循环的相对起点为这次的相对终点
;;并移除点表的第一项
(setq Pnt3 Pnt4
PtsLst0 (cdr PtsLst0)
)
)
(setq PtsLst1 (reverse PtsLst1)
;;给顶点添加组码10
PtsLst1 (mapcar '(lambda (x) (cons 10 x)) PtsLst1)
;;计算顶点的个数
PtsLst2 (length PtsLst1)
;;添加多段线各段的起点宽度和终点宽度
PtsLst1 (mapcar '(lambda (x) (list (cons 40 MinLeng) (cons 41 MinLeng) x)) PtsLst1)
PtsLst1 (cddr (apply 'append PtsLst1))
)
;;绘制多段线
(entmake
(append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (100 . "AcDbPolyline") (8 . "0") (62 . 6) (70 . 0))
(list (cons 90 PtsLst2))
PtsLst1
)
)
(princ)
)

(defun PLConvert (PLEntName / PtsLst0 PtsLst1 MinLeng LinLeng PtsLst2 Pnt0 Pnt1 Pnt2 Pnt3 Pnt4 Pnt5) 
  ;;获取闭合多段线所有顶点的坐标 
  (setq        PtsLst0        (mapcar        'cdr 
                        (vl-remove-if 
                          '(lambda (x) (/= 10 (car x))) 
                          (entget PLEntName) 
                        ) 
                ) 
        ;;将起点后置 
        PtsLst1        (append (cdr PtsLst0) (list (car PtsLst0))) 
        ;;初始化最小长度为闭合多段线的总长 
        MinLeng        (apply '+ (mapcar 'distance PtsLst1 PtsLst0)) 
        ;;获取多段线每一段的点对表 
        PtsLst1        (mapcar 'list PtsLst0 PtsLst1) 
  ) 
  ;;搜索最小长度的那一段 
  (foreach x PtsLst1 
    (if        (< (setq LinLeng (apply 'distance x)) MinLeng) 
      (setq MinLeng LinLeng 
            PtsLst2 x 
      ) 
    ) 
  ) 
  ;;最小长度那一段的前一点 
  (setq        Pnt0        (car PtsLst2) 
        ;;最小长度那一段的后一点 
        Pnt1        (cadr PtsLst2) 
        ;;最小长度那一段的中点 
        Pnt2        (mapcar '* (mapcar '+ Pnt0 Pnt1) '(0.5 0.5 0.5)) 
        PtsLst0        (append        (member Pnt0 PtsLst0) 
                        (reverse (cdr (member Pnt0 (reverse PtsLst0)))) 
                ) 
        ;;循环后置，将Pnt0、Pnt1两点放在点表的后面 
        PtsLst0        (append (cddr PtsLst0) PtsLst2) 
        ;;初始化变量Pnt3 
        Pnt3        Pnt1 
        ;;初始化变量PtsLst1，这个变量按顺序保存将要绘制的多段线的所有点 
        PtsLst1        (list Pnt2) 
        ;;修复部分 
        Pnt4    (car PtsLst0) 
        Pnt5    (polar Pnt2 (angle Pnt3 Pnt4) (* MinLeng 0.25)) 
  ) 
  (if (setq LinLeng (bpoly Pnt5)) 
    (if        (= (vlax-curve-getarea LinLeng) 
           (vlax-curve-getarea PLEntName) 
        ) 
      (entdel LinLeng) 
      (progn 
        (entdel LinLeng) 
        (setq PtsLst0 (reverse PtsLst0) 
              PtsLst0 (append (cddr PtsLst0) (list Pnt1 Pnt0)) 
              Pnt3    Pnt0 
              Pnt0    Pnt1 
        ) 
      ) 
    ) 
    (setq PtsLst0 (reverse PtsLst0) 
          PtsLst0 (append (cddr PtsLst0) (list Pnt1 Pnt0)) 
          Pnt3          Pnt0 
          Pnt0          Pnt1 
    ) 
  ) 
  ;;如果相对起点Pnt3是最小长度那一段的前一点，那么停止循环 
  (while (not (equal Pnt3 Pnt0)) 
    ;;获取相对终点Pnt4 
    (setq Pnt4 (car PtsLst0) 
          ;;点Pnt5和点Pnt4一起使用，作为前进或后退的方向 
          Pnt5 (cadr PtsLst0) 
          ;;根据相对起点Pnt3和相对终点Pnt4的长度和方向移动点Pnt2 
          Pnt2 (polar Pnt2 (angle Pnt3 Pnt4) (distance Pnt3 Pnt4)) 
    ) 
    ;;如果移动后点Pnt2在原多段线上，那么先在Pnt3 Pnt4方向上后退半个最小长度，再在Pnt4 Pnt5方向上后退半个最小长度； 
    ;;相反地，点Pnt2不在原多段线上，那么先在Pnt3 Pnt4方向上前进半个最小长度，再在Pnt4 Pnt5方向上前进半个最小长度。 
    ;;这么做的目的是始终使点Pnt2和下一次循环的相对起点保持对齐，距离是半个最小长度，并把两次调整过的点存储到PtsLst1表中。 
    (if (vlax-curve-getParamAtPoint PLEntName Pnt2) 
      (setq Pnt2    (polar Pnt2 (angle Pnt4 Pnt3) (* MinLeng 0.5)) 
            PtsLst1 (cons Pnt2 PtsLst1) 
            Pnt2    (polar Pnt2 (angle Pnt5 Pnt4) (* MinLeng 0.5)) 
            PtsLst1 (cons Pnt2 PtsLst1) 
      ) 
      (setq Pnt2    (polar Pnt2 (angle Pnt3 Pnt4) (* MinLeng 0.5)) 
            PtsLst1 (cons Pnt2 PtsLst1) 
            Pnt2    (polar Pnt2 (angle Pnt4 Pnt5) (* MinLeng 0.5)) 
            PtsLst1 (cons Pnt2 PtsLst1) 
      ) 
    ) 
    ;;设置下一次循环的相对起点为这次的相对终点 
    ;;并移除点表的第一项 
    (setq Pnt3          Pnt4 
          PtsLst0 (cdr PtsLst0) 
    ) 
  ) 
  (setq PtsLst1 (reverse PtsLst1) 
        ;;给顶点添加组码10 
        PtsLst1 (mapcar '(lambda (x) (cons 10 x)) PtsLst1) 
        ;;计算顶点的个数 
        PtsLst2 (length PtsLst1) 
        ;;添加多段线各段的起点宽度和终点宽度 
        PtsLst1 (mapcar '(lambda (x) (list (cons 40 MinLeng) (cons 41 MinLeng) x)) PtsLst1) 
        PtsLst1 (cddr (apply 'append PtsLst1)) 
        ) 
  ;;绘制多段线 
  (entmake 
    (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (100 . "AcDbPolyline") (8 . "0") (62 . 6) (70 . 0)) 
            (list (cons 90  PtsLst2)) 
            PtsLst1 
    ) 
  ) 
  (princ) 
)

ps122hb · 发表于 2013-4-6 08:38:20

试了一下，果然好使，多谢了

xiaxiang · 发表于 2013-4-7 19:49:24

不知道严兄还有什么更好的方法？

开1心 · 发表于 2013-7-14 17:11:58

整了半天，弄到LSP文件中，调用不了~初学者~

freeok · 发表于 2013-11-22 21:00:22

nzl1116 发表于 2013-4-5 10:37

话说，这个程序能指导下小白怎么使么？谢谢！

nzl1116 · 发表于 2013-11-23 00:15:12

本帖最后由 nzl1116 于 2013-11-23 00:24 编辑

freeok 发表于 2013-11-22 21:00
话说，这个程序能指导下小白怎么使么？谢谢！

(PLConvert (car (entsel)))

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

[源码] 转换多段线

点评

评分

本帖子中包含更多资源

浏览过的版块