明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 916|回复: 0

承台高度计算

[复制链接]
发表于 2015-12-11 10:35 | 显示全部楼层 |阅读模式
  1. (defun c:biaogao ( / blc scale ii no ssa ssb xindian en ent ptb ptb1 pzxaa)  ;;;
  2. ;;;;;;;;;;;;;;;;;;
  3.   ;选择集与对象名表互转
  4. (defun cx-ss2en
  5.   (ss / enlst)
  6.   (cond
  7.     ((= (type ss) 'PICKSET)
  8.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
  9.     )
  10.     ((= (type ss) 'LIST)
  11.       (setq enlst (ssadd))
  12.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
  13.     )
  14.     ((='ename(type ss))
  15.       (ssadd ss)
  16.     )
  17.   )
  18. )
  19.   ;;;;;;;;;;;;;;;;;;
  20. (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
  21.   (regapp "SOUTH")
  22.   

  23. (setq blc (getint "\n请输入比例尺1:<500>"))
  24.   (if (= blc nil)(setq blc 500))
  25.   (setvar 'userr1 blc);设置比例尺
  26. (setq scale (* 0.001 blc));缩放比例
  27. ;;;by Gu_xl
  28. (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
  29.   (setvar "CMDECHO" 0)
  30.   (command "layer" "m" "bgGCD" "c" "1" "" "L" "CONTINUOUS" ""  "")
  31.   (if height
  32.     (setq height (rtos height 2 3));3为高程注记位数
  33.     (setq height "")
  34.   )
  35.   (regapp "SOUTH")
  36.   
  37.   ;;;检查字体 "HZ" 是否存在
  38.   (if (not (tblobjname "style" "HZ"))
  39.     (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
  40.   )
  41.   ;;;检查是否存在高程点图块定义
  42.   (if (not (tblobjname "block" "GC200"))
  43.     (progn
  44.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
  45.       (setq obj
  46.         (vla-AddPolyline
  47.            blkdef
  48.            (vlax-make-variant
  49.               (vlax-safearray-fill
  50.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
  51.                  '(-0.2 0 0 0.2 0 0)
  52.               )
  53.            )
  54.         )
  55.       )
  56.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
  57.       (vla-put-Closed obj :vlax-true)
  58.       (vla-put-ConstantWidth obj 0.4)
  59.     )
  60.   )
  61.   ;;;插入块
  62.   (entmake (list
  63.              '(0 . "INSERT")
  64.              '(100 . "AcDbEntity")
  65.              '(100 . "AcDbBlockReference")
  66.              '(66 . 1);;;属性跟随标志,1跟随,0不跟随
  67.               (cons 2 "GC200")
  68.               (cons 10 inspt)
  69.               (cons 41 scale)
  70.               (cons 42 scale)
  71.               (cons 43 scale)
  72.               (list -3 '("SOUTH" (1000 . "202101")))
  73.            )
  74.   )
  75.   ;;;插入属性
  76.   (entmake (list
  77.              '(0 . "ATTRIB")
  78.              '(100 . "AcDbEntity")
  79.              '(100 . "AcDbText")
  80.               (cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
  81.               (cons 40 (* 2.0 scale))
  82.               (cons 50 0)
  83.               (cons 41 0.8)
  84.               (cons 51 0)
  85.               (cons 1 height)
  86.               (cons 7 "HZ")
  87.        (cons 62 3)
  88.               (cons 72 0)
  89.               (cons 11 pt)
  90.               '(100 . "AcDbAttribute")
  91.               (cons 2 "height")
  92.               (cons 70  0)
  93.               (cons 74 2)
  94.            )
  95.    )
  96.    ;;;结束标志
  97.    (entmake '((0 . "SEQEND")))
  98.    (princ)
  99. )
  100. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  101. (defun plinexy( e / e)
  102.   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
  103.   )

  104. (defun insertgc ( e / e)
  105.   (cdr(assoc 10(entget e)))
  106.   )


  107. (defun poinpl(p pt);;:点是否在指定点表内
  108.   (equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))


  109. (setq ssa (ssget '((0 . "lwPOLYLINE") (8 . "0")))
  110.   ssb (ssget  "X"'((0 . "insert") (8 . "gcd"))))

  111.                      
  112.     (setq ii   0  no  0  pzxaa '()  )              

  113. (repeat (sslength ssa)
  114.   

  115.                        (setq en (ssname ssa ii)
  116.                             ptb (plinexy en)
  117.                                         )
  118. ;;;;;;;;;;;;;
  119.   (foreach  x (cx-ss2en ssb)
  120.          (setq ptb1 (insertgc x)
  121.                                        )
  122.     (if (= (poinpl ptb1 ptb) T) (progn   (setq pzxaa (append pzxaa (list ptb1))) (setq no  (1+ no) )
  123.   
  124.       
  125.               )
  126.       )
  127.        )
  128.      ;;;;;;;;;;;;;;;;;;
  129.   (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)) ) ) ))
  130. (gxl-cs:gcd xindian (caddr xindian) scale)
  131. (entmod  (append (subst (cons 38 (caddr xindian)) (assoc 38 (entget en)) (entget en)) (list(cons 62 3)))  )
  132.   (setq ii  (1+ ii) )
  133.   (setq pzxaa '())
  134.   (setq xindian nil)
  135.                   )


  136. ;;;;;;;;;;;;(assoc 62 (subst (cons 38 (caddr xindian)) (assoc 38 (entget en)) (entget en)))
  137. )

本帖子中包含更多资源

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

x

评分

参与人数 1明经币 +1 收起 理由
tryhi + 1 赞一个!

查看全部评分

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

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-28 22:47 , Processed in 0.343188 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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