设为首页收藏本站转
发帖领奖家园QQ群申请版主版主评价切换到宽版

 找回密码
 立即注册

QQ登录

只需一步，快速开始

扫一扫，访问微社区

晓东CAD家园-论坛»论坛 › ╃CAD编程开发 › A/VLISP › [LISP程序]：帮我看看这个LSP程序好吗？
返回列表 发新帖
查看: 950|回复: 4

[LISP程序]：帮我看看这个LSP程序好吗？

[复制链接]
cqsnowfox
发表于 2005-12-10 18:47:35 | 显示全部楼层 |阅读模式
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要 登录 才可以下载或查看，没有账号？立即注册

×
(defun c:bh()
;编号高度
(if (null h)
(setq h (getvar "textsize"))
)
(setq input (getreal(strcat"\\n\\t输入编号高度<" (rtos h) ">")))
(if (/= input nil)
(setq h input)
)
-------------------------------------
(initget "1 2")
(setq key (getkword"\\n\\t1-正向编号/2-反向编号<1>:"))
(setq s1 (entsel"\\n\\t选择对象<退出>"))
(setq ent (entget(car s1)))
(redraw (car s1) 3)
(setq pt0 (getpoint "\\n选择编号起号位置"))
(setq x (car pt0))
(setq y (cadr pt0))
(redraw (car s1) 4)
(setq n (cdr(assoc 90 ent)))

;正向编号
(if (or (= key 1) (= key nil))
(progn
(command "text" pt0 h "0" 1)
(setq plist (member (list 10 x y) ent))
(SETQ pplist (member(assoc 10 ent) ent))
(setq count 1)
(setq d (cdr plist))
(setq plist (member (assoc 10 d) d))
(while (/= plist nil)
(setq count (1+ count))
(setq pp_t (car plist))
(setq pp (cdr pp_t))
(command "text" pp h "0" (itoa count))
(setq d (cdr plist))
(setq plist (member (assoc 10 d) d))
)
(while (/= pplist nil)
(setq count (1+ count))
(setq pp_t (car pplist))
(setq pp (cdr pp_t))
(setq pp_x (car pp))
(setq pp_y (cadr pp))
(if (and (= pp_x x) (= pp_y y))
(exit)
(progn
(command "text" pp h "0" (itoa count))
(setq d (cdr pplist))
(setq pplist (member (assoc 10 d) d))
);end progn
);end if
);end while
);end progn
;反向编号
(progn
(command "text" pt0 h "0" (itoa n))
(setq plist (member (list 10 x y) ent))
(SETQ pplist (member(assoc 10 ent) ent))
(setq d (cdr plist))
(setq plist (member (assoc 10 d) d))
(setq n (1- n))
(while (/= plist nil)
(setq pp_t (car plist))
(setq pp (cdr pp_t))
(command "text" pp h "0" (itoa n))
(setq d (cdr plist))
(setq plist (member (assoc 10 d) d))
(setq n (1- n))
)

(while (/= pplist nil)
(setq pp_t (car pplist))
(setq pp (cdr pp_t))
(setq pp_x (car pp))
(setq pp_y (cadr pp))
(if (and (= pp_x x) (= pp_y y))
(exit)
(progn
(command "text" pp h "0" (itoa n))
(setq d (cdr pplist))
(setq pplist (member (assoc 10 d) d))
(setq n (1- n))
);end progn
);end if
);end while
);end progn
);end if
);end defun
(prompt"\\n多义线角点自动编号程序,键入：bh执行,程序设计：小谢")
(princ)

请讲讲其编程思路好吗？我不懂LSP，我想将其改为vba
setq, plist, pp

相关帖子

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复

使用道具 举报

