[其他]：天正6下Lisp编程

Free-Lancer

看到wharan朋友写了两个天正6下的程序，也忍不住试了一把。首先看了看TArch6 目录，在SYS目录下有 dxf参考.doc 里面是常用实体的DXF组码，有了这个就可以使用 entmake 制造实体了。
既然用Lisp编程当然有得力的 API 将达到事半功倍的效果了，在天正下就用天正的二维核心 tch3_kernal.arx 中提供的就可以。
介绍几个关于程序结构的使用函数

1. 
   
2. 1  begin 标记程序开始
   
3. 调用方法： (begin) & (begin lyrname)
   
4. 2 end  标记程序结束，与 begin 配对使用
   
5. 调用方法：(end)
   
6. 3 ucson ucsoff 配对使用，功能就不用说了
   
7. 4 getss 将选择集放入内部数据库 （不知道最多可以存几个）
   
8. 调用方法：(getss ss 0)
   
9. 5 namess 依次获取内部数据库实体
   
10. 调用方法: (namess 0) 配合 getss 使用
    
11. 6 socas 获取内部数据库实体的组码值
    
12. 调用方法：(socas 0) ->可能返回 "LINE"
    
13. 7 getent 将实体放入内部数据库
    
14. 调用方法：(getent <ent>)
    
15. 说明：用gete获取的实体，ent可选
    
16. 8 modent 修改内部数据库实体的组码
    
17. 调用方法：(modent code var)
    
