[LISP函数]：请教老师在编lisp中遇到的问题：如何把pL多义线的各顶点按顺序编号?

tywsc

请问老师和各位高手：我在编程(lisp)时，不知如何把pL多义线的各顶点按顺序自动编号。
比如，一条PL多义线有80个顶点，我希望把一端的起点设为T1,第二点自动编为T2,......至
最后一点自动编为T80;然后在输出的顶点坐标文件时，把T1、T2、T3......T80等与顶点坐标
一一对应上。
多谢陈老师和各位高手指教。

下面是我下载老师的有关程序，请教老师如何把‘各顶点自动编号’也加到程序中？
是不是要用regapp函数扩展数据呢？

**********************************************************************************
作(译)者：  陈伯雄 　
　上传时间：2002年9月3日  
(Defun C:PLL ()
       (PrinC "\n这是对 PolyLine 进行数据分析的基本程序...")
       (While (Progn (SetQ pen (Car (EntSel "\n指定一条 PolyLine: ")))
                        (/= "POLYLINE" (Cdr (Assoc 0 (EntGet pen))))
                )
                (Alert "所指对象不是 PolyLine，请重新指定...")
       )                                              ;指定PolyLine
       (SetQ pel (EntGet pen)           ;取出对象表
              ptp (Cdr (Assoc 70 pel))   ;取出结束片段型
              wpl '()                       ;自建的点位数表
           pen (EntNext pen)
       )
       (While (/= "SEQEND" (Cdr (Assoc 0 (EntGet pen)))) ;如果没结束
               (SetQ pel (EntGet pen)           ;取得顶点对象数据表
               plp (Cdr (Assoc 10 pel))    ;取出控制点点位
                      par (Cdr (Assoc 42 pel))     ;取出弓弦比
                      wpl (Cons (List plp par) wpl)    ;将数据加到WPL表中
               )
               (SetQ pen (EntNext pen))                ;搜索下一个对象
       )
       (SetQ ct (If (= 0 (Cadr (Car wpl))) "直线片段封闭" "弧片段封闭"))
       (SetQ wpl (Cons (Last wpl) wpl) ;加入封闭点
       wpl (Reverse wpl)           ;整理WPL表
       rl (Length wpl)
              pn 0
       )            
       (SetQ clk (If (Or (= 0 ptp) (= 128 ptp)) "开口" "封闭"))  
       (SetVar “pdmode” 3)
       (Repeat (1- 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))
                           )
                           (Command "text" "m" cp 2 0  
(StrCat "R" (RToS (Abs rr)))
                       "text" "" (AngToS bj)
                       "circle" cp 5
                           )
                    )
               )
               (SetQ pn (1+ pn)) ;搜索序号步进
       )
       (Alert (StrCat "结束段状态:\n"
                  clk
                        (If (= "封闭" clk) ct "")
              )
       )
       (PrinC)
)  
**********************************************************************************

lsjjm

最初由 tywsc 发布
[B]请问老师和各位高手：我在编程(lisp)时，不知如何把pL多义线的各顶点按顺序自动编号...[/B]

2. 
   
3. (defun c:test ()
   
4.   (setq poly (car (entsel)))
   
5.   (setq ptlst (acet-geom-vertex-list poly))
   
6.   (setq n 0)
   
7.   (while (< n (length ptlst))
   
8.     (princ (strcat "\nT" (itoa n) "  "))
   
9.            (princ (nth n ptlst))
   
10.     (setq n (1+ n))
    
11.     )
    
12.   (princ)
    
13. )

<br /> (defun c:test ()<br />   (setq poly (car (entsel)))<br />   (setq ptlst (acet-geom-vertex-list poly))<br />   (setq n 0)<br />   (while (< n (length ptlst))<br />     (princ (strcat "\nT" (itoa n) "  "))<br />            (princ (nth n ptlst))<br />     (setq n (1+ n))<br />     )<br />   (princ)<br /> )

心梦相随

也可以这样：

2. 
   
3. (setq e (entget (car (entsel))))
   
4. (setq n 1)
   
5. (foreach x e
   
6.   (if (= (car x) 10)
   
7.     (progn (princ (strcat "\nT" (itoa n) " "))
   
8.            (princ (nth 1 x))
   
9.            (setq n (1+ n))
   
10.     )
    
11.   )
    
12. )

<br /> (setq e (entget (car (entsel))))<br /> (setq n 1)<br /> (foreach x e<br />   (if (= (car x) 10)<br />     (progn (princ (strcat "\nT" (itoa n) " "))<br />            (princ (nth 1 x))<br />            (setq n (1+ n))<br />     )<br />   )<br /> )

tywsc

感谢这个论坛,感谢二位老师指路。
这里高手真多。我要加倍努力。
多谢了！多谢了！多谢了！

Qlin

1楼的只适用于polyline,
2楼的polyline和lwpolyline都行,但不知道没装express时能否使用,
3楼的只适用于lwpolyline,

陌生人

6楼的适用polyline和lwpolyline，不用装et， 要求2000以上版本

2. 
   
3. ;;列 pl，lwpl顶点.
   
4. (defun c:plnpt (/ obj ptlst z i)
   
5. (setq obj   (vlax-ename->vla-object (car(entsel "\n选择多义线：")))
   
6.        ptlst (vlax-get obj 'Coordinates )
   
7.        z     (if (= "AcDb2dPolyline"  (vla-get-objectname obj)) (vlax-get obj 'Elevation ))
   
8.        i     0)
   
9. (while ptlst
   
10.    (mapcar 'princ (list "\nT" (itoa i) " " (car ptlst) " " (cadr ptlst) " " (if z z (caddr ptlst))))
    
11.    (setq ptlst (cdddr ptlst)
    
12.          i (1+ i))
    
13. )(princ)
    
14. )
    
15. 
    

<br /> ;;列 pl，lwpl顶点.<br /> (defun c:plnpt (/ obj ptlst z i)<br /> (setq obj   (vlax-ename->vla-object (car(entsel "\n选择多义线：")))<br />        ptlst (vlax-get obj 'Coordinates )<br />        z     (if (= "AcDb2dPolyline"  (vla-get-objectname obj)) (vlax-get obj 'Elevation ))<br />        i     0)<br /> (while ptlst<br />    (mapcar 'princ (list "\nT" (itoa i) " " (car ptlst) " " (cadr ptlst) " " (if z z (caddr ptlst))))<br />    (setq ptlst (cdddr ptlst)<br />          i (1+ i))<br /> )(princ)<br /> )<br /> <br />