似水无痕
发表于 2005-12-11 00:08:43 | 显示全部楼层
我大致看了一下，主要意图是给pline线节点写编号的程序，主要看了一下正向编号的程序，大致思路是这样的（一下内容为正向编号，即代码为1）：
程序执行后先输入“字体高度”，依次为选择“正反向编号代码（1为正向，2为反向）”，选择pline线及需要输入编号的第一个节点（鼠标输入后程序会在该点写入编号“1”），程序自动去选择plist剩余节点然后进行相应编号，假如所选的第一个节点并非pline线的起点，程序在转回起点进行累加编号。
另：程序中还有几处错误！(if (or (= key 1) (= key nil))应改为(if (or (= key "1") (= key nil))
(command "text" pt0 h "0" 1)应改为(command "text" pt0 h "0" "1")
更改后的程序：
  2. (defun c:bh ()
  3.                                         ;编号高度
  4.   (if (null h)
  5.     (setq h (getvar "textsize"))
  6.   )
  7.   (setq input (getreal (strcat "\\n\\t输入编号高度<" (rtos h) ">")))
  8.   (if (/= input nil)
  9.     (setq h input)
  10.   )
  11.   (initget "1 2")
  12.   (setq key (getkword "\\n\\t1-正向编号/2-反向编号<1>:"))
  13.   (setq s1 (entsel "\\n\\t选择对象<退出>"))
  14.   (setq ent (entget (car s1)))
  15.   (redraw (car s1) 3)
  16.   (setq pt0 (getpoint "\\n选择编号起号位置"))
  17.   (setq x (car pt0))
  18.   (setq y (cadr pt0))
  19.   (redraw (car s1) 4)
  20.   (setq n (cdr (assoc 90 ent)))

  22.                                         ;正向编号
  23.   (if (or (= key "1") (= key nil))
  24.     (progn
  25.       (command "text" pt0 h "0" "1")
  26.       (setq plist (member (list 10 x y) ent))
  27.       (SETQ pplist (member (assoc 10 ent) ent))
  28.       (setq count 1)
  29.       (setq d (cdr plist))
  30.       (setq plist (member (assoc 10 d) d))
  31.       (while (/= plist nil)
  32.         (setq count (1+ count))
  33.         (setq pp_t (car plist))
  34.         (setq pp (cdr pp_t))
  35.         (command "text" pp h "0" (itoa count))
  36.         (setq d (cdr plist))
  37.         (setq plist (member (assoc 10 d) d))
  38.       )
  39.       (while (/= pplist nil)
  40.         (setq count (1+ count))
  41.         (setq pp_t (car pplist))
  42.         (setq pp (cdr pp_t))
  43.         (setq pp_x (car pp))
  44.         (setq pp_y (cadr pp))
  45.         (if (and (= pp_x x) (= pp_y y))
  46.           (exit)
  47.           (progn
  48.             (command "text" pp h "0" (itoa count))
  49.             (setq d (cdr pplist))
  50.             (setq pplist (member (assoc 10 d) d))
  51.           )                                ;end progn
  52.         )                                ;end if
  53.       )                                        ;end while
  54.     )                                        ;end progn
  55.                                         ;反向编号
  56.     (progn
  57.       (command "text" pt0 h "0" (itoa n))
  58.       (setq plist (member (list 10 x y) ent))
  59.       (SETQ pplist (member (assoc 10 ent) ent))
  60.       (setq d (cdr plist))
  61.       (setq plist (member (assoc 10 d) d))
  62.       (setq n (1- n))
  63.       (while (/= plist nil)
  64.         (setq pp_t (car plist))
  65.         (setq pp (cdr pp_t))
  66.         (command "text" pp h "0" (itoa n))
  67.         (setq d (cdr plist))
  68.         (setq plist (member (assoc 10 d) d))
  69.         (setq n (1- n))
  70.       )

  72.       (while (/= pplist nil)
  73.         (setq pp_t (car pplist))
  74.         (setq pp (cdr pp_t))
  75.         (setq pp_x (car pp))
  76.         (setq pp_y (cadr pp))
  77.         (if (and (= pp_x x) (= pp_y y))
  78.           (exit)
  79.           (progn
  80.             (command "text" pp h "0" (itoa n))
  81.             (setq d (cdr pplist))
  82.             (setq pplist (member (assoc 10 d) d))
  83.             (setq n (1- n))
  84.           )                                ;end progn
  85.         )                                ;end if
  86.       )                                        ;end while
  87.     )                                        ;end progn
  88.   )                                        ;end if
  89. )                                        ;end defun
  90. (prompt
  91.   "\\n多义线角点自动编号程序,键入：bh执行,程序设计：小谢"
  92. )
  93. (princ)

以下图片是程序执行结果，点1即为输入编号的第一个节点（本来想做个flash动画，可惜我的软件过期了）：
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

cqsnowfox
 楼主| 发表于 2005-12-11 22:14:05 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
我想知道它是怎样判断起始点逆时针方向下一点的算法，麻烦再看看讲详细点好吗？
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

似水无痕
发表于 2005-12-11 22:58:38 | 显示全部楼层
逆向标注程序主要在以下代码：
  2.     (progn
  3.       (command "text" pt0 h "0" (itoa n))
  4.       (setq plist (member (list 10 x y) ent))
  5.       (SETQ pplist (member (assoc 10 ent) ent))
  6.       (setq d (cdr plist))
  7.       (setq plist (member (assoc 10 d) d))
  8.       (setq n (1- n))
  9.       (while (/= plist nil)
  10.         (setq pp_t (car plist))
  11.         (setq pp (cdr pp_t))
  12.         (command "text" pp h "0" (itoa n))
  13.         (setq d (cdr plist))
  14.         (setq plist (member (assoc 10 d) d))
  15.         (setq n (1- n))
  16.       )

  18.       (while (/= pplist nil)
  19.         (setq pp_t (car pplist))
  20.         (setq pp (cdr pp_t))
  21.         (setq pp_x (car pp))
  22.         (setq pp_y (cadr pp))
  23.         (if (and (= pp_x x) (= pp_y y))
  24.           (exit)
  25.           (progn
  26.             (command "text" pp h "0" (itoa n))
  27.             (setq d (cdr pplist))
  28.             (setq pplist (member (assoc 10 d) d))
  29.             (setq n (1- n))
  30.           )                                ;end progn
  31.         )                                ;end if
  32.       )                                        ;end while
  33.     )                                        ;end progn
  34.   )                                        ;end if
  35. )

