求能够连续测量多点间距的lsp程序

chengx2000

直接写一个程序不就可以了吗，这样的程序有不难。

soonsos

9楼的方法我也想过，整合到一个程序里面。问题是我要具体的程序呀！！！谁能编出来！！

wdq10105

求多点距离，并显示在屏幕

2. (defun c:dd (/ pt pts dis p1 pp ppp );连续测量线段总长
   
3.   (setvar "cmdecho" 0)
   
4.   (setq K (getvar "dimscale"))
   
5.   (setq t_h (* 3 k))
   
6.   (command "style" "xywzgs" "txt,hztxt" t_h 0.8 0 "n" "n" "n")         
   
7.   (while (setq pt (getpoint "\n请选取点： "))
   
8.    
   
9.     (if        (not p1)
   
10.            (setq p1 pt)
    
11.       
    
12.     )
    
13.    
    
14.     (setq pts (cons pt pts))
    
15.     (if (>= (length pts) 2)
    
16.      (grdraw pt p1 1))
    
17.     (setq p1 pt)
    
18.   )
    
19.   (setq dis 0.)
    
20.   (if pts
    
21.     (mapcar '(lambda (x y)
    
22.                (setq dis (+ dis (distance x y)))
    
23.              )
    
24.             (reverse (cdr (reverse pts)))
    
25.             (cdr pts)
    
26.     )
    
27.           )
    
28.   ;;(apply 'command (cons ".pline" pts))
    
29.   ;;(command)
    
30.   (if (not (zerop dis))
    
31.      (progn
    
32.      (setq pp (* 0.001 dis))
    
33.      (setq ppp (rtos pp 2 3))
    
34.         (princ (strcat "\n线段总长 = " ppp "米\n"))
    
35.     (command "Text" "s" "xywzgs" p1 "0" PPP )
    
36.     (command "move" "L" "" "@" )
    
37.      ))
    
38.   (princ)
    
39. )
    

(defun c:dd (/ pt pts dis p1 pp ppp );连续测量线段总长<br />   (setvar "cmdecho" 0)<br />   (setq K (getvar "dimscale"))<br />   (setq t_h (* 3 k))<br />   (command "style" "xywzgs" "txt,hztxt" t_h 0.8 0 "n" "n" "n")         <br />   (while (setq pt (getpoint "\n请选取点： "))<br />     <br />     (if        (not p1)<br />            (setq p1 pt)<br />       <br />     )<br />     <br />     (setq pts (cons pt pts))<br />     (if (>= (length pts) 2)<br />      (grdraw pt p1 1))<br />     (setq p1 pt)<br />   )<br />   (setq dis 0.)<br />   (if pts<br />     (mapcar '(lambda (x y)<br />                (setq dis (+ dis (distance x y)))<br />              )<br />             (reverse (cdr (reverse pts)))<br />             (cdr pts)<br />     )<br />           )<br />   ;;(apply 'command (cons ".pline" pts))<br />   ;;(command)<br />   (if (not (zerop dis))<br />      (progn<br />      (setq pp (* 0.001 dis))<br />      (setq ppp (rtos pp 2 3))<br />         (princ (strcat "\n线段总长 = " ppp "米\n")) <br />     (command "Text" "s" "xywzgs" p1 "0" PPP )<br />     (command "move" "L" "" "@" )<br />      ))<br />   (princ)<br /> )<br />

soonsos

13楼的程序恐怕是抄的网上的，里面依旧使用了grdraw函数，这个函数有个不好的地方就是：鼠标移动后，grdraw函数产生的红色轨迹就消失了，以致使用者不知道侧料到何处了！！！

caoyin

chg 发表于 2011-1-23 21:56
dist 命令里不是有个多点选项吗？

可能低版本的cad没有，但我的是2011是有多点选项的
命令: DIST
指定第一点:
指定第二个点或 [多个点(M)]: m
指定下一个点或 [圆弧(A)/长度(L)/放弃(U)/总计(T)] <总计>:

写一个也很方便：
;;;;以下代码引用置顶贴子的函数 http://bbs.mjtd.com/thread-85250-1-1.html

1. 
   
2. ;;;以下代码引用置顶贴子的函数 http://bbs.mjtd.com/thread-85250-1-1.html
   
3. ;;;by caoyin 2011.1.28
   
4. (defun C:DIT (/ P1 PW  P2 OBJ DI)
   
5.   (initget "Object")
   
6.   (setq P1 (getpoint "\n指定第一点或 [对象(O)] <对象>: "))
   
7.   (if (vl-consp P1)
   
8.     (progn
   
9.       (setq PW (getvar 'PLINEWID))
   
10.       (setvar 'PLINEWID 0)
    
11.       (command "_.PLINE" P1)
    
12.       (while (setq p2 (getpoint p1 "\n指定下一点: "))
    
13.         (command P2)
    
14.         (setq P1 P2)
    
15.       )
    
16.       (command "")
    
17.       (setq OBJ (list (entlast)))
    
18.       (setvar 'PLINEWID PW)
    
19.     )
    
20.     (if (setq OBJ (ssget '((0 . "LINE,*POLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))
    
21.       (setq OBJ (MJ:SS->LIST OBJ))
    
22.     )
    
23.   )
    
24.   (setq DI (apply '+ (mapcar '(lambda (x)
    
25.                                 (vlax-curve-getdistatparam X (vlax-curve-getendparam X))
    
26.                               )
    
27.                               OBJ
    
28.                      )
    
29.            )
    
30.   )
    
31.   (MJ:Print-LIST
    
32.     (list "总长度=" (MJ:RTOS DI) "。")
    
33.   )
    
34.   (if (vl-consp P1) (entdel (car OBJ)))
    
35.   (princ)
    
36. )
    
37. 
    

<br /> ;;;以下代码引用置顶贴子的函数 <a href="http://bbs.mjtd.com/thread-85250-1-1.html" target="_blank">http://bbs.mjtd.com/thread-85250-1-1.html</a><br /> ;;;by caoyin 2011.1.28<br /> (defun C:DIT (/ P1 PW  P2 OBJ DI)<br />   (initget "Object")<br />   (setq P1 (getpoint "\n指定第一点或 [对象(O)] <对象>: "))<br />   (if (vl-consp P1)<br />     (progn<br />       (setq PW (getvar 'PLINEWID))<br />       (setvar 'PLINEWID 0)<br />       (command "_.PLINE" P1)<br />       (while (setq p2 (getpoint p1 "\n指定下一点: "))<br />         (command P2)<br />         (setq P1 P2)<br />       )<br />       (command "")<br />       (setq OBJ (list (entlast)))<br />       (setvar 'PLINEWID PW)<br />     )<br />     (if (setq OBJ (ssget '((0 . "LINE,*POLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))<br />       (setq OBJ (MJ:SS->LIST OBJ))<br />     )<br />   )<br />   (setq DI (apply '+ (mapcar '(lambda (x)<br />                                 (vlax-curve-getdistatparam X (vlax-curve-getendparam X))<br />                               )<br />                               OBJ<br />                      )<br />            )<br />   )<br />   (MJ:Print-LIST<br />     (list "总长度=" (MJ:RTOS DI) "。")<br />   )<br />   (if (vl-consp P1) (entdel (car OBJ)))<br />   (princ)<br /> )<br /> <br />