找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 1609|回复: 4

[LISP程序]:帮我看看这段lisp程序好吗?是对多段线顶点编号的程序

[复制链接]
发表于 2005-12-10 11:03:02 | 显示全部楼层 |阅读模式

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

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

×
(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)

有哪位朋友可以将这个程序转成VBA或者直接解释其编程算法啊

菜冬瓜 (19375389)  (2005-12-10 10:15:24)
  
菜冬瓜 (19375389)  (2005-12-10 10:15:01)
  
天堂鸟(552128916)  (2005-12-10 10:14:27)
有人在吗?
天堂鸟(552128916)  (2005-12-10 00:25:25)
(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)

有哪位朋友可以将这个程序转成VBA或者直接解释其编程算法啊
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
发表于 2005-12-10 11:32:52 | 显示全部楼层
  1. [FONT=courier new](load "xyp_lib.vlx")  ;版本 V.20051205 (1781)
  2. ;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下)
  3. 利用以下任何一种方式(首选第一种)即可加载和运行通用函数内的所有子程序:
  4. ★1·在acad.lsp中增加(load"xyp_lib.vlx")
  5. ■2·在每个程序内增加(load"xyp_lib.vlx")
  6. ■3·在command下,输入(load"xyp_lib.vlx")
  7. ■4·在菜单.mnl中增加(load"xyp_lib.vlx")
  8. ■5·将xyp_lib.vlx文件直接拽到cad屏幕
  9. [COLOR=red] ★通用函数下载地址:[/COLOR]
  10. [url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url]
  11. |;

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

使用道具 举报

已领礼包: 111个

财富等级: 日进斗金

发表于 2005-12-12 14:31:25 | 显示全部楼层
;;;封闭多边形顶点排序 by yshf
;;;测试程序
;;;将下载的文件“dbxddpx.fas”
;;;存到“L”盘中,如存入其它地方,
;;;请更改程序中第二行中的相应路径名。
;;;用于地藉测量中对宗地界址点编号和排序。

(defun c:cc()
   (if (null dbxddpx)(load "L:dbxddpx.fas"));请注意文件“dbxddpx.fas”存盘路径名
   (setq xtblm '("cmdecho" "osmode")
         xtblz (mapcar 'getvar xtblm)
   )
   (mapcar 'setvar xtblm '(0 0))
   (command "_undo" "be")
   (while (setq en (sel "请选择封闭多段线(LWPOLYLINE/POLYLINE)(按Esc键退出程序)"
                        "LWPOLYLINE,POLYLINE"
                )
          )
      (initget 1 "1 2 3 4")
      (setq pjd (getkword "西北角(1)/西南角(2)/东南角/(3)东北角(4):"))
      (initget 1 "1 2")
      (setq snj (getkword "顺时针(1)/逆时针(2):"))
      ;返回按要求排好序的顶点列表,并赋值给fhb
      (setq fhb (dbxddpx (car en) (read pjd) (read snj))
     i 1
      )
      (foreach pt0 fhb
        (command "_circle" pt0 1 "_chprop" (entlast) "" "c" 1 ""
        "_text" (mapcar '+ pt0 '(0.7 0.7)) 2.5 0 (itoa i)
        "_chprop" (entlast) "" "c" 3 ""
        )
        (setq i (1+ i))
     )
   )
   (command "_undo" "e")
   (mapcar 'setvar xtblm xtblz)(princ)        
)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2005-12-12 20:09:12 | 显示全部楼层
cqsnowfox ,这是我写的程序你有什么不明白的?这是受xyp1964 程序的启发不懂你可问xyp1964
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 33个

财富等级: 招财进宝

发表于 2022-6-11 15:36:27 | 显示全部楼层
学习力,谢谢
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

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

GMT+8, 2024-6-25 19:29 , Processed in 0.232897 second(s), 40 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

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