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

cqsnowfox

(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或者直接解释其编程算法啊

xyp1964

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. |;
    
13. 
    
14. ;;;多义线顶点序号及坐标标注，可输出坐标数据到文本文件
    
15. (defun c:test065 ()
    
16.   (CMDLASC0)
    
17.   (setq        tx1 (UKWORD 7 "1 2" "\n确定顶点顺序 : 1-正向/2-反向" tx1)
    
18.         tx2 (UKWORD 7 "Y N" "\n是否输出顶点坐标数据 : Y-是/N-否" tx2)
    
19.   )
    
20.   (if (= tx2 "Y")
    
21.     (setq ffn (getfiled "\n保存的坐标文件" "坐标" "txt" 1)
    
22.           ff  (open ffn "w")
    
23.     )
    
24.   )
    
25.   (while (setq en (car (entsel "\n选择对象<退出> : ")))
    
26.     (if        (or (= (xyp-get-DXF 0 en) "POLYLINE")
    
27.             (= (xyp-get-DXF 0 en) "LWPOLYLINE")
    
28.         )
    
29.       (progn
    
30.         (setq ptn (xyp-get-Vertexs en 1)
    
31.               i          -1
    
32.               j          0
    
33.         )
    
34.         (if (= tx1 "2")                        ;反向
    
35.           (setq ptn (reverse ptn))
    
36.         )
    
37.         (foreach pt ptn
    
38.           (MKLA "坐标编号" 1)
    
39.           (xyp-Text 3 pt (itoa (setq j (1+ j))))
    
40.           (MKLA "坐标" 3)
    
41.           (xyp-ZB pt)
    
42.           (if (= tx2 "Y")
    
43.             (wr-tx pt ff)
    
44.           )
    
45.         )
    
46.       )
    
47.     )
    
48.   )
    
49.   (if (= tx2 "Y")
    
50.     (progn
    
51.       (close ff)
    
52.       (princ (strcat "\n 坐标写至=>" ffn))
    
53.     )
    
54.   )
    
55.   (CMDLA1)
    
56. )
    
57. (defun wr-tx (point filename / tx)
    
58.   (setq        tx (strcat
    
59.              (rtos (car point) 2)
    
60.              " "
    
61.              (rtos (cadr point) 2)
    
62.              " "
    
63.              (rtos (caddr point) 2)
    
64.            )
    
65.   )
    
66.   (write-line tx filename)
    
67. )[/FONT]

[FONT=courier new](load "xyp_lib.vlx")  ;版本 V.20051205 (1781)<br /> ;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下)<br /> 利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：<br /> ★1·在acad.lsp中增加(load"xyp_lib.vlx")<br /> ■2·在每个程序内增加(load"xyp_lib.vlx")<br /> ■3·在command下，输入(load"xyp_lib.vlx")<br /> ■4·在菜单.mnl中增加(load"xyp_lib.vlx")<br /> ■5·将xyp_lib.vlx文件直接拽到cad屏幕<br /> [COLOR=red] ★通用函数下载地址：[/COLOR]<br /> [url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url]<br /> |;<br /> <br /> ;;;多义线顶点序号及坐标标注，可输出坐标数据到文本文件<br /> (defun c:test065 ()<br />   (CMDLASC0)<br />   (setq        tx1 (UKWORD 7 "1 2" "\n确定顶点顺序 : 1-正向/2-反向" tx1)<br />         tx2 (UKWORD 7 "Y N" "\n是否输出顶点坐标数据 : Y-是/N-否" tx2)<br />   )<br />   (if (= tx2 "Y")<br />     (setq ffn (getfiled "\n保存的坐标文件" "坐标" "txt" 1)<br />           ff  (open ffn "w")<br />     )<br />   )<br />   (while (setq en (car (entsel "\n选择对象<退出> : ")))<br />     (if        (or (= (xyp-get-DXF 0 en) "POLYLINE")<br />             (= (xyp-get-DXF 0 en) "LWPOLYLINE")<br />         )<br />       (progn<br />         (setq ptn (xyp-get-Vertexs en 1)<br />               i          -1<br />               j          0<br />         )<br />         (if (= tx1 "2")                        ;反向 <br />           (setq ptn (reverse ptn))<br />         )<br />         (foreach pt ptn<br />           (MKLA "坐标编号" 1)<br />           (xyp-Text 3 pt (itoa (setq j (1+ j))))<br />           (MKLA "坐标" 3)<br />           (xyp-ZB pt)<br />           (if (= tx2 "Y")<br />             (wr-tx pt ff)<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (if (= tx2 "Y")<br />     (progn<br />       (close ff)<br />       (princ (strcat "\n 坐标写至=>" ffn))<br />     )<br />   )<br />   (CMDLA1)<br /> )<br /> (defun wr-tx (point filename / tx)<br />   (setq        tx (strcat<br />              (rtos (car point) 2)<br />              " "<br />              (rtos (cadr point) 2)<br />              " "<br />              (rtos (caddr point) 2)<br />            )<br />   )<br />   (write-line tx filename)<br /> )[/FONT]

yshf

;;;封闭多边形顶点排序 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)        
)

xxming

cqsnowfox ,这是我写的程序你有什么不明白的?这是受xyp1964 程序的启发不懂你可问xyp1964

MUYIY

学习力，谢谢