明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1600|回复: 2

三角网坡度分析转三维面-仿CASS

[复制链接]
发表于 2015-12-4 09:53:09 | 显示全部楼层 |阅读模式

  1. ;;;;;;;



  2. (defun vxs (e / i v lst)
  3.   (setq i 0)
  4.   (while
  5.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
  6.      (setq lst (cons v lst))
  7.   )
  8.   (reverse lst))

  9. (defun podujs (pzx / zjs podu1 podu2 podu3 pzx)
  10. (setq zjs (list (/ (+ (car(car pzx)) (car(cadr pzx)) (car(caddr pzx))   ) 3.000)
  11.                 (/ (+ (cadr(car pzx)) (cadr(cadr pzx)) (cadr(caddr pzx))   ) 3.000)
  12.                 (/ (+ (caddr(car pzx)) (caddr(cadr pzx)) (caddr(caddr pzx))   ) 3.000)
  13.     ))

  14.   
  15. (setq podu1 (read(angtos (atan(abs  (/ (- (caddr(car pzx))  (caddr zjs)) (distance (car pzx) zjs) )   ))0 3)))
  16. (setq podu2 (read(angtos (atan(abs  (/ (- (caddr(cadr pzx))  (caddr zjs)) (distance (cadr pzx) zjs) )   ))0 3)))
  17.   (setq podu3 (read(angtos (atan(abs  (/ (- (caddr(caddr pzx))  (caddr zjs)) (distance (caddr pzx) zjs) )   ))0 3)))

  18.   (max podu1 podu2 podu3)
  19.       )



  20. ;;;;;;;;;;;;;;;
  21. (defun c:sjwswt ( / pzx ssa en ptb i ii no yanse demj zongmj)
  22. (setq ssa (ssget '((0 . "POLYLINE") (8 . "sjw"))))
  23.                 (setq ii   0
  24.                       no  0
  25.                   )
  26.                   (repeat (sslength ssa)
  27.                        (setq en (ssname ssa ii)
  28.                             ptb (vxs en)
  29.            ;demj (vlax-curve-getArea  (vlax-ename->vla-object en))
  30.           pzx (append pzx (list ptb))
  31.   ;zongmj (append zongmj (list demj))         
  32.            ii  (1+ ii)               )
  33.        ; (setq pzx (list (car pt) (cadr pt) (caddr pt)))
  34.                        
  35.                   )
  36.   ;(write-line (strcat pzx) fff)
  37.                  ; (close fff)
  38.                   ;(princ (strcat "\n坐标已存入"" wjm ""中"))
  39.    
  40.     ;(setvar "cmdecho" cm)
  41.     (princ)


  42. (foreach n pzx

  43.   
  44. (setq yanse nil)
  45.   (cond  ((< 0 (podujs n) 12)  (setq yanse 4)   )

  46. ((< 12 (podujs n) 25)  (setq yanse 5)   )
  47. ((< 25 (podujs n)  35)  (setq yanse 2)   )   
  48. ((< 35 (podujs n) 90)  (setq yanse 6)   )
  49.     )


  50.   
  51. (entmake  (list '(0 . "3dface") (cons 10 (nth 0 n))
  52.     (cons 11 (nth 1 n))
  53.                 (cons 12 (nth 2 n))
  54.                 (cons 13 (nth 0 n))
  55.                 '(8 . "0")
  56.     (cons 62 yanse)
  57.     )  )

  58. (setq no (1+ no))
  59.   )
  60. (princ)

  61. )

评分

参与人数 1明经币 +3 金钱 +30 收起 理由
yfy2003 + 3 + 30 赞一个!

查看全部评分

发表于 2015-12-4 10:03:39 | 显示全部楼层
加一些动画和测试文件
 楼主| 发表于 2015-12-5 10:19:06 | 显示全部楼层
  1. (defun vxs (e / i v lst)
  2.   (setq i 0)
  3.   (while
  4.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
  5.      (setq lst (cons v lst))
  6.   )
  7.   (reverse lst))

  8. ;;;;;;;
  9. (defun getplarea (l)
  10.   (* 0.5
  11.      (apply
  12.        '+
  13.        (mapcar
  14.          '(lambda (a b) (- (* (car a) (cadr b)) (* (car b) (cadr a))))
  15.          l
  16.          (append (cdr l) (list (car l)))
  17.        )
  18.      )
  19.   )
  20. )
  21. ;;;;;;;



  22. (entmake (list (cons 0  "TEXT") (cons 1 (rtos (getplarea(vxs(car(entsel)))) 2 3)) (cons 10 (getpoint""))
  23.                (cons 40 0.5)
  24.                (cons 8 "面积")
  25.                ))
面积计算
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-6 07:55 , Processed in 0.189996 second(s), 30 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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