我想你是问如何取得下一个点吧？
程序通过member函数搜索图元列表中包含的节点，并从节点的第一次出现处返回表的其余部分，即(setq plist (member (assoc 10 d) d))一句，然后用cadr函数取得去除该点表达式的其余部分返回给表pp 即(setq pp (cdr pp_t))一句，重复以上步骤直到点取完为止（该步骤通过(while (/= plist nil)以下语句实现）！
我的表达能力有限，感觉说得我都糊涂了！呵呵！
其实vlisp编辑器中有设置断点和添加监视功能（即实时查看变量）！可以结合这个方法让程序一步一步运行，这样检查程序比较方便！
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

xyp1964
发表于 2005-12-11 23:49:17 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
最初由 cqsnowfox 发布
[B]我想知道它是怎样判断起始点逆时针方向下一点的算法，麻烦再看看讲详细点好吗？ [/B]

对于非封闭多段线是没有“起始点逆时针方向”之说的。
画图的顺序为正向，否则为反向。
  2. [FONT=courier new](load "xyp_lib.vlx")  ;版本 V.20051205 (1781)
  3. ;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下)
  4. 利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：
  5. ★1·在acad.lsp中增加(load"xyp_lib.vlx")
  6. ■2·在每个程序内增加(load"xyp_lib.vlx")
  7. ■3·在command下，输入(load"xyp_lib.vlx")
  8. ■4·在菜单.mnl中增加(load"xyp_lib.vlx")
  9. ■5·将xyp_lib.vlx文件直接拽到cad屏幕
  10. [COLOR=red] ★通用函数下载地址：[/COLOR]
  11. [url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url]
  12. |;

  14. ;;;功能 : 多义线顶点序号及坐标标注，可输出坐标数据到文本文件。
  15. ;;;适用于 POLYLINE 及 LWPOLYLINE 图元
  16. (defun c:test065 ()
  17.   (CMDLASC0)
  18.   (setq        tx1 (UKWORD 1 "1 2" "\n确定顶点顺序 : 1-正向/2-反向" tx1)
  19.         tx2 (UKWORD 1 "Y N" "\n是否输出顶点坐标数据 : Y-是/N-否" tx2)
  20.   )
  21.   (if (= tx2 "Y")
  22.     (setq ffn (getfiled "\n保存的坐标文件" "坐标" "txt" 1)
  23.           ff  (open ffn "w")
  24.     )
  25.   )
  26.   (while (setq en (car (entsel "\n选择对象<退出> : ")))
  27.     (if        (or (= (xyp-get-DXF 0 en) "POLYLINE")
  28.             (= (xyp-get-DXF 0 en) "LWPOLYLINE")
  29.         )
  30.       (progn
  31.         (setq ptn (xyp-get-Vertexs en 1)
  32.               i          -1
  33.               j          0
  34.         )
  35.         ;;反向
  36.         (if (= tx1 "2")
  37.           (setq ptn (reverse ptn))
  38.         )
  39.         (foreach pt ptn
  40.           (MKLA "坐标编号" 1)
  41.           (xyp-Text 3 pt (itoa (setq j (1+ j))))
  42.           (MKLA "坐标" 3)
  43.           (xyp-ZB pt)
  44.           (if (= tx2 "Y")
  45.             (wr-tx pt ff)
  46.           )
  47.         )
  48.       )
  49.     )
  50.   )
  51.   (if (= tx2 "Y")
  52.     (progn
  53.       (close ff)
  54.       (princ (strcat "\n 坐标写至=>" ffn))
  55.     )
  56.   )
  57.   (CMDLA1)
  58. )
  59. (defun wr-tx (point filename / tx)
  60.   (setq        tx (strcat
  61.              (rtos (car point) 2)
  62.              " "
  63.              (rtos (cadr point) 2)
  64.              " "
  65.              (rtos (caddr point) 2)
  66.            )
  67.   )
  68.   (write-line tx filename)
  69. )[/FONT]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-11-15 14:52 , Processed in 0.370583 second(s), 40 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表