cqsnowfox 发表于 2005-12-10 11:03:02

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

(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 发表于 2005-12-10 11:32:52

(load "xyp_lib.vlx");版本 V.20051205 (1781)
;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下)
利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：
★1·在acad.lsp中增加(load"xyp_lib.vlx")
■2·在每个程序内增加(load"xyp_lib.vlx")
■3·在command下，输入(load"xyp_lib.vlx")
■4·在菜单.mnl中增加(load"xyp_lib.vlx")
■5·将xyp_lib.vlx文件直接拽到cad屏幕
★通用函数下载地址：
http://www.xdcad.net/forum/attachment.php?s=&postid=1606661
|;

;;;多义线顶点序号及坐标标注，可输出坐标数据到文本文件
(defun c:test065 ()
(CMDLASC0)
(setq        tx1 (UKWORD 7 "1 2" "\n确定顶点顺序 : 1-正向/2-反向" tx1)
        tx2 (UKWORD 7 "Y N" "\n是否输出顶点坐标数据 : Y-是/N-否" tx2)
)
(if (= tx2 "Y")
    (setq ffn (getfiled "\n保存的坐标文件" "坐标" "txt" 1)
          ff(open ffn "w")
    )
)
(while (setq en (car (entsel "\n选择对象<退出> : ")))
    (if        (or (= (xyp-get-DXF 0 en) "POLYLINE")
          (= (xyp-get-DXF 0 en) "LWPOLYLINE")
        )
      (progn
        (setq ptn (xyp-get-Vertexs en 1)
              i          -1
              j          0
        )
        (if (= tx1 "2")                        ;反向
          (setq ptn (reverse ptn))
        )
        (foreach pt ptn
          (MKLA "坐标编号" 1)
          (xyp-Text 3 pt (itoa (setq j (1+ j))))
          (MKLA "坐标" 3)
          (xyp-ZB pt)
          (if (= tx2 "Y")
          (wr-tx pt ff)
          )
        )
      )
    )
)
(if (= tx2 "Y")
    (progn
      (close ff)
      (princ (strcat "\n 坐标写至=>" ffn))
    )
)
(CMDLA1)
)
(defun wr-tx (point filename / tx)
(setq        tx (strcat
             (rtos (car point) 2)
             " "
             (rtos (cadr point) 2)
             " "
             (rtos (caddr point) 2)
           )
)
(write-line tx filename)
)

yshf 发表于 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)      
)

xxming 发表于 2005-12-12 20:09:12

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

MUYIY 发表于 2022-6-11 15:36:27

学习力，谢谢
页: [1]
查看完整版本: [LISP程序]：帮我看看这段lisp程序好吗？是对多段线顶点编号的程序