ＳＯＳ：ＬＩＳＰ程序请教（一次性获取两相交线节点坐标)

limj2007

各位大哥：

新年好！

图中红色为生成的线，黄色的为我画上去的线条，我想用ＬＩＳＰ编一程序,可生成能"获取黄色线节点坐标"（纵横两线交点）程序，生成最好系ＴＸＴ文本格式，有哪位兄弟能帮上这个忙吗？谢谢！

 

fools

我的理解是:你希望求出红线与所有白线的交点,生成黄线和坐标文本,
如果我的理解没有错,程序如下:

2. (DEFUN c:tmp (/ ENT1 ENT2 N PT PTS SSG FILE)
3.   (vl-load-com)
4.   (SETQ ent1 (VLAX-ENAME->VLA-OBJECT (CAR (ENTSEL "\n选取一根红线:"))))
5.   (PRINC "\n选取一组竖向坐标线:")
6.   (SETQ ssg (SSGET '((0 . "LINE"))))
7.   ;;获取交点集
8.   (SETQ pts nil)
9.   (REPEAT (SETQ n (SSLENGTH ssg))
10.     (SETQ ent2 (VLAX-ENAME->VLA-OBJECT (SSNAME ssg (SETQ n (1- n)))))
11.     (IF (SETQ pt (VLAX-INVOKE ent1 'IntersectWith ent2 ACEXTENDNONE))
12.       (SETQ pts (CONS pt pts))
13.     )
14.   )
15.   ;;沿红线对点集排序
16.   (SETQ pts (VL-SORT pts
17.        '(LAMBDA (p1 p2)
18.    (> (VLAX-CURVE-GETPARAMATPOINT ent1 p1)
19.       (VLAX-CURVE-GETPARAMATPOINT ent1 p2)
20.    )
21.         )
22.      )
23.   )
24.   ;;画黄线并写入文件
25.   (SETVAR "clayer" "图层1")
26.   (COMMAND "_.PLINE")
27.   (SETQ file (OPEN "c:/pts.txt" "w"))
28.   (FOREACH item pts
29.     (COMMAND item)
30.     (WRITE-LINE (VL-PRINC-TO-STRING item) file)
31.   )
32.   (CLOSE file)
33.   (COMMAND "")
34.   (PRINC)
35. )

复制代码

limj2007

大哥:

小弟在这里先谢谢你!

你的程序我调用过了,但加载tmp命令点选红线后,出现如下错误:

(选取一根红线:; 错误: no function definition: VLAX-ENAME->VLA-OBJECT)

我要的程序只是能提取"黄线"跟"纵向白色线"<交点坐标>就好了,最好生成的是TXT格式文本,我的图再上传一下,你下载后打开看看就明白我意思了,再一次谢谢你!

fools

对于出现错误:no function definition: VLAX-ENAME->VLA-OBJECT
如果你用的acad2000以后的版本,可在我的程序第一行前添加(vl-load-com),如果是r14就没有办法了
只选黄线,问题就简化为取黄线的节点坐标,不需要求交点,程序如下,可以运行在任何cad版本.

2. (DEFUN c:tmp (/ EL FILE PTS)
3.   (SETQ EL (ENTGET (CAR (ENTSEL "\n选取一根黄线:"))))
4.   (WHILE (AND EL (ASSOC 10 EL))
5.     (SETQ PTS (CONS (ASSOC 10 EL) PTS)
6.    EL  (CDR (MEMBER (CAR PTS) EL))
7.     )
8.   )
9.   ;;写入文件
10.   (SETQ file (OPEN "c:/pts.txt" "w"))
11.   (FOREACH item (MAPCAR 'CDR (REVERSE pts))
12.     ;;下一行的","可改为其他的分隔符,比如" " "\t"
13.     (WRITE-LINE
14.       (STRCAT (RTOS (CAR item) 2 3) "," (RTOS (CADR item) 2 3))
15.       file
16.     )
17.   )
18.   (CLOSE file)
19.   (PRINC)
20. )

复制代码

limj2007

兄弟:

感谢你为我编的这程序,真的谢谢!

但程序还是用不了,我加载程序后,用TMP命令,然后选取黄色线条,但就没有了下文了,是否程序出现错乱,麻烦你看看,谢谢!

limj2007

在线等侯你回复，你ＱQ号系几多？我加你为好友．

fools

忘记告诉你了,到硬盘的c驱下找pts.txt文件,里面就是所有的点
新程序增加了一句,会自动打开pts.txt,方便你操作.

3. (DEFUN c:tmp (/ EL FILE PTS)
4.    (SETQ EL (ENTGET (CAR (ENTSEL "\n选取一根黄线:"))))
5.    (WHILE (AND EL (ASSOC 10 EL))
6.      (SETQ PTS (CONS (ASSOC 10 EL) PTS)
7.     EL  (CDR (MEMBER (CAR PTS) EL))
8.      )
9.    )
10.    ;;写入文件
11.    (SETQ file (OPEN "c:/pts.txt" "w"))
12.    (FOREACH item (MAPCAR 'CDR (REVERSE pts))
13.      ;;下一行的","可改为其他的分隔符,比如" " "\t"
14.      (WRITE-LINE
15.        (STRCAT (RTOS (CAR item) 2 3) "," (RTOS (CADR item) 2 3))
16.        file
17.      )
18.    )
19.    (CLOSE file)
20.    (startapp "notepad" "c:/pts.txt")
21.    (PRINC)
22. )

复制代码

不好意思,很少聊天,以前的qq号被盗,就没有再申请了

limj2007

兄弟:

你好!

真谢谢你了,程序可用了,而且你改正后挺好用的,谢谢你!

以前我用LISP命令提取坐标,再经文本编辑小软件编著它,现在工作量快多了,真的谢谢你!

你的编程技术太高了,有什么事再请教你,还望留下你的大名.谢谢!