- 积分
- 11693
- 明经币
- 个
- 注册时间
- 2011-9-17
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
方格节点不要多于12个 图层根据自己需要自己改 应付现在越来越多的非测量专业土方预算员及审计的奇葩要求,说多了都是泪- ;;;;;;;;;;;;;;;;;;
- (defun insertgc ( e / e)
- (cdr(assoc 10(entget e)))
- )
- ;;;;;;;;;;;;;;;;;
- (defun insert-1 ( e / e)
- (cdr(assoc 1(entget e)))
- )
- ;(vl-remove '"" (insertatt(car(entsel ))))
- ;连结表中字符串连结表中字符串 (strcat (car lst) (apply 'strcat (mapcar '(lambda (a) (strcat str a)) (cdr lst))) )
- (defun Fsxm-join (lst str)
- (substr (apply 'strcat (mapcar '(lambda (a) (strcat str a)) lst))
- (1+ (strlen str))
- )
- )
- ;(setq ent (car (entsel "\n请选取属性块:")))
- (defun insertatt (ent / obj att jgb)
- (vl-load-com)
-
- (if (= (cdr (assoc 0 (entget ent))) "INSERT")
- (if (= (vlax-get (setq obj (vlax-ename->vla-object ent)) "HasAttributes") -1)
- (progn
- (setq att (vlax-invoke obj "GetAttributes"))
- (setq jgb (mapcar '(lambda(aobj) (list (vlax-get aobj "TagString")
- (vlax-get aobj "TextString")
- )
- )
- att
- )
- )
- ;(princ "\n属性列表=")(princ jgb)
- (apply 'append (mapcar 'cdr jgb))
- )
- )
- )
-
- ;(princ)
- )
- ;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;
- (defun zxzb (pts / len pt )
- (setq len (length pts))
- (setq pt (mapcar
- '(lambda(x)
- (/ x len)
- )
- (apply
- 'mapcar
- (cons '+ pts)
- )
- )
- ) pt)
- (defun Plinexy(e / p a b n ob q et d d1 en et)
- (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
- (cond((="LWPOLYLINE"et)
- (repeat(length a)(setq b (nth n a) n (+ n 1))
- (if (= 10 (car b))(progn
- (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
- (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
- (setq p (list q)))))))
- ((="POLYLINE"et)
- (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
- (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
- (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
- (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
- (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
- (setq p(reverse p))))P)
- (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)
- )
- )
- )
- ;;;;;;;;;;;;;;;;;;
- ;;本程序是在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 ( / biaotou1 biaotou2 p1 p2 ssa kongbiao i zb x zb1 paixuzb ii e1 e2 ssa kongbiao qzz i ii zb paixuzb p1 p2 fgjj p3 cishu kb kbb iii ty tuyuan ssb ssc f b c d ee bb pzx x y z demj zmj demja iiii str pzx11 ssd yyy m pzxaa)
- (setq p1 (getpoint "\n请输入起点:"))
- (setq p2 (getpoint p1 "\n请输入基点:"))
- (setq f(open(getfiled "打开(或建立)数据文件" "C:\\" "csv" 36)"a"))
- (setq qzz (getstring "\n请输入前缀: ") )
- (setq biaotou1 (strcat "表格编号" "," "原地面标高" "," """," """," """," "设计面标高""," """," """," """," "施工高差""," """," """," """," "挖方""," "填方""," "方格面积""," "平均高度" "\n"))
- (setq biaotou2 (strcat "\n" "" "," "原高1" "," "原高2""," "原高3""," "原高4""," "设高1""," "设高2""," "设高3""," "设高4""," "高差1""," "高差2""," "高差3""," "高差4""," "挖方""," "填方""," "方格面积""," "平均高度" "\n"))
- (write-line biaotou1 f) (write-line biaotou2 f)
- (setq ssa (ssget "x"'( (0 . "polyline") (8 . "tf-fg1") ) ) )
- (setq ssb (ssget "x"'( (0 . "insert") (8 . "tf-wtf1") ) ) )
- (setq ssc (ssget "x"'( (0 . "insert") (8 . "tf-fgd1") ) ))
-
- ;(setq ssa (ssget "x"'( (0 . "circle") (8 . "0") ) ) )
- (setq kongbiao '()) (setq i 0)
- (foreach x (cx-ss2en ssa)
-
- (setq zb (zxzb(plinexy 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)
- ;(print paixuzb)
- (setq iii 0) (setq tuyuan'())
- (repeat (length paixuzb)
- (foreach xx (cx-ss2en ssa)
- (if (and (equal (car(cdr(cdr(nth iii paixuzb)) )) (car(zxzb(plinexy xx)) ) 0.01)
- (equal (cadr(cdr(cdr(nth iii paixuzb)) )) (cadr(zxzb(plinexy xx)) ) 0.01)
- )
- (progn (setq ty (list xx)))
- )
- )
- (setq tuyuan (append tuyuan ty))
- (setq iii (1+ iii))
- )
-
- ;(print tuyuan)
- ;(setq kongbiao 'nil) (setq paixuzb 'nil)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (setq iiii 0)
- (foreach x tuyuan ;;;;;(HH:ssPts:Sort ssa "xYz" 5)
- (setq b '())
- (foreach n (cx-ss2en ssb)
- (if (and (equal (car (zxzb (plinexy x))) (car (insertgc n)) 0.1) (equal (cadr (zxzb (plinexy x))) (cadr (insertgc n)) 0.1) )
- (progn (setq pzx11 (insertatt n)) (setq b (append b pzx11 )) );
- )
- )
- (if (= (length b) 1)(setq b (append b '("0.000"))) )
- (setq b (vl-sort b
- (function (lambda (e1 e2)
- (> (read e1) (read e2))
- ) ) ) )
-
- (setq pzx '()) (setq zmj 0.000) (setq demja (vlax-curve-getArea (vlax-ename->vla-object x)))
- (foreach z (plinexy x)
- (foreach y (cx-ss2en ssc)
- (if (and (equal (car z) (car (insertgc y)) 0.002) (equal (cadr z) (cadr (insertgc y)) 0.002) )
- (progn (setq c (vl-remove '"" (insertatt y)) ) (setq demj (read (last c)))
- )
- )
- )
-
- (setq pzx (append pzx c)) (setq zmj(+ zmj demj))
- )
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;========================================
-
- (cond ( (=(length pzx) 9) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx)) (list "空格") (list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list "空格") (list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx)) (list "空格") ))
- );;;;;;;
- ( (=(length pzx) 12) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx))(list (nth 9 pzx))(list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list (nth 10 pzx))(list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx))(list (nth 11 pzx)) ))
- );;;;;;;;;;;;;
- ( (=(length pzx) 15) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx))(list (nth 9 pzx))(list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list (nth 10 pzx))(list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx))(list (nth 11 pzx))
- (list "\n")(list (nth 12 pzx)) (list "空格")(list "空格")(list "空格") (list (nth 13 pzx)) (list "空格")(list "空格")(list "空格")(list (nth 14 pzx)) (list "空格")(list "空格")(list "空格") ))
- );;;;;;;;;;;
- ( (=(length pzx) 18) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx))(list (nth 9 pzx))(list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list (nth 10 pzx))(list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx))(list (nth 11 pzx))
- (list "\n")(list (nth 12 pzx)) (list(nth 15 pzx))(list "空格")(list "空格") (list (nth 13 pzx)) (list(nth 16 pzx))(list "空格")(list "空格")(list (nth 14 pzx)) (list(nth 17 pzx))(list "空格")(list "空格") ))
- );;;;;;;;;;;
- ( (=(length pzx) 21) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx))(list (nth 9 pzx))(list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list (nth 10 pzx))(list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx))(list (nth 11 pzx))
- (list "\n")(list (nth 12 pzx)) (list(nth 15 pzx))(list(nth 18 pzx))(list "空格") (list (nth 13 pzx)) (list(nth 16 pzx))(list(nth 19 pzx))(list "空格")(list (nth 14 pzx)) (list(nth 17 pzx))(list(nth 20 pzx))(list "空格") ))
- );;;;;;;;;;;
- ( (=(length pzx) 24) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx))(list (nth 9 pzx))(list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list (nth 10 pzx))(list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx))(list (nth 11 pzx))
- (list "\n")(list (nth 12 pzx)) (list(nth 15 pzx)) (list(nth 18 pzx)) (list(nth 21 pzx)) (list (nth 13 pzx)) (list(nth 16 pzx)) (list(nth 19 pzx)) (list(nth 22 pzx)) (list (nth 14 pzx)) (list(nth 17 pzx)) (list(nth 20 pzx)) (list(nth 23 pzx)) ))
- );;;;;;;;;;;
- ( (=(length pzx) 27) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx))(list (nth 9 pzx))(list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list (nth 10 pzx))(list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx))(list (nth 11 pzx))
- (list "\n")(list (nth 12 pzx)) (list(nth 15 pzx)) (list(nth 18 pzx)) (list(nth 21 pzx)) (list (nth 13 pzx)) (list(nth 16 pzx)) (list(nth 19 pzx)) (list(nth 22 pzx)) (list (nth 14 pzx)) (list(nth 17 pzx)) (list(nth 20 pzx)) (list(nth 23 pzx))
- (list "\n")(list (nth 24 pzx)) (list "空格")(list "空格")(list "空格")(list (nth 25 pzx)) (list "空格")(list "空格")(list "空格") (list (nth 26 pzx)) (list "空格")(list "空格")(list "空格")
- )) );;;;;;;;;;;
- ( (=(length pzx) 30) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx))(list (nth 9 pzx))(list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list (nth 10 pzx))(list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx))(list (nth 11 pzx))
- (list "\n")(list (nth 12 pzx)) (list(nth 15 pzx)) (list(nth 18 pzx)) (list(nth 21 pzx)) (list (nth 13 pzx)) (list(nth 16 pzx)) (list(nth 19 pzx)) (list(nth 22 pzx)) (list (nth 14 pzx)) (list(nth 17 pzx)) (list(nth 20 pzx)) (list(nth 23 pzx))
- (list "\n")(list (nth 24 pzx)) (list (nth 27 pzx))(list "空格")(list "空格")(list (nth 25 pzx)) (list (nth 28 pzx))(list "空格")(list "空格") (list (nth 26 pzx)) (list (nth 29 pzx))(list "空格")(list "空格")
- )) );;;;;;;;;;;;;;
- ( (=(length pzx) 33) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx))(list (nth 9 pzx))(list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list (nth 10 pzx))(list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx))(list (nth 11 pzx))
- (list "\n")(list (nth 12 pzx)) (list(nth 15 pzx)) (list(nth 18 pzx)) (list(nth 21 pzx)) (list (nth 13 pzx)) (list(nth 16 pzx)) (list(nth 19 pzx)) (list(nth 22 pzx)) (list (nth 14 pzx)) (list(nth 17 pzx)) (list(nth 20 pzx)) (list(nth 23 pzx))
- (list "\n")(list (nth 24 pzx)) (list (nth 27 pzx)) (list (nth 30 pzx)) (list "空格") (list (nth 25 pzx)) (list (nth 28 pzx)) (list (nth 31 pzx)) (list "空格") (list (nth 26 pzx)) (list (nth 29 pzx)) (list (nth 32 pzx)) (list "空格")
- )) );;;;;;;;;;;;;;
- ( (=(length pzx) 36) (setq pzxaa (append (list (nth 0 pzx)) (list (nth 3 pzx)) (list (nth 6 pzx))(list (nth 9 pzx))(list (nth 1 pzx))(list (nth 4 pzx))(list (nth 7 pzx)) (list (nth 10 pzx))(list (nth 2 pzx))(list (nth 5 pzx))(list (nth 8 pzx))(list (nth 11 pzx))
- (list "\n")(list (nth 12 pzx)) (list(nth 15 pzx)) (list(nth 18 pzx)) (list(nth 21 pzx)) (list (nth 13 pzx)) (list(nth 16 pzx)) (list(nth 19 pzx)) (list(nth 22 pzx)) (list (nth 14 pzx)) (list(nth 17 pzx)) (list(nth 20 pzx)) (list(nth 23 pzx))
- (list "\n")(list (nth 24 pzx)) (list (nth 27 pzx)) (list (nth 30 pzx)) (list (nth 33 pzx)) (list (nth 25 pzx)) (list (nth 28 pzx)) (list (nth 31 pzx)) (list (nth 34 pzx)) (list (nth 26 pzx)) (list (nth 29 pzx)) (list (nth 32 pzx)) (list (nth 35 pzx))
- )) )
- ;;;;;;;;;;;;;;;;;;;;;;;=============================
- ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;========================================================================================
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (setq str (strcat qzz (rtos (1+ iiii) 2 0)))
-
- (setq bb (append (list str) pzxaa b (list (rtos demja 2 4)) (list(rtos (/ zmj (length (plinexy x) )) 2 3)) )) ;;;;
- (entmake (list '(0 . "TEXT") '(8 . "fgbj1")(cons 1 str) (cons 10 (zxzb (plinexy x)) ) (cons 40 1.0)))
- (entmake (list '(0 . "circle") '(8 . "fgbj1")(cons 62 3) (cons 10 (zxzb (plinexy x)) ) (cons 40 1.3)))
- (setq bbb(Fsxm-join bb ",") )
- (setq pzx '()) (setq pzxaa '())
- (princ )
- (write-line bbb f)
- (setq iiii (1+ iiii)) ;(setq yy nil)
- ;(setq b "" c "" d "" ee "" bb "" bbb "")
- )
- (close f)
-
- (princ)
- )
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看,没有账号?注册
x
评分
-
查看全部评分
|