承台高度计算

树櫴希德

2. (defun c:biaogao ( / blc scale ii no ssa ssb xindian en ent ptb ptb1 pzxaa)  ;;;
   
3. ;;;;;;;;;;;;;;;;;;
   
4.   ;选择集与对象名表互转
   
5. (defun cx-ss2en
   
6.   (ss / enlst)
   
7.   (cond
   
8.     ((= (type ss) 'PICKSET)
   
9.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
   
10.     )
    
11.     ((= (type ss) 'LIST)
    
12.       (setq enlst (ssadd))
    
13.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
    
14.     )
    
15.     ((='ename(type ss))
    
16.       (ssadd ss)
    
17.     )
    
18.   )
    
19. )
    
20.   ;;;;;;;;;;;;;;;;;;
    
21. (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
    
22.   (regapp "SOUTH")
    
23.   
    
24. 
    
25. (setq blc (getint "\n请输入比例尺1:<500>"))
    
26.   (if (= blc nil)(setq blc 500))
    
27.   (setvar 'userr1 blc);设置比例尺
    
28. (setq scale (* 0.001 blc));缩放比例
    
29. ;;;by Gu_xl
    
30. (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
    
31.   (setvar "CMDECHO" 0)
    
32.   (command "layer" "m" "bgGCD" "c" "1" "" "L" "CONTINUOUS" ""  "")
    
33.   (if height
    
34.     (setq height (rtos height 2 3));3为高程注记位数
    
35.     (setq height "")
    
36.   )
    
37.   (regapp "SOUTH")
    
38.   
    
39.   ;;;检查字体 "HZ" 是否存在
    
40.   (if (not (tblobjname "style" "HZ"))
    
41.     (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
    
42.   )
    
43.   ;;;检查是否存在高程点图块定义
    
44.   (if (not (tblobjname "block" "GC200"))
    
45.     (progn
    
46.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
    
47.       (setq obj
    
48.         (vla-AddPolyline
    
49.            blkdef
    
50.            (vlax-make-variant
    
51.               (vlax-safearray-fill
    
52.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
    
53.                  '(-0.2 0 0 0.2 0 0)
    
54.               )
    
55.            )
    
56.         )
    
57.       )
    
58.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
    
59.       (vla-put-Closed obj :vlax-true)
    
60.       (vla-put-ConstantWidth obj 0.4)
    
61.     )
    
62.   )
    
63.   ;;;插入块
    
64.   (entmake (list
    
65.              '(0 . "INSERT")
    
66.              '(100 . "AcDbEntity")
    
67.              '(100 . "AcDbBlockReference")
    
68.              '(66 . 1);;;属性跟随标志,1跟随，0不跟随
    
69.               (cons 2 "GC200")
    
70.               (cons 10 inspt)
    
71.               (cons 41 scale)
    
72.               (cons 42 scale)
    
73.               (cons 43 scale)
    
74.               (list -3 '("SOUTH" (1000 . "202101")))
    
75.            )
    
76.   )
    
77.   ;;;插入属性
    
78.   (entmake (list
    
79.              '(0 . "ATTRIB")
    
80.              '(100 . "AcDbEntity")
    
81.              '(100 . "AcDbText")
    
82.               (cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
    
83.               (cons 40 (* 2.0 scale))
    
84.               (cons 50 0)
    
85.               (cons 41 0.8)
    
86.               (cons 51 0)
    
87.               (cons 1 height)
    
88.               (cons 7 "HZ")
    
89.        (cons 62 3)
    
90.               (cons 72 0)
    
91.               (cons 11 pt)
    
92.               '(100 . "AcDbAttribute")
    
93.               (cons 2 "height")
    
94.               (cons 70  0)
    
95.               (cons 74 2)
    
96.            )
    
97.    )
    
98.    ;;;结束标志
    
99.    (entmake '((0 . "SEQEND")))
    
100.    (princ)
     
101. )
     
102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
103. 
     
104. (defun plinexy( e / e)
     
105.   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
     
106.   )
     
107. 
     
108. (defun insertgc ( e / e)
     
109.   (cdr(assoc 10(entget e)))
     
110.   )
     
111. 
     
112. 
     
113. (defun poinpl(p pt);;:点是否在指定点表内
     
114.   (equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))
     
115. 
     
116. 
     
117. (setq ssa (ssget '((0 . "lwPOLYLINE") (8 . "0")))
     
118.   ssb (ssget  "X"'((0 . "insert") (8 . "gcd"))))
     
119. 
     
120.                      
     
121.     (setq ii   0  no  0  pzxaa '()  )              
     
122. 
     
123. (repeat (sslength ssa)
     
124.   
     
125. 
     
126.                        (setq en (ssname ssa ii)
     
127.                             ptb (plinexy en)
     
128.                                         )
     
129. ;;;;;;;;;;;;;
     
130.   (foreach  x (cx-ss2en ssb)
     
131.          (setq ptb1 (insertgc x)
     
132.                                        )
     
133.     (if (= (poinpl ptb1 ptb) T) (progn   (setq pzxaa (append pzxaa (list ptb1))) (setq no  (1+ no) )
     
134.   
     
135.       
     
136.               )
     
137.       )
     
138.        )
     
139.      ;;;;;;;;;;;;;;;;;;
     
140.   (setq xindian (list (*(+ (car(car pzxaa)) (car(cadr pzxaa)) ) 0.5)  (*(+ (cadr(car pzxaa)) (cadr(cadr pzxaa)) ) 0.5) (abs(- (caddr(car pzxaa)) (caddr(cadr pzxaa)) ) ) ))
     
141. (gxl-cs:gcd xindian (caddr xindian) scale)
     
142. (entmod  (append (subst (cons 38 (caddr xindian)) (assoc 38 (entget en)) (entget en)) (list(cons 62 3)))  )
     
143.   (setq ii  (1+ ii) )
     
144.   (setq pzxaa '())
     
145.   (setq xindian nil)
     
146.                   )
     
147. 
     
148. 
     
149. ;;;;;;;;;;;;(assoc 62 (subst (cons 38 (caddr xindian)) (assoc 38 (entget en)) (entget en)))
     
150. )

(defun c:biaogao ( / blc scale ii no ssa ssb xindian en ent ptb ptb1 pzxaa)  ;;;<br /> ;;;;;;;;;;;;;;;;;;<br />   ;选择集与对象名表互转<br /> (defun cx-ss2en<br />   (ss / enlst)<br />   (cond<br />     ((= (type ss) 'PICKSET)<br />       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))<br />     )<br />     ((= (type ss) 'LIST)<br />       (setq enlst (ssadd))<br />       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))<br />     )<br />     ((='ename(type ss))<br />       (ssadd ss)<br />     )<br />   )<br /> )<br />   ;;;;;;;;;;;;;;;;;;<br /> (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP<br />   (regapp "SOUTH")<br />   <br /> <br /> (setq blc (getint "\n请输入比例尺1:<500>"))<br />   (if (= blc nil)(setq blc 500))<br />   (setvar 'userr1 blc);设置比例尺<br /> (setq scale (* 0.001 blc));缩放比例<br /> ;;;by Gu_xl<br /> (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)<br />   (setvar "CMDECHO" 0)<br />   (command "layer" "m" "bgGCD" "c" "1" "" "L" "CONTINUOUS" ""  "")<br />   (if height<br />     (setq height (rtos height 2 3));3为高程注记位数<br />     (setq height "")<br />   )<br />   (regapp "SOUTH")<br />   <br />   ;;;检查字体 "HZ" 是否存在<br />   (if (not (tblobjname "style" "HZ"))<br />     (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")<br />   )<br />   ;;;检查是否存在高程点图块定义<br />   (if (not (tblobjname "block" "GC200"))<br />     (progn<br />       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))<br />       (setq obj<br />         (vla-AddPolyline<br />            blkdef<br />            (vlax-make-variant<br />               (vlax-safearray-fill<br />                  (vlax-make-safearray vlax-vbdouble (cons 0 5))<br />                  '(-0.2 0 0 0.2 0 0)<br />               )<br />            )<br />         )<br />       )<br />       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)<br />       (vla-put-Closed obj :vlax-true)<br />       (vla-put-ConstantWidth obj 0.4)<br />     )<br />   )<br />   ;;;插入块<br />   (entmake (list<br />              '(0 . "INSERT")<br />              '(100 . "AcDbEntity")<br />              '(100 . "AcDbBlockReference")<br />              '(66 . 1);;;属性跟随标志,1跟随，0不跟随<br />               (cons 2 "GC200")<br />               (cons 10 inspt)<br />               (cons 41 scale)<br />               (cons 42 scale)<br />               (cons 43 scale)<br />               (list -3 '("SOUTH" (1000 . "202101")))<br />            )<br />   )<br />   ;;;插入属性<br />   (entmake (list<br />              '(0 . "ATTRIB")<br />              '(100 . "AcDbEntity")<br />              '(100 . "AcDbText")<br />               (cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))<br />               (cons 40 (* 2.0 scale))<br />               (cons 50 0)<br />               (cons 41 0.8)<br />               (cons 51 0)<br />               (cons 1 height)<br />               (cons 7 "HZ")<br />        (cons 62 3)<br />               (cons 72 0)<br />               (cons 11 pt)<br />               '(100 . "AcDbAttribute")<br />               (cons 2 "height")<br />               (cons 70  0)<br />               (cons 74 2)<br />            )<br />    )<br />    ;;;结束标志<br />    (entmake '((0 . "SEQEND")))<br />    (princ)<br /> )<br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> <br /> (defun plinexy( e / e)<br />   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))<br />   )<br /> <br /> (defun insertgc ( e / e)<br />   (cdr(assoc 10(entget e)))<br />   )<br /> <br /> <br /> (defun poinpl(p pt);;:点是否在指定点表内<br />   (equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))<br /> <br /> <br /> (setq ssa (ssget '((0 . "lwPOLYLINE") (8 . "0")))<br />   ssb (ssget  "X"'((0 . "insert") (8 . "gcd"))))<br /> <br />                      <br />     (setq ii   0  no  0  pzxaa '()  )              <br /> <br /> (repeat (sslength ssa)<br />   <br /> <br />                        (setq en (ssname ssa ii)<br />                             ptb (plinexy en)<br />                                         )<br /> ;;;;;;;;;;;;;<br />   (foreach  x (cx-ss2en ssb)<br />          (setq ptb1 (insertgc x)<br />                                        )<br />     (if (= (poinpl ptb1 ptb) T) (progn   (setq pzxaa (append pzxaa (list ptb1))) (setq no  (1+ no) )<br />   <br />       <br />               )<br />       )<br />        )<br />      ;;;;;;;;;;;;;;;;;;<br />   (setq xindian (list (*(+ (car(car pzxaa)) (car(cadr pzxaa)) ) 0.5)  (*(+ (cadr(car pzxaa)) (cadr(cadr pzxaa)) ) 0.5) (abs(- (caddr(car pzxaa)) (caddr(cadr pzxaa)) ) ) ))<br /> (gxl-cs:gcd xindian (caddr xindian) scale)<br /> (entmod  (append (subst (cons 38 (caddr xindian)) (assoc 38 (entget en)) (entget en)) (list(cons 62 3)))  )<br />   (setq ii  (1+ ii) )<br />   (setq pzxaa '())<br />   (setq xindian nil)<br />                   )<br /> <br /> <br /> ;;;;;;;;;;;;(assoc 62 (subst (cons 38 (caddr xindian)) (assoc 38 (entget en)) (entget en)))<br /> )