水泥搅拌桩编号

树櫴希德 · 发表于 2018-7-7 23:41

;;本程序是在fsxm的扩展自贡黄明儒 2013年9月6日
;;ssPts: 1 选择集，返回图元列表
;; 2 点表(1到n维 1维时key只能是x或X)，返回点表
;; 3 (cons 点表 A)组成的列表，返回A组成的列表
;;Key: "xyzXYZ"任意组合,例如"yX",y在前表示y坐标优先，小y表示从小到大(注:二维点时，不能有z)
;;FUZZ: 允许误差
;;示例1 (HH:ssPts:Sort (ssget) "YxZ" 0.5);返回(<Entity name: 7ef7b3a8> <Entity name: 7ef7b3a0>)
;;示例2 (HH:ssPts:Sort (list '(2 3) '(3 5)) "Yx" 0.5);返回((3 5) (2 3))
;;示例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>)
(defun HH:ssPts:Sort (ssPts KEY FUZZ / E EN FUN LST N SORTPTS SORTSS)
;;1 点列表排序
(defun sortpts (PTS FUN F FUZZ)
(vl-sort pts
'(lambda (a b)
(if (not (equal (F a) (F b) fuzz))
(fun (F a) (F b))
)
)
)
)
;;2 选择集图元排序
(defun sortSS (PTS FUN F FUZZ)
(vl-sort pts
'(lambda (a b)
(if (not (equal (F (car a)) (F (car b)) fuzz))
(fun (F (car a)) (F (car b)))
)
)
)
)
;;3 排序
(defun sortSS1 (myfun PTS KEY FUZZ)
(setq Key (vl-string->list Key))
(foreach xyz (reverse Key)
(cond ((< xyz 100)
(setq fun >)
(setq xyz (nth (- xyz 88) (list car cadr caddr)))
)
(T
(setq fun <)
(setq xyz (nth (- xyz 120) (list car cadr caddr)))
)
)
(setq Pts (myfun Pts fun xyz fuzz))
)
)
;;4 本程序主程序
(cond ((= (type ssPts) 'PICKSET)
(repeat (setq n (sslength ssPts))
(if (and (setq e (ssname ssPts (setq n (1- n))))
(setq en (entget e))
)
(setq lst (cons (cons (cdr (assoc 10 en)) e) lst))
)
)
(mapcar 'cdr (sortSS1 sortSS lst KEY FUZZ))
)
(T
(cond
((= (type (caar ssPts)) 'LIST)
(mapcar 'cdr (sortSS1 sortSS ssPts KEY FUZZ))
)
(T (sortSS1 sortpts ssPts KEY FUZZ))
)
)
)
)
(defun jiaodu (p1 p2 / angl1 )
(setq angl1 (angle p1 p2))
(setq angl1 (- (* 2.5 pi) angl1))
(if (> angl1 (* 2 pi)) (setq angl1 (- angl1 (* 2 pi))))
angl1
)
(defun zbzh ( p1 p2 p3 / a xp yp)
;(setq k (getreal "\n请输入K比列:"))
;(setq p1 (getpoint "\n请输入起点："))
;(setq p2 (getpoint p1 "\n请输入法线点："))
;(setq p3 (getpoint "\n请点击转换点："))
(setq a (jiaodu p2 p1))
(setq xp (+(*(-(cadr p3)(cadr p2)) (cos a)) (*(-(car p3)(car p2)) (sin a)) 90000.0000 ))
(setq yp (+(* -1.000 (-(cadr p3)(cadr p2)) (sin a)) (*(-(car p3)(car p2)) (cos a)) 50000.0000 ) )
(list yp xp)
)
;;;;;;;;;;;;;;;;;;
(defun insertgc ( e / e)
(cdr(assoc 10(entget e)))
)
;;;;;;;;;;;;;;;;;;;;;
(defun cx-ss2en
(ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
((='ename(type ss))
(ssadd ss)
)
)
)
;;;;;;;;;;;;;;
(defun c:bianhao ( / p1 p2 ssa kongbiao i zb x zb1 paixuzb ii e1 e2)
(setq p1 (getpoint "\n请输入起点："))
(setq p2 (getpoint p1 "\n请输入基点："))
(setq ssa (ssget "x"'( (0 . "circle") (8 . "0") ) ) )
(setq kongbiao '()) (setq i 0)
(foreach x (cx-ss2en ssa)
(setq zb (insertgc x)) (setq zb1 (append (zbzh p1 p2 zb) zb))
(setq kongbiao (append (list zb1) kongbiao)) (setq i (1+ i))
)
; (setq paixuzb (vl-sort kongbiao '(lambda (e1 e2)(< (car e1)(car e2 ) ) (< (cadr e1)(cadr e2 ) ) ) ) ) ;;;;;
(setq paixuzb(HH:ssPts:Sort kongbiao "Yx" 0.5) )
(setq ii 1)
(foreach n (reverse paixuzb)
(print n)
(entmake (list '(0 . "TEXT") '(8 . "fgbj1")(cons 1 (rtos ii 2 0)) (cons 10 (cdr (cdr n)) ) (cons 40 0.2)))
;(entmake (list '(0 . "TEXT") '(8 . "fgbj2")(cons 1 (rtos ii 2 0)) (cons 10 (list (car n)(cadr n)) ) (cons 40 0.4)))
(setq ii (1+ ii))
)
(setq kongbiao 'nil) (setq paixuzb 'nil)
(princ)
)

;;本程序是在fsxm的扩展 自贡黄明儒 2013年9月6日 
;;ssPts: 1 选择集，返回图元列表 
;;  2 点表(1到n维 1维时key只能是x或X)，返回点表 
;;  3 (cons 点表 A)组成的列表，返回A组成的列表 
;;Key: "xyzXYZ"任意组合,例如"yX",y在前表示y坐标优先，小y表示从小到大(注:二维点时，不能有z) 
;;FUZZ: 允许误差 
;;示例1 (HH:ssPts:Sort (ssget) "YxZ" 0.5);返回(<Entity name: 7ef7b3a8> <Entity name: 7ef7b3a0>) 
;;示例2 (HH:ssPts:Sort (list '(2 3) '(3 5)) "Yx" 0.5);返回((3 5) (2 3)) 
;;示例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>) 
(defun HH:ssPts:Sort (ssPts KEY FUZZ / E EN FUN LST N SORTPTS SORTSS) 
  ;;1 点列表排序 
  (defun sortpts (PTS FUN F FUZZ) 
    (vl-sort pts 
      '(lambda (a b) 
  (if (not (equal (F a) (F b) fuzz)) 
    (fun (F a) (F b)) 
  ) 
       ) 
    ) 
  ) 
  ;;2 选择集图元排序 
  (defun sortSS (PTS FUN F FUZZ) 
    (vl-sort pts 
      '(lambda (a b) 
  (if (not (equal (F (car a)) (F (car b)) fuzz)) 
    (fun (F (car a)) (F (car b))) 
  ) 
       ) 
    ) 
  ) 
  ;;3 排序 
  (defun sortSS1 (myfun PTS KEY FUZZ) 
    (setq Key (vl-string->list Key)) 
    (foreach xyz (reverse Key) 
      (cond ((< xyz 100) 
      (setq fun >) 
      (setq xyz (nth (- xyz 88) (list car cadr caddr))) 
     ) 
     (T 
      (setq fun <) 
      (setq xyz (nth (- xyz 120) (list car cadr caddr))) 
     ) 
      ) 
      (setq Pts (myfun Pts fun xyz fuzz)) 
    ) 
  ) 
  ;;4 本程序主程序 
  (cond ((= (type ssPts) 'PICKSET) 
  (repeat (setq n (sslength ssPts)) 
    (if (and (setq e (ssname ssPts (setq n (1- n)))) 
      (setq en (entget e)) 
        ) 
      (setq lst (cons (cons (cdr (assoc 10 en)) e) lst)) 
    ) 
  ) 
  (mapcar 'cdr (sortSS1 sortSS lst KEY FUZZ)) 
) 
(T 
  (cond 
    ((= (type (caar ssPts)) 'LIST) 
     (mapcar 'cdr (sortSS1 sortSS ssPts KEY FUZZ)) 
    ) 
    (T (sortSS1 sortpts ssPts KEY FUZZ)) 
  ) 
) 
  ) 
) 
 
 
(defun jiaodu (p1 p2 /  angl1  ) 
 
 
  (setq angl1 (angle p1 p2)) 
(setq angl1 (- (* 2.5 pi) angl1)) 
(if (> angl1 (* 2 pi)) (setq angl1 (- angl1 (* 2 pi)))) 
  angl1 
  ) 
 
(defun zbzh ( p1 p2 p3 /  a xp yp) 
;(setq k (getreal "\n请输入K比列:")) 
;(setq p1 (getpoint "\n请输入起点：")) 
;(setq p2 (getpoint p1 "\n请输入法线点：")) 
;(setq p3 (getpoint  "\n请点击转换点：")) 
(setq a (jiaodu p2 p1)) 
(setq xp   (+(*(-(cadr p3)(cadr p2)) (cos a))  (*(-(car p3)(car p2)) (sin a)) 90000.0000 )) 
(setq yp  (+(* -1.000 (-(cadr p3)(cadr p2)) (sin a))  (*(-(car p3)(car p2)) (cos a)) 50000.0000 )       ) 
 
    (list yp xp)    
 ) 
 
;;;;;;;;;;;;;;;;;; 
(defun insertgc ( e / e) 
  (cdr(assoc 10(entget e))) 
  ) 
;;;;;;;;;;;;;;;;;;;;; 
(defun cx-ss2en 
  (ss / enlst) 
  (cond 
    ((= (type ss) 'PICKSET) 
      (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS))) 
    ) 
    ((= (type ss) 'LIST) 
      (setq enlst (ssadd)) 
      (last (mapcar '(lambda (x) (ssadd x enlst)) ss)) 
    ) 
    ((='ename(type ss)) 
      (ssadd ss) 
    ) 
  ) 
) 
;;;;;;;;;;;;;; 
(defun c:bianhao (  / p1 p2 ssa kongbiao i zb x zb1 paixuzb ii e1 e2) 
  (setq p1 (getpoint "\n请输入起点：")) 
(setq p2 (getpoint p1 "\n请输入基点：")) 
(setq ssa (ssget "x"'( (0 . "circle")  (8 . "0") ) ) ) 
 
(setq kongbiao '()) (setq i 0) 
 
(foreach x (cx-ss2en ssa) 
      
    (setq zb (insertgc x)) (setq zb1 (append (zbzh p1 p2 zb) zb)) 
  (setq kongbiao (append (list zb1) kongbiao)) (setq i (1+ i)) 
  ) 
 
 ; (setq paixuzb (vl-sort kongbiao '(lambda (e1 e2)(< (car e1)(car e2 ) ) (< (cadr e1)(cadr e2 ) )    ) ) )  ;;;;; 
  (setq paixuzb(HH:ssPts:Sort kongbiao "Yx" 0.5) ) 
       
  (setq ii 1) 
   
  (foreach n  (reverse paixuzb) 
 
 
    
    (print n) 
(entmake (list '(0 . "TEXT") '(8 . "fgbj1")(cons 1 (rtos ii 2 0)) (cons 10 (cdr (cdr n)) ) (cons 40 0.2))) 
 ;(entmake (list '(0 . "TEXT") '(8 . "fgbj2")(cons 1 (rtos ii 2 0)) (cons 10 (list (car n)(cadr n)) ) (cons 40 0.4)))    
(setq ii (1+ ii)) 
    ) 
(setq kongbiao 'nil)  (setq paixuzb 'nil) 
   
(princ) 
      )

树櫴希德 · 发表于 2020-2-24 21:09

本帖最后由树櫴希德于 2020-2-24 22:35 编辑

(defun listgroup (lst / k l ll)
(setq ll '())
(while lst ; 循环取值
(setq k (cadar lst)) ; 设定关键词
(setq l (vl-remove-if-not '(lambda (x) (equal (cadr x) k 0.5) ) lst
) ) ; 以关键词查找出对应的元素表l
(setq lst(vl-remove-if '(lambda (x) (equal (cadr x) k 0.5) ) lst ) )
(setq l (list l) ) ; 组合成一个小组
(setq ll (append l ll) ) ; 小组添加到输出表
) ; while循环结束
(reverse ll) ; 反串
)

树櫴希德 · 发表于 2023-8-4 10:14

树櫴希德发表于 2020-2-24 16:10
根据曲线排序标注圆圈编号bianhao

(defun vxs (e / i v lst)
(setq i 0)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst))
;;;;;;;;;;;;;;;
(defun 38zu ( e / e)
(cdr(assoc 38(entget e)))
)
;;;;;
(defun 10zu ( e / e)
(cdr(assoc 10(entget e)))
)
;;;;;
(defun 1zu ( e / e)
(cdr(assoc 1(entget e)))
)
;;;;;;
(defun c:tt1188 ( / lst ent pts pt demj zmj ffn ff) ;标记三角网表面积
(setq lst (ssget "x" '( (0 . "text") (8 . "fgbj1")) ) )
(setq i 0)
;(setq zmj 0.000)
(setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1))
(setq ff (open ffn "w"))
(while (< i (sslength lst))
(setq ent (ssname lst i))
(princ (strcat (1zu ent)","(rtos (cadr(10zu ent)) 2 3) "," (rtos (car(10zu ent)) 2 3)"," (rtos (last(10zu ent)) 2 3) "\n"
) ff)
;(setq zmj(+ zmj demj))
(setq i (+ i 1))
)
(close ff)
(princ)
)

(defun vxs (e / i v lst) 
  (setq i 0) 
  (while 
    (setq v (vlax-curve-getpointatparam e (setq i (1+ i)))) 
     (setq lst (cons v lst)) 
  ) 
  (reverse lst)) 
;;;;;;;;;;;;;;; 
(defun 38zu ( e / e) 
  (cdr(assoc 38(entget e))) 
  ) 
;;;;; 
(defun 10zu ( e / e) 
  (cdr(assoc 10(entget e))) 
  ) 
;;;;; 
(defun 1zu ( e / e) 
  (cdr(assoc 1(entget e))) 
  ) 
;;;;;; 
(defun c:tt1188 ( / lst ent pts pt demj zmj ffn ff) ;标记三角网表面积 
 
  (setq lst (ssget "x" '( (0 . "text") (8 . "fgbj1")) ) ) 
(setq i 0) 
;(setq zmj 0.000) 
(setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1)) 
  (setq ff (open ffn "w")) 
 
   
(while  (
 
(setq ent (ssname lst i)) 
 
   
  (princ (strcat (1zu ent)","(rtos (cadr(10zu ent)) 2 3) "," (rtos (car(10zu ent)) 2 3)"," (rtos (last(10zu ent)) 2 3) "\n" 
    ) ff) 
 
 
   
   
   
;(setq zmj(+ zmj demj)) 
 
(setq i (+ i 1)) 
   
   
  ) 
 
(close ff) 
  (princ) 
 
)

树櫴希德 · 发表于 2018-8-3 16:50

真奇怪路版推荐的跟redraw 类似单个运行没问题在整个程序中运行就不亮显，我再试下院长的吧
e派(100801964) 2018-8-3 16:40:09
;; tt(选边修剪)
(defun c:tt ()
(if (and (setq s1 (car (entsel "\n选择剪切边线: ")))
(setq p0 (getpoint "\n剪切方向点<退出>: "))
)
(progn
(command "offset" 1 s1 p0 "")
(setq s2 (entlast)
ptn (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget s2))
ptn (mapcar 'cdr ptn)
ptn (cons (last ptn) ptn)
)
(entdel s2)
(command "trim" s1 "" "f")
(foreach pt ptn
(command pt)
)
(command "")
)
)
(princ)
)

树櫴希德 · 发表于 2018-7-21 19:34

回帖是一种美德！感谢楼主的无私分享谢谢

迷失1786 · 发表于 2018-7-23 21:51

大哥，好像用不了啊，
命令: BIANHAO
请输入起点：
请输入基点：
命令:
命令:
BIANHAO
请输入起点：*取消*
函数已取消
命令:

yoyoho · 发表于 2018-7-28 08:12

感谢树櫴希德分享程序!!!!

tonglesky · 发表于 2019-3-24 12:07

太棒了非常感谢

wdjy808 · 发表于 2019-3-28 11:49

超强的，

lty · 发表于 2019-5-16 20:23

楼主，号码能编成第几排第几号吗?

树櫴希德 · 发表于 2020-2-24 16:10

根据曲线排序标注圆圈编号bianhao

账号		自动登录	找回密码
密码			注册

水泥搅拌桩编号

本帖子中包含更多资源

相关帖子

本帖子中包含更多资源