[求助]：如何一次性获取多义线的所有顶点

jjxiao

如题,最好可以复制到excel或者写字板中,向各位请教!

maplesu

其实，list可以取得的
但是你如果只要数值就比较麻烦
看看我这个lisp可以帮助你不？
是写成txt的纯文本文件！
还要说明的是我这个只有x,y坐标没有z的。不知楼主是用做什么的
要是需要z的我可以修改！


[PHP]
(defun c:zb()
  (setvar "cmdecho"0)
  (setq ffn (getfiled "保存坐标" "" "txt" 1))
  (setq ff (open ffn "w"))
  (close ff)
  (princ "\n选取对象...")
  (setq ss (ssget))
  (setq i 0)
  (setvar "pdmode" 33)
  (repeat (sslength ss)
    (setq ssn (ssname ss i))
    (setq endata (entget ssn))
    (setq n 0)
    (repeat (length endata)
      (setq pp (nth n endata))
      (setq key (car pp))
      (if (= key 10)
        (progn
          (setq x (cadr pp))
          (setq y (caddr pp))
          (command "point" (list x y))
          (setq ff (open ffn "a"))
          (princ (rtos x 2 0) ff)
          (princ " " ff)
          (princ (rtos y 2 0) ff)
          (princ "\n" ff)
          (close ff)
          )
        )
      (setq n (1+ n))
      )
    (setq ff (open ffn "a"))
    (princ "End\n" ff)
    (close ff)
    (setq i (1+ i))
    )
  (princ (strcat "\n文件写至=> " ffn))
  (prin1)
  )
[/PHP]

gp8117

斑竹果然高手!
这个东东真不错!
但不知楼主用这个作什么?

maplesu

呵呵，这个东西是我在用桥梁博士输入截面的时候用的，哪里可以利用点的坐标自己输入截面计算，但是一个一个输入比较麻烦，我就做了这个东东，没有想到也有人需要！就贴上来了！

gp8117

键盘命令:ZB
网速太慢,斑竹可以把这两个帖子和在一起.

jjxiao

呵呵，这个东西是我在用桥梁博士输入截面的时候用的，哪里可以利用点的坐标自己输入截面计算，但是一个一个输入比较麻烦，我就做了这个东东，没有想到也有人需要！就贴上来了！

呵呵,惭愧,我也是搞桥的,不过不会自己写程序,汗~~~~~~


斑主,您的程序我下了,运行很好,可以实现坐标输出,但是好像输出的都是整数,能否改一下程序,可以手工(或者程序内部指定)小数点后面保留小数的位数.再者,如果可以输入z坐标那这个lisp就很完美啦,请斑主帮忙,不甚感激!

lsjjm

贴个简化点的"
(defun c:test ()
  (setq a (car (entsel)))
  (setq pts (acet-geom-vertex-list a))
  (setq n 0)
  (setq fn (open "coord5.txt" "w"))
  (write-line "PolyLine Coordinates: " fn)
  (write-line "*******************************" fn)
  (while (< n (length pts))
    (write-line  (strcat (itoa n) "   " (rtos (car (nth n pts)))
                 "   " (rtos (cadr (nth n pts)))"   " (rtos (last (nth n pts)))) fn)
    (setq n (1+ n))
  )
  (close fn)
)

maplesu

今天由于比较忙所以一直没有来看帖子，不好意思，由于pline画成的线是二维的，所以不能提供z轴的数值，需要提供的话应该用spline画的线，这个我现在还没有时间做，晚一点给你，至于需要可以调整精度的，这个没有问题。

还想问一句，不知道你需要用这个做什么？z轴也需要？

改好了，spline的是有z坐标的，pline是没有z坐标的。

[PHP]
(defun c:zb3()
  (setvar "cmdecho"0)
  (setq q (getint "小数点后的位数： "))
  (setq ffn (getfiled "保存坐标" "" "txt" 1))
  (setq ff (open ffn "w"))
  (close ff)
  (princ "\n选取对象...")
  (setq ss (ssget))
  (setq i 0)
  (setvar "pdmode" 33)
  (repeat (sslength ss)
    (setq ssn (ssname ss i))
    (setq endata (entget ssn))
    (setq kind (cdr (assoc 0 endata)))   
    (setq n 0)
    (if (= kind "SPLINE")
      (progn
        (repeat (length endata)
      (setq pp (nth n endata))
      (setq key (car pp))      
      (if (= key 11)
        (progn
          (setq x (cadr pp))
          (setq y (caddr pp))
          (setq z (cadddr pp))
          (command "point" (list x y z))
          (setq ff (open ffn "a"))
          (princ (rtos x 2 q) ff)
          (princ " " ff)
          (princ (rtos y 2 q) ff)
          (princ " " ff)
          (princ (rtos z 2 q) ff)
          (princ "\n" ff)
          (close ff)
          )
        )
      (setq n (1+ n))
      ))
      (progn       
    (repeat (length endata)
      (setq pp (nth n endata))
      (setq key (car pp))      
      (if (= key 10)
        (progn
          (setq x (cadr pp))
          (setq y (caddr pp))          
          (command "point" (list x y))            
          (setq ff (open ffn "a"))
          (princ (rtos x 2 q) ff)
          (princ " " ff)
          (princ (rtos y 2 q) ff)          
          (princ "\n" ff)
          (close ff)
          )
        )
      (setq n (1+ n))
      )
    ))
    (setq ff (open ffn "a"))
    (princ "End\n" ff)
    (close ff)
    (setq i (1+ i))
    )
  (princ (strcat "\n文件写至=> " ffn))
  (prin1)
  )