18. Sample： (modent 10 '(0 . 0. 0.))

复制代码

以上说明仅对本人使用的天正6，可能函数名称在各版中有所不同，请自行对照。
用上面的函数修改坐标参数可以这样（当然用特性也很方便）

1. 
   
2. (getent (car (entsel)) ;;拾取坐标
   
3. (modent 40 4);;修改字高
   

复制代码

以下是一个批量标注的例子（运行环境 AutoCAD 2004 + Tarch6）

2. 
   
3. ;;-----------------------------------------------
   
4. ;; CDNC5-02.LSP
   
5. ;; Bill Kramer
   
6. ;; Find all intersections between objects in
   
7. ;; the selection set SS.
   
8. ;; Process - Create drawing with intersecting lines and lwpolylines.
   
9. ;;           Load function set
   
10. ;;           Run command function INTLINES
    
11. ;;           Intersections are marked with POINT objects on current layer
    
12. (defun INTLINES        (ss / SSL                ;length of SS
    
13.                  PTS                        ;returning list
    
14.                  AOBJ1                        ;Object 1
    
15.                  AOBJ2                        ;Object 2
    
16.                  N1                        ;Loop counter
    
17.                  N2                        ;Loop counter
    
18.                  IPTS                        ;intersects
    
19.                  A N NN        HOLDOSMODE)
    
20.   (setq        N1  0                                ;index for outer loop
    
21.         SSL (sslength SS)
    
22.   )                                        ; Outer loop, first through second to last
    
23.   (while (< N1 (1- SSL))                ; Get object 1, convert to VLA object type
    
24.     (setq AOBJ1        (ssname SS N1)
    
25.           AOBJ1        (vlax-ename->vla-object AOBJ1)
    
26.           N2        (1+ N1)
    
27.     )                                        ;index for inner loop
    
28. ;;; Inner loop, go through remaining objects
    
29.     (while (< N2 SSL)                        ; Get object 2, convert to VLA object
    
30.       (setq AOBJ2 (ssname SS N2)
    
31.             AOBJ2 (vlax-ename->vla-object AOBJ2)
    
32. ;;;Find intersections of Objects
    
33.             IPTS  (vla-intersectwith
    
34.                     AOBJ1
    
35.                     AOBJ2
    
36.                     0
    
37.                   )                        ; variant result
    
38.             IPTS  (vlax-variant-value IPTS)
    
39.       )
    
40. ;;;Variant array has values?
    
41.       (if (> (vlax-safearray-get-u-bound IPTS 1) 0)
    
42.         (progn                                ;array holds values, convert it
    
43.           (setq        IPTS                        ;to a list.
    
44.                  (vlax-safearray->list IPTS)
    
45.           )
    
46. ;;;Loop through list constructing points
    
47.           (while (> (length IPTS) 0)
    
48.             (setq PTS  (cons (list (car IPTS)
    
49.                                    (cadr IPTS)
    
50.                                    (caddr IPTS)
    
51.                              )
    
52.                              PTS
    
53.                        )
    
54.                   IPTS (cdddr IPTS)
    
55.             )
    
56.           )
    
57.         )
    
58.       )
    
59.       (setq N2 (1+ N2))
    
60.     )                                        ;inner loop end
    
61.     (setq N1 (1+ N1))
    
62.   )                                        ;outer loop end
    
63.   pts
    
64.                                         ;(princ)
    
65. )
    
66. (if (not (member "tch3_kernal.arx" (arx)))
    
67.   (arxload "tch3_kernal.arx")
    
68. )
    
69. (defun c:tst (/ ss ptl ptl1)
    
70.   (setvar "smdecho" 0)
    
71.   (if (setq ss (ssget '((0 . "*line,arc,circle"))))
    
72.     (progn
    
73.       (begin)
    
74.       (setq ptl         (INTLINES ss)
    
75.             ptl1 (mapcar '(lambda (x) (mapcar '+ x '(1200. 1200. 0.)))
    
76.                          ptl
    
77.                  )
    
78.       )
    
79.       (mapcar '(lambda (a b) (command "T61_TCOORD" a "" b)) ptl ptl1)
    
80.       (end)
    
81.     )
    
82.   )
    
83.   (princ)
    
84. )
    

<br /> ;;-----------------------------------------------<br /> ;; CDNC5-02.LSP<br /> ;; Bill Kramer<br /> ;; Find all intersections between objects in<br /> ;; the selection set SS.<br /> ;; Process - Create drawing with intersecting lines and lwpolylines.<br /> ;;           Load function set<br /> ;;           Run command function INTLINES<br /> ;;           Intersections are marked with POINT objects on current layer<br /> (defun INTLINES        (ss / SSL                ;length of SS<br />                  PTS                        ;returning list<br />                  AOBJ1                        ;Object 1<br />                  AOBJ2                        ;Object 2<br />                  N1                        ;Loop counter<br />                  N2                        ;Loop counter<br />                  IPTS                        ;intersects<br />                  A N NN        HOLDOSMODE)<br />   (setq        N1  0                                ;index for outer loop<br />         SSL (sslength SS)<br />   )                                        ; Outer loop, first through second to last<br />   (while (< N1 (1- SSL))                ; Get object 1, convert to VLA object type<br />     (setq AOBJ1        (ssname SS N1)<br />           AOBJ1        (vlax-ename->vla-object AOBJ1)<br />           N2        (1+ N1)<br />     )                                        ;index for inner loop<br /> ;;; Inner loop, go through remaining objects<br />     (while (< N2 SSL)                        ; Get object 2, convert to VLA object<br />       (setq AOBJ2 (ssname SS N2)<br />             AOBJ2 (vlax-ename->vla-object AOBJ2)<br /> ;;;Find intersections of Objects<br />             IPTS  (vla-intersectwith<br />                     AOBJ1<br />                     AOBJ2<br />                     0<br />                   )                        ; variant result<br />             IPTS  (vlax-variant-value IPTS)<br />       )<br /> ;;;Variant array has values?<br />       (if (> (vlax-safearray-get-u-bound IPTS 1) 0)<br />         (progn                                ;array holds values, convert it<br />           (setq        IPTS                        ;to a list.<br />                  (vlax-safearray->list IPTS)<br />           )<br /> ;;;Loop through list constructing points<br />           (while (> (length IPTS) 0)<br />             (setq PTS  (cons (list (car IPTS)<br />                                    (cadr IPTS)<br />                                    (caddr IPTS)<br />                              )<br />                              PTS<br />                        )<br />                   IPTS (cdddr IPTS)<br />             )<br />           )<br />         )<br />       )<br />       (setq N2 (1+ N2))<br />     )                                        ;inner loop end<br />     (setq N1 (1+ N1))<br />   )                                        ;outer loop end<br />   pts<br />                                         ;(princ)<br /> )<br /> (if (not (member "tch3_kernal.arx" (arx)))<br />   (arxload "tch3_kernal.arx")<br /> )<br /> (defun c:tst (/ ss ptl ptl1)<br />   (setvar "smdecho" 0)<br />   (if (setq ss (ssget '((0 . "*line,arc,circle"))))<br />     (progn<br />       (begin)<br />       (setq ptl         (INTLINES ss)<br />             ptl1 (mapcar '(lambda (x) (mapcar '+ x '(1200. 1200. 0.)))<br />                          ptl<br />                  )<br />       )<br />       (mapcar '(lambda (a b) (command "T61_TCOORD" a "" b)) ptl ptl1)<br />       (end)<br />     )<br />   )<br />   (princ)<br /> )<br />

hcheli

看不懂，就像天书一样。

Free-Lancer

最初由 hcheli 发布
[B]看不懂，就像天书一样。 [/B]

看多了就成破书了*-*1