水泥搅拌桩编号
;;本程序是在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 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) )
(setql (list l) ) ; 组合成一个小组
(setqll (append l ll)) ; 小组添加到输出表
) ; while循环结束
(reverse ll) ; 反串
) 树櫴希德 发表于 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)
) 真奇怪 路版推荐的跟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)
)
回帖是一种美德！感谢楼主的无私分享 谢谢 大哥，好像用不了啊，
命令: BIANHAO
请输入起点：
请输入基点：
命令:
命令:
BIANHAO
请输入起点：*取消*
函数已取消
命令:
感谢 树櫴希德 分享程序!!!! 太棒了非常感谢 超强的， 楼主，号码能编成第几排第几号吗?
根据曲线排序标注圆圈编号bianhao
页:
[1]
2