[/PHP]

xhgzly

什么时候才能学会编程啊啊啊啊啊！郁闷

jjxiao

"还想问一句，不知道你需要用这个做什么？z轴也需要~~~"

呵呵,有点贪心了~~~~想找斑主要个完美的程序!

再次谢谢斑主,向斑主学习编程的知识和助人为乐的高尚品格!!!

lsjjm

最初由 maplesu 发布
[B]...spline的是有z坐标的，pline是没有z坐标的。... [/B]

不是吧??

                 POLYLINE  Layer: "external"
                            Space: Model space
                   at point, X=   1.0000  Y=   1.0000  Z=   1.1110
              ......

maplesu

最初由 lsjjm 发布
[B]

不是吧??

                 POLYLINE  Layer: "external"
                            Space: Mode... [/B]

这个地方可能是我没有说清楚，虽然可以显示出z坐标，但是在autolisp中取得对象数据以后，表示点的顶点坐标的群码为10的项目中只有x,y坐标没有z的。而且在cad中pline是一个二维的，用pline是画不出三维的！

lsjjm

最初由 maplesu 发布
[B]..在cad中pline是一个二维的，用pline是画不出三维的！[/B]

1楼的原问并没有特别指定是二维pline, 而且在3楼再次要求 " 如果可以输入z坐标那这个lisp就很完美啦" . !
用pline画不出三维的来, 难道不能用其他的命令?

maplesu

其实是因为我只学了autolisp（而且时间不长），我认为autolisp没有办法解决这个问题，看了你那个程序了，用你那个函数是可以求得z。还是你的比较好，但是我不知道那个函数的真正意义，可以告诉我吗？还有那个函数你是在那里查到的呢？
你不介意我改改你的程序吧，我想可以利用选择集来循环操作，还有就是可以指定保存文件的路径和名称！

ahlzl

用VBA提取三维多段线的顶点坐标到EXCEL，并保存在C：\1.xls。

2. Sub PL()
   
3. On Error Resume Next
   
4. Dim pnt As Variant
   
5. Dim ent As AcadEntity
   
6. ThisDrawing.Utility.GetEntity ent, pnt, "请选择一条三维多段线："
   
7. 
   
8. 
   
9. Do While ent.ObjectName <> "AcDb3dPolyline"
   
10. ThisDrawing.Utility.Prompt "您选的不是三维多段线！"
    
11. ThisDrawing.Utility.GetEntity ent, pnt, "请选择一条三维多段线："
    
12. Loop
    
13.    
    
14. Set aa = ent
    
15. Dim ps As Variant, n As Long
    
16. ps = aa.Coordinates
    
17. n = UBound(ps)
    
18.    
    
19. Dim xlapp As Object
    
20.    
    
21. Set xlapp = GetObject(, "Excel.Application")
    
22. If Err <> 0 Then
    
23.     Err.Clear
    
24.     Set xlapp = CreateObject("Excel.Application")
    
25.     xlapp.Visible = True
    
26. End If
    
27. 
    
28. Dim xlbook As Object
    
29. Set xlbook = xlapp.Workbooks.Add
    
30. For k = 0 To n Step 3
    
31.     xlbook.ActiveSheet.Cells(k / 3 + 1, 1) = ps(k)
    
32.     xlbook.ActiveSheet.Cells(k / 3 + 1, 2) = ps(k + 1)
    
33.     xlbook.ActiveSheet.Cells(k / 3 + 1, 3) = ps(k + 2)
    
34. Next k
    
35.    
    
36. xlbook.SaveAs ("c:\1.xls")                    '另存为
    
37.    
    
38. End Sub

Sub PL()<br /> On Error Resume Next<br /> Dim pnt As Variant<br /> Dim ent As AcadEntity<br /> ThisDrawing.Utility.GetEntity ent, pnt, "请选择一条三维多段线："<br /> <br /> <br /> Do While ent.ObjectName <> "AcDb3dPolyline"<br /> ThisDrawing.Utility.Prompt "您选的不是三维多段线！"<br /> ThisDrawing.Utility.GetEntity ent, pnt, "请选择一条三维多段线："<br /> Loop<br />    <br /> Set aa = ent<br /> Dim ps As Variant, n As Long<br /> ps = aa.Coordinates<br /> n = UBound(ps)<br />     <br /> Dim xlapp As Object<br />    <br /> Set xlapp = GetObject(, "Excel.Application")<br /> If Err <> 0 Then<br />     Err.Clear<br />     Set xlapp = CreateObject("Excel.Application")<br />     xlapp.Visible = True<br /> End If<br /> <br /> Dim xlbook As Object<br /> Set xlbook = xlapp.Workbooks.Add<br /> For k = 0 To n Step 3<br />     xlbook.ActiveSheet.Cells(k / 3 + 1, 1) = ps(k)<br />     xlbook.ActiveSheet.Cells(k / 3 + 1, 2) = ps(k + 1)<br />     xlbook.ActiveSheet.Cells(k / 3 + 1, 3) = ps(k + 2)<br /> Next k<br />     <br /> xlbook.SaveAs ("c:\1.xls")                    '另存为<br />     <br /> End Sub

用VBALOAD加载，用VBARUN运行。