明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 4414|回复: 15

水泥搅拌桩编号

[复制链接]
发表于 2018-7-7 23:41:16 | 显示全部楼层 |阅读模式
  1. ;;本程序是在fsxm的扩展 自贡黄明儒 2013年9月6日
  2. ;;ssPts: 1 选择集,返回图元列表
  3. ;;  2 点表(1到n维 1维时key只能是x或X),返回点表
  4. ;;  3 (cons 点表 A)组成的列表,返回A组成的列表
  5. ;;Key: "xyzXYZ"任意组合,例如"yX",y在前表示y坐标优先,小y表示从小到大(注:二维点时,不能有z)
  6. ;;FUZZ: 允许误差
  7. ;;示例1 (HH:ssPts:Sort (ssget) "YxZ" 0.5);返回(<Entity name: 7ef7b3a8> <Entity name: 7ef7b3a0>)
  8. ;;示例2 (HH:ssPts:Sort (list '(2 3) '(3 5)) "Yx" 0.5);返回((3 5) (2 3))
  9. ;;示例3 (((-597.321 2418.69 0.0) . <Entity name: 7ef7b418>) ((-597.321 2411.69 0.0) . <Entity name: 7ef7b400>));返回(<Entity name: 7ef7b418> <Entity name: 7ef7b400>)
  10. (defun HH:ssPts:Sort (ssPts KEY FUZZ / E EN FUN LST N SORTPTS SORTSS)
  11.   ;;1 点列表排序
  12.   (defun sortpts (PTS FUN F FUZZ)
  13.     (vl-sort pts
  14.       '(lambda (a b)
  15.   (if (not (equal (F a) (F b) fuzz))
  16.     (fun (F a) (F b))
  17.   )
  18.        )
  19.     )
  20.   )
  21.   ;;2 选择集图元排序
  22.   (defun sortSS (PTS FUN F FUZZ)
  23.     (vl-sort pts
  24.       '(lambda (a b)
  25.   (if (not (equal (F (car a)) (F (car b)) fuzz))
  26.     (fun (F (car a)) (F (car b)))
  27.   )
  28.        )
  29.     )
  30.   )
  31.   ;;3 排序
  32.   (defun sortSS1 (myfun PTS KEY FUZZ)
  33.     (setq Key (vl-string->list Key))
  34.     (foreach xyz (reverse Key)
  35.       (cond ((< xyz 100)
  36.       (setq fun >)
  37.       (setq xyz (nth (- xyz 88) (list car cadr caddr)))
  38.      )
  39.      (T
  40.       (setq fun <)
  41.       (setq xyz (nth (- xyz 120) (list car cadr caddr)))
  42.      )
  43.       )
  44.       (setq Pts (myfun Pts fun xyz fuzz))
  45.     )
  46.   )
  47.   ;;4 本程序主程序
  48.   (cond ((= (type ssPts) 'PICKSET)
  49.   (repeat (setq n (sslength ssPts))
  50.     (if (and (setq e (ssname ssPts (setq n (1- n))))
  51.       (setq en (entget e))
  52.         )
  53.       (setq lst (cons (cons (cdr (assoc 10 en)) e) lst))
  54.     )
  55.   )
  56.   (mapcar 'cdr (sortSS1 sortSS lst KEY FUZZ))
  57. )
  58. (T
  59.   (cond
  60.     ((= (type (caar ssPts)) 'LIST)
  61.      (mapcar 'cdr (sortSS1 sortSS ssPts KEY FUZZ))
  62.     )
  63.     (T (sortSS1 sortpts ssPts KEY FUZZ))
  64.   )
  65. )
  66.   )
  67. )


  68. (defun jiaodu (p1 p2 /  angl1  )


  69.   (setq angl1 (angle p1 p2))
  70. (setq angl1 (- (* 2.5 pi) angl1))
  71. (if (> angl1 (* 2 pi)) (setq angl1 (- angl1 (* 2 pi))))
  72.   angl1
  73.   )

  74. (defun zbzh ( p1 p2 p3 /  a xp yp)
  75. ;(setq k (getreal "\n请输入K比列:"))
  76. ;(setq p1 (getpoint "\n请输入起点:"))
  77. ;(setq p2 (getpoint p1 "\n请输入法线点:"))
  78. ;(setq p3 (getpoint  "\n请点击转换点:"))
  79. (setq a (jiaodu p2 p1))
  80. (setq xp   (+(*(-(cadr p3)(cadr p2)) (cos a))  (*(-(car p3)(car p2)) (sin a)) 90000.0000 ))
  81. (setq yp  (+(* -1.000 (-(cadr p3)(cadr p2)) (sin a))  (*(-(car p3)(car p2)) (cos a)) 50000.0000 )       )

  82.     (list yp xp)   
  83. )

  84. ;;;;;;;;;;;;;;;;;;
  85. (defun insertgc ( e / e)
  86.   (cdr(assoc 10(entget e)))
  87.   )
  88. ;;;;;;;;;;;;;;;;;;;;;
  89. (defun cx-ss2en
  90.   (ss / enlst)
  91.   (cond
  92.     ((= (type ss) 'PICKSET)
  93.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
  94.     )
  95.     ((= (type ss) 'LIST)
  96.       (setq enlst (ssadd))
  97.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
  98.     )
  99.     ((='ename(type ss))
  100.       (ssadd ss)
  101.     )
  102.   )
  103. )
  104. ;;;;;;;;;;;;;;
  105. (defun c:bianhao (  / p1 p2 ssa kongbiao i zb x zb1 paixuzb ii e1 e2)
  106.   (setq p1 (getpoint "\n请输入起点:"))
  107. (setq p2 (getpoint p1 "\n请输入基点:"))
  108. (setq ssa (ssget "x"'( (0 . "circle")  (8 . "0") ) ) )

  109. (setq kongbiao '()) (setq i 0)

  110. (foreach x (cx-ss2en ssa)
  111.      
  112.     (setq zb (insertgc x)) (setq zb1 (append (zbzh p1 p2 zb) zb))
  113.   (setq kongbiao (append (list zb1) kongbiao)) (setq i (1+ i))
  114.   )

  115. ; (setq paixuzb (vl-sort kongbiao '(lambda (e1 e2)(< (car e1)(car e2 ) ) (< (cadr e1)(cadr e2 ) )    ) ) )  ;;;;;
  116.   (setq paixuzb(HH:ssPts:Sort kongbiao "Yx" 0.5) )
  117.       
  118.   (setq ii 1)
  119.   
  120.   (foreach n  (reverse paixuzb)


  121.    
  122.     (print n)
  123. (entmake (list '(0 . "TEXT") '(8 . "fgbj1")(cons 1 (rtos ii 2 0)) (cons 10 (cdr (cdr n)) ) (cons 40 0.2)))
  124. ;(entmake (list '(0 . "TEXT") '(8 . "fgbj2")(cons 1 (rtos ii 2 0)) (cons 10 (list (car n)(cadr n)) ) (cons 40 0.4)))   
  125. (setq ii (1+ ii))
  126.     )
  127. (setq kongbiao 'nil)  (setq paixuzb 'nil)
  128.   
  129. (princ)
  130.       )

本帖子中包含更多资源

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

x
 楼主| 发表于 2020-2-24 21:09:34 | 显示全部楼层
本帖最后由 树櫴希德 于 2020-2-24 22:35 编辑

  1. (defun listgroup (lst  / k l ll)
  2.       (setq ll '())                  
  3.   (while lst                                     ; 循环取值
  4.     (setq k (cadar lst)) ; 设定关键词
  5.     (setq l (vl-remove-if-not '(lambda (x) (equal (cadr x) k 0.5)    ) lst
  6.             )     )                                       ; 以关键词查找出对应的元素表l
  7.             

  8.     (setq lst(vl-remove-if '(lambda (x) (equal (cadr x) k 0.5)    ) lst  ) )
  9.            
  10.    (setq  l (list l) )                   ; 组合成一个小组
  11.     (setq  ll (append l ll)  )                            ; 小组添加到输出表
  12.    
  13.   )                                                 ; while循环结束
  14. (reverse ll)                            ; 反串
  15. )
 楼主| 发表于 2023-8-4 10:14:22 | 显示全部楼层
树櫴希德 发表于 2020-2-24 16:10
根据曲线排序标注圆圈编号bianhao

  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 38zu ( e / e)
  10.   (cdr(assoc 38(entget e)))
  11.   )
  12. ;;;;;
  13. (defun 10zu ( e / e)
  14.   (cdr(assoc 10(entget e)))
  15.   )
  16. ;;;;;
  17. (defun 1zu ( e / e)
  18.   (cdr(assoc 1(entget e)))
  19.   )
  20. ;;;;;;
  21. (defun c:tt1188 ( / lst ent pts pt demj zmj ffn ff) ;标记三角网表面积

  22.   (setq lst (ssget "x" '( (0 . "text") (8 . "fgbj1")) ) )
  23. (setq i 0)
  24. ;(setq zmj 0.000)
  25. (setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1))
  26.   (setq ff (open ffn "w"))

  27.   
  28. (while  (< i (sslength lst))

  29. (setq ent (ssname lst i))

  30.   
  31.   (princ (strcat (1zu ent)","(rtos (cadr(10zu ent)) 2 3) "," (rtos (car(10zu ent)) 2 3)"," (rtos (last(10zu ent)) 2 3) "\n"
  32.     ) ff)


  33.   
  34.   
  35.   
  36. ;(setq zmj(+ zmj demj))

  37. (setq i (+ i 1))
  38.   
  39.   
  40.   )

  41. (close ff)
  42.   (princ)

  43. )
 楼主| 发表于 2018-8-3 16:50:05 | 显示全部楼层
  1. 真奇怪 路版推荐的跟redraw 类似 单个运行没问题在整个程序中运行就不亮显,我再试下院长的吧
  2. e派(100801964) 2018-8-3 16:40:09
  3. ;; tt(选边修剪)
  4. (defun c:tt ()
  5.   (if (and (setq s1 (car (entsel "\n选择剪切边线: ")))
  6.            (setq p0 (getpoint "\n剪切方向点<退出>: "))
  7.       )
  8.     (progn
  9.       (command "offset" 1 s1 p0 "")
  10.       (setq s2        (entlast)
  11.             ptn        (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget s2))
  12.             ptn        (mapcar 'cdr ptn)
  13.             ptn        (cons (last ptn) ptn)
  14.       )
  15.       (entdel s2)
  16.       (command "trim" s1 "" "f")
  17.       (foreach pt ptn
  18.         (command pt)
  19.       )
  20.       (command "")
  21.     )
  22.   )
  23.   (princ)
  24. )
 楼主| 发表于 2018-7-21 19:34:31 | 显示全部楼层

回帖是一种美德!感谢楼主的无私分享 谢谢
发表于 2018-7-23 21:51:52 | 显示全部楼层
大哥,好像用不了啊,
命令: BIANHAO
请输入起点:
请输入基点:
命令:
命令:
BIANHAO
请输入起点:*取消*
函数已取消
命令:
发表于 2018-7-28 08:12:53 | 显示全部楼层
感谢 树櫴希德 分享程序!!!!
发表于 2019-3-24 12:07:09 | 显示全部楼层
太棒了非常感谢
发表于 2019-5-16 20:23:10 | 显示全部楼层
楼主,号码能编成第几排第几号吗?
 楼主| 发表于 2020-2-24 16:10:06 | 显示全部楼层
根据曲线排序标注圆圈编号bianhao

本帖子中包含更多资源

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

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

本版积分规则

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

GMT+8, 2024-11-22 20:03 , Processed in 0.208632 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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