[求助]：如何遍历多义线表（entget返回）的各点坐标

netbee

在编程过程中如何遍历多义线表
（entget返回）的各顶点坐标项

gchen

[php]
(Defun C:LWPL (/ pen pel pln ptp pan plp par wpl ct pn rl clk al pt gx bj np xc gg rr cp pa
                 ca cm nn)
(PrinC "\n这是对 LWPolyLine 进行资料分析的基本程序...")
(While (Progn (SetQ pen (Car (EntSel "\n指定一条LWPolyline: ")))
     (/= "LWPOLYLINE" (Cdr (Assoc 0 (EntGet pen))))
     )
     (Alert "所指对象不是 LWPolyLine，请重新指定...")
  ) ;指定LWPolyLine
  (SetQ pel (EntGet pen) ;取出对象资料表
     pel (Member '(100 . "AcDbPolyline") pel) ;取出其中的有关资料
     pln (Cdr (Assoc 90 pel)) ;取出控制点数量
     ptp (Cdr (Assoc 70 pel)) ;取出结束片段类型
  )
  (SetQ pan 6 ;资料读取序号初值
    wpl '() ;自建的点位资料表
  )
  (Repeat pln
   (SetQ plp (Cdr (Nth pan pel)) ;取出控制点点位
      par (Cdr (Nth (+ 3 pan) pel)) ;取出弓弦比
      wpl (Cons (List plp par) wpl) ;将资料加到WPL表中
   )
   (SetQ pan (+ 4 pan)) ;序号步进
  )
  (SetQ ct (If (= 0 (cadr (last wpl))) "直线片段封闭" "弧片段封闭"));判断最后段类型
  (SetQ wpl (Cons (Last wpl) wpl) ;加入封闭点
     wpl (Reverse wpl) ;整理WPL表
     pn 0
     rl (Length wpl)
  )
  (SetQ clk (If (Or (= 0 ptp) (= 128 ptp)) "开口" "封闭")) ;判断封闭与开口
  (SetQ rl (If (= "开口" clk) (- rl 2) (- rl 1)))
  (Repeat rl ;逐点分析
   (SetQ al (Nth pn wpl) ;取出点数据表
      pt (Car al) ;取出点位
   )
   (Command "point" pt)
   (PrinC "\n") (PrinC al)
   (If (And (/= 0.0 (Cadr al)) (Nth pn wpl)) ;如果是弧片断
     (Progn (SetQ gx (Cadr al) ;取出弓弦比
           bj (* (ATAN (ABS gx)) 4) ;计算包角
           np (Car (Nth (1+ pn) wpl)) ;取出下一点位
           xc (* 0.5 (Distance pt np)) ;半弦长计算
           gg (* gx xc) ;弓高计算
           rr (/ (+ (* xc xc)(* gg gg)) (* 2 gg)) ;半径计算
        )
        (SetQ cp (Polar pt (SetQ pa (Angle pt np)) xc) ; 圆心点计算
           cp (Polar cp (+ pa (* 0.5 Pi)) (- rr gg))
        )
        (SetQ ca (Angle pt np) ;弦角度
           cm (Polar cp (- ca 1.5707963268) rr) ;弧片段中点
        )
        (Command "text" "m" cp 2 0 (StrCat "R" (RToS (Abs rr)))
             "text" "" (AngToS bj)
             "circle" cp 5
             "circle" cm 3
        )
    )
   )
   (SetQ pn (1+ pn)) ;搜索序号步进
  )
  (Alert (StrCat "结束段状态:\n"
          clk "\n"
         (If (= "封闭" clk) ct "")
  )
)
(PrinC)
)
[/php]

ll_j

最初由 netbee 发布
在编程过程中如何遍历多义线表
（entget返回）的各顶点坐标项

(setq aa nil)
(setq bb (entget (car(entsel))))
(mapcar '(lambda(x) (if (= (car x) 10) (setq aa (cons (cdr x) aa))))bb)

Command: !aa
((9.39265 5.98161) (7.8627 3.19177) (5.65452 6.34413) (3.47788 3.44396))

hi71400

我好象找到点什么灵感－－关于两条复合线倒角的方法。要想想。

chstart

最初由 ll_j 发布
[B]
(setq aa nil)
(setq bb (entget (car(entsel))))
(mapcar '(lambda(x) (if (= (car x) 10) (setq aa ... [/B]

新手求助：如何把 aa 各项表分离开？

lsjjm

论坛里有许多类似的帖子，搜索一下嘛？！
其实是用内部函数最简单：
(acet-geom-vertex-list ename)

chstart

在acad r14里是不是不能使用函数acet-geom-vertex-list ？
苦恼，单位都在用r14，好像很多lisp函数都不能用？

maplesu

其实就是象3楼那样做，把群码是10的都取出就可以了

tosky

最初由 ll_j 发布
[B]
(setq aa nil)
(setq bb (entget (car (entsel))))
(mapcar '(lambda(x) (if (= (car x) 10) (setq aa ... [/B]

黄金兄得到的是反序数据序列

我的可以得到顺序数据序列，如下

(setq TmpLine_Data (entget (car(entsel))))  
(setq Data_List (mapcar '(lambda (xtmp)  (if (= 10 (car xtmp)) (cdr xtmp))) TmpLine_Data))
          
(setq Data_List (vl-remove nil Data_List))

有时候，数据的顺序很重要！

唉，疏忽

(setq aa nil)
(setq bb (entget (car (entsel))))
(mapcar '(lambda(x) (if (= (car x) 10) (setq aa ...  

加上
(setq aa (reverse aa))
也可以

lsjjm

最初由 chstart 发布
[B]在acad r14里是不是不能使用函数acet-geom-vertex-list ？
苦恼，单位都在用r14，好像很多lisp函数都不能用？ [/B]

能用于R14的:
[php]
(defun c:test ( / pts)
  (setq ent (nentsel "\nSelect a Polyline: "))
  (foreach i (entget (car ent))
    (if (= 10 (car i))(setq pts (cons (cdr i) pts)))
  )
  (reverse pts)
)
[/php]

chstart

感谢黄金长老 ：）
小弟受教了！
现在就可以分离出来了。棒！
努力！！！

陌生人

为什么没有人用vl-remove-if-not
[php]
(defun c:test ( / pts)
  (setq ent (nentsel "\nSelect a Polyline: "))
  (vl-remove-if-not '(lambda(x)(= 10 (car x))) (entget(car ent)))
)[/php]

lsjjm

最初由 陌生人 发布
[B]为什么没有人用vl-remove-if-not...[/B]

就跟为什么没有人用(acet-geom-vertex-list ename) 一样, 可能是不知道或者使用的版本太旧吧?

JOSDENNIS

我一直用這個方法
  (setq lst1 (entget (car (entsel "\nSelect a Polyline: "))) )
(while (setq lst1 (member (assoc 10 lst1) lst1))
    (setq controlpoint-list1 (append controlpoint-list1 (list (car lst1))))
    (setq lst1 (cdr lst1)))