一个排序函数,应用慢慢添加

13808843088 · 发表于 2013-5-18 11:53:56

发帖看帖:)

夏生生 · 发表于 2013-5-18 12:22:31

由于函数无说明，自己估的，mode应该只有0 1，key应该只有1 2 3 4，建议：第一应该控制用户的输入，第二可否像ossnap一样用位去控制，这样mode和key就可以只留一个参数，下面我mode取1000key取10000都没报错。
(setq lst '((53366.0 39118.1 0.0)
      (50864.3 38429.3 0.0)
      (49179.4 38735.4 0.0)
      (49996.3 40036.6 0.0)
      (53366.0 41337.8 0.0)
      (51834.3 42562.4 0.0)
      (50124.0 42741.0 0.0)
      (48924.1 40878.5 0.0)
   )
   mod 1000
   key 10000
   vx  1.e-6
)
(ybl-ent-sort lst mod key vx)

vlisp2012 · 发表于 2013-5-18 15:04:49

下载，攒豆豆！！！

eachy · 发表于 2013-5-18 19:23:52

;;********************************************************
;;示例一：将文字按要求排序号
;;********************************************************
(defun c:t1 (/ ss ssl e elst el n k1 k2 d pre sub)
(if (and (setq ss (ssget '((0 . "text"))))
(progn
(initget "0 1")
(setq k1 (getkword "\n[0 -按行/1 -按列]:"))
)
(progn
(initget "1 2 3 4")
(setq k2
(getkword
"\n[1-左上至右下/2-右上至左下/3-右下至左上/4-左下至右上]:"
)
)
)
(setq d (getdist "\n输入允许误差: "))
)
(progn
(setq ssl (sslength ss))
(while (> ssl 0)
(setq e (ssname ss (setq ssl (1- ssl))))
(setq elst (cons (list (cdr (assoc 10 (entget e))) e) elst))
)
(setq pre "K+" ;_ 前缀
;;sub "A" ;_ 后缀
)
(setq el (mapcar '(lambda (x) (mapcar 'cadr x))
(ybl-ent-sort elst (atoi k1) (atoi k2) d)
)
)
(setq n 1) ;_ 起始值,
(mapcar
'(lambda (x)
(mapcar
'(lambda (e1)
(setq el (entget e1))
(entmod (subst (cons 1
(strcat pre ;_ 前缀
(if (< n 10)
(strcat "0" (itoa n))
(itoa n)
) ;_ 可以进行格式化
;; sub;_ 后缀
)
)
(assoc 1 el)
el
)
)
(setq n (1+ n)) ;_ 可以定义步距
)
x
)
)
el
)
)
)
(princ)
)

;;******************************************************** 
;;示例一：将文字按要求排序号                               
;;******************************************************** 
(defun c:t1 (/ ss ssl e elst el n k1 k2 d pre sub) 
  (if (and (setq ss (ssget '((0 . "text")))) 
     (progn 
       (initget "0 1") 
       (setq k1 (getkword "\n[0 -按行/1 -按列]:")) 
     ) 
     (progn 
       (initget "1 2 3 4") 
       (setq k2 
        (getkword 
          "\n[1-左上至右下/2-右上至左下/3-右下至左上/4-左下至右上]:" 
        ) 
       ) 
     ) 
     (setq d (getdist "\n输入允许误差: ")) 
      ) 
    (progn 
      (setq ssl (sslength ss)) 
      (while (> ssl 0) 
  (setq e (ssname ss (setq ssl (1- ssl)))) 
  (setq elst (cons (list (cdr (assoc 10 (entget e))) e) elst)) 
      ) 
      (setq pre  "K+" ;_ 前缀 
    ;;sub  "A" ;_ 后缀 
      ) 
      (setq el (mapcar '(lambda (x) (mapcar 'cadr x)) 
           (ybl-ent-sort elst (atoi k1) (atoi k2) d) 
         ) 
      ) 
      (setq n 1) ;_ 起始值, 
      (mapcar 
  '(lambda (x) 
     (mapcar 
       '(lambda (e1) 
    (setq el (entget e1)) 
    (entmod  (subst (cons 1 
             (strcat pre ;_ 前缀 
               (if (< n 10) 
                 (strcat "0" (itoa n)) 
                 (itoa n) 
               ) ;_ 可以进行格式化 
               ;; sub;_ 后缀 
             ) 
             ) 
             (assoc 1 el) 
             el 
      ) 
    ) 
    (setq n (1+ n)) ;_ 可以定义步距 
        ) 
       x 
     ) 
   ) 
  el 
      ) 
    ) 
  ) 
  (princ) 
)

eachy · 发表于 2013-5-18 19:29:50

;;实体排序示例二，按行连接文字
(defun ea:Clearcset (/ cset)
(if (not (vl-catch-all-error-p
(setq cset
(vl-catch-all-apply
'vla-item
(list
(vlax-get-property
(vlax-get-property
(vlax-get-acad-object)
'activedocument
)
'selectionsets
)
"CURRENT"
)
)
)
)
)
(vla-delete cset)
)
(princ)
)
;;构造实体表要根据需要决定采用 Object 还是 Entity，这样才能精简代码并提高效率
(vl-load-com)
(defun c:t3 (/ objlst tlst first_obj strlst fstr)
(ea:clearcset) ;_ 此处必须，原因见以前讨论帖
(princ "\n选择按行连接文字...")
(if (ssget '((0 . "text")))
(progn
;;获取实体表
(vlax-map-collection
(vlax-get-property
(vlax-get-property (vlax-get-acad-object) 'activedocument)
'activeselectionset
)
'(lambda (x)
(setq objlst
(cons (list (vlax-get x 'insertionpoint) x) objlst)
)
(if (not hi)
(setq hi (vlax-get-property x 'height))
) ;_ 取字高作为误差，仅取一次
)
) ;_ end vlax-map-colllection
;;排序并处理
(setq tlst (mapcar '(lambda (x) (mapcar 'cadr x))
(ybl-ent-sort objlst 0 1 hi) ;_ 按行排序
) ;_ 排序后实体表
first_obj (mapcar 'car tlst) ;_每行第一个实体列表
strlst (mapcar '(lambda (x) (mapcar 'vla-get-textstring x))
tlst
) ;_ 每行字符串列表
fstr (mapcar '(lambda (x) (apply 'strcat x)) strlst) ;_合并每行字符串
)
(mapcar '(lambda (a b) (vlax-put-property a 'textstring b))
first_obj
fstr
) ;_ 修改每行第一个文字
(mapcar '(lambda (x) (mapcar 'vla-delete x))
(vl-remove nil (mapcar '(lambda (e) (cdr e)) tlst))
) ;_ 删除每行第二个以后的实体
)
)
(princ)
)

;;实体排序示例二，按行连接文字 
(defun ea:Clearcset (/ cset) 
  (if (not (vl-catch-all-error-p 
      (setq cset 
      (vl-catch-all-apply 
        'vla-item 
        (list 
   (vlax-get-property 
     (vlax-get-property 
       (vlax-get-acad-object) 
       'activedocument 
     ) 
     'selectionsets 
   ) 
   "CURRENT" 
        ) 
      ) 
      ) 
    ) 
      ) 
    (vla-delete cset) 
  ) 
  (princ) 
) 
;;构造实体表要根据需要决定采用 Object 还是 Entity，这样才能精简代码并提高效率 
(vl-load-com) 
(defun c:t3 (/ objlst tlst first_obj strlst fstr) 
  (ea:clearcset) ;_ 此处必须，原因见以前讨论帖 
  (princ "\n选择按行连接文字...") 
  (if (ssget '((0 . "text"))) 
    (progn 
      ;;获取实体表 
      (vlax-map-collection 
 (vlax-get-property 
   (vlax-get-property (vlax-get-acad-object) 'activedocument) 
   'activeselectionset 
 ) 
 '(lambda (x) 
    (setq objlst 
    (cons (list (vlax-get x 'insertionpoint) x) objlst) 
    ) 
    (if (not hi) 
      (setq hi (vlax-get-property x 'height)) 
    ) ;_ 取字高作为误差，仅取一次 
  ) 
      ) ;_ end vlax-map-colllection 
      ;;排序并处理 
      (setq tlst      (mapcar '(lambda (x) (mapcar 'cadr x)) 
         (ybl-ent-sort objlst 0 1 hi) ;_ 按行排序 
        ) ;_ 排序后实体表 
     first_obj (mapcar 'car tlst) ;_每行第一个实体列表 
     strlst    (mapcar '(lambda (x) (mapcar 'vla-get-textstring x)) 
         tlst 
        ) ;_ 每行字符串列表 
     fstr      (mapcar '(lambda (x) (apply 'strcat x)) strlst) ;_合并每行字符串 
      ) 
      (mapcar '(lambda (a b) (vlax-put-property a 'textstring b)) 
       first_obj 
       fstr 
      ) ;_ 修改每行第一个文字 
      (mapcar '(lambda (x) (mapcar 'vla-delete x)) 
       (vl-remove nil (mapcar '(lambda (e) (cdr e)) tlst)) 
      ) ;_ 删除每行第二个以后的实体 
    ) 
  ) 
  (princ) 
)

eachy · 发表于 2013-5-18 20:05:06

;;排序示例三：行对齐(文字)
(defun c:t4 (/ objlst tlst ptl hi)
(ea:clearcset) ;_ 此处必须，原因见以前讨论帖
(princ "\n选择按行对齐文字...")
(if (ssget '((0 . "text")))
(progn
;;获取实体表
(vlax-map-collection
(vlax-get-property
(vlax-get-property (vlax-get-acad-object) 'activedocument)
'activeselectionset
)
'(lambda (x / bb uu)
(vla-getboundingbox x 'bb 'uu) ;_还可以用来做实体对齐
(setq objlst
(cons (list (safearray-value bb) x) objlst)
)
(if (not hi)
(setq hi (vlax-get-property x 'height))
) ;_ 取字高作为误差，仅取一次
)
) ;_ end vlax-map-colllection
;;排序并处理
(setq tlst (ybl-ent-sort objlst 0 1 hi) ;_ 按行排序
objlst (mapcar '(lambda (x) (mapcar 'cadr x))
tlst
) ;_ 排序后实体表
ptl (mapcar '(lambda (x) (caar x)) tlst) ;_每行第一个点
)
(mapcar '(lambda (a b)
(mapcar '(lambda (e)
(vla-move (cadr e)
(vlax-3d-point (car e))
(vlax-3d-point
(list (caar e) (cadr b) 0.)
)
)
)
a
)
)
tlst
ptl
)
)
)
(princ)
)

;;排序示例三：行对齐(文字) 
(defun c:t4 (/ objlst tlst ptl hi) 
  (ea:clearcset) ;_ 此处必须，原因见以前讨论帖 
  (princ "\n选择按行对齐文字...") 
  (if (ssget '((0 . "text"))) 
    (progn 
      ;;获取实体表 
      (vlax-map-collection 
 (vlax-get-property 
   (vlax-get-property (vlax-get-acad-object) 'activedocument) 
   'activeselectionset 
 ) 
 '(lambda (x / bb uu) 
    (vla-getboundingbox x 'bb 'uu) ;_还可以用来做实体对齐 
    (setq objlst 
    (cons (list (safearray-value bb) x) objlst) 
    ) 
    (if (not hi) 
      (setq hi (vlax-get-property x 'height)) 
    ) ;_ 取字高作为误差，仅取一次 
  ) 
      ) ;_ end vlax-map-colllection 
      ;;排序并处理 
      (setq tlst   (ybl-ent-sort objlst 0 1 hi) ;_ 按行排序 
     objlst (mapcar '(lambda (x) (mapcar 'cadr x)) 
      tlst 
     ) ;_ 排序后实体表 
     ptl    (mapcar '(lambda (x) (caar x)) tlst) ;_每行第一个点 
      ) 
      (mapcar '(lambda (a b) 
   (mapcar '(lambda (e) 
       (vla-move (cadr e) 
          (vlax-3d-point (car e)) 
          (vlax-3d-point 
     (list (caar e) (cadr b) 0.) 
          ) 
       ) 
     ) 
    a 
   ) 
        ) 
       tlst 
       ptl 
      ) 
    ) 
  ) 
  (princ) 
)

wowan1314 · 发表于 2013-5-18 21:48:23

好思路！还可以按行列分别设误差排序！
我咋想不到呢

eachy · 发表于 2013-5-18 22:16:13

;|
1 ybl-ent-sort 实体按规则分行/列
调用格式: (ybl-ent-sort entity_list mode key vx)
参数说明:
1 mode 0 按行 1 按列
2 key
(mod = 0) (mod = 1)
1 Y降X升 X升Y降 (左上至右下)
2 Y降X降 X降Y降 (右上至左下)
3 Y升X降 X降Y升 (右下至左上)
4 Y升X升 X升Y升 (左下至右上)
3 vx 行(列)允许误差，为 nil 实取 0
4 entity_list 表, 格式如下
((pt1 ent1) (pt2 ent2) ... (ptn entn))
a pt 为 ent 的特征点， ent 可以为 entity 或 vla-object
比如对文字排序，pt 可以使用文字的插入点
b 当 pt 为实数时，vx 为行列最大及最小值的差值，此时 mode key 为任意值
如一组数 (1 3 56 89 56 45 6 8 45 91 45 69 78 15 12 11) vx 取 10
排序后为 ((1 3 6 8 11) (12 15) (45 45 45) (56 56) (69 78) (89 91))
总表及子表均为由大到小排列
|;
(defun c:test (/ ss ssl i e el lst n xl)
(if (setq ss (ssget))
(progn
(setq ssl (sslength ss)
i -1
)
(repeat ssl
(setq e (ssname ss (setq i (1+ i)))
el (entget e)
lst (cons (list (cdr (assoc 10 el)) e) lst)
)
)
(setq lst (mapcar '(lambda (x) (mapcar 'car x))
(ybl-ent-sort lst 0 1 1.)
)
n (apply 'max (setq ln (mapcar 'length lst)))
xl (nth (vl-position n ln) lst)
)
(setq
v (mapcar
'(lambda (a / ll)
(mapcar
'(lambda (b / tf tf1)
(if (member
't
(mapcar '(lambda (c)
(if (equal (car c) (car b) 1.)
t
nil
)
)
a
)
)
b
" "
)
)
xl
)
)
lst
)
)
(princ v)
)
)
(princ)
)

;| 
1  ybl-ent-sort 实体按规则分行/列 
调用格式: (ybl-ent-sort entity_list mode key vx) 
参数说明: 
        1 mode 0 按行 1 按列 
        2 key 
             (mod = 0)    (mod = 1) 
          1  Y降X升       X升Y降   (左上至右下) 
          2  Y降X降       X降Y降   (右上至左下) 
          3  Y升X降       X降Y升   (右下至左上) 
          4  Y升X升       X升Y升   (左下至右上) 
        3 vx 行(列)允许误差，为 nil 实取 0 
        4 entity_list 表, 格式如下 
          ((pt1 ent1) (pt2 ent2) ... (ptn entn)) 
          a pt 为 ent 的特征点， ent 可以为 entity 或 vla-object 
            比如对文字排序，pt 可以使用文字的插入点 
             
          b 当 pt 为实数时，vx 为行列最大及最小值的差值，此时 mode key 为任意值 
            如一组数 (1 3 56 89 56 45 6 8 45 91 45 69 78 15 12 11) vx 取 10 
            排序后为 ((1 3 6 8 11) (12 15) (45 45 45) (56 56) (69 78) (89 91)) 
            总表及子表均为由大到小排列 
|; 
(defun c:test (/ ss ssl i e el lst n xl) 
  (if (setq ss (ssget)) 
    (progn 
      (setq ssl (sslength ss) 
     i -1 
      ) 
      (repeat ssl 
 (setq e   (ssname ss (setq i (1+ i))) 
       el  (entget e) 
       lst (cons (list (cdr (assoc 10 el)) e) lst) 
 ) 
      ) 
      (setq lst (mapcar '(lambda (x) (mapcar 'car x)) 
   (ybl-ent-sort lst 0 1 1.) 
  ) 
     n (apply 'max (setq ln (mapcar 'length lst))) 
     xl (nth (vl-position n ln) lst) 
      ) 
      (setq 
 v (mapcar 
     '(lambda (a / ll) 
        (mapcar 
   '(lambda (b / tf tf1) 
      (if (member 
     't 
     (mapcar '(lambda (c) 
         (if (equal (car c) (car b) 1.) 
           t 
           nil 
         ) 
       ) 
      a 
     ) 
   ) 
        b 
        " " 
      ) 
    ) 
   xl 
        ) 
      ) 
     lst 
   ) 
      ) 
      (princ v) 
    ) 
  ) 
  (princ) 
)

守仁格竹GM · 发表于 2013-5-22 11:29:25

顶一下高手

zyhandw · 发表于 2013-5-22 14:01:13

强，顶一个，向楼主学习:lol

eachy · 发表于 2013-5-22 16:57:00

另外一个应用,生成一个外围盒
http://bbs.xdcad.net/forum.php?m ... 171&pid=3454532

kwok · 发表于 2013-5-23 19:45:55

请问这个点排序可以做到下面图那样吗，把每根线的p1p2点找出来，然后在想在p1处画一个矩形.

如果可以，请指导一下要怎么弄?

eachy · 发表于 2013-5-23 20:12:35

这个用不到 ybl-ent-sort ，给你个思路，取点集的中心点，比较这个中心点和每个线的 Startpoint 及 Endpoint 的距离远近

eachy · 发表于 2013-5-26 19:31:03

以前写的一个土方计算，排序部分用 ybl-ent-sort 替换

;;土方随手算系列二,
;;本程序中高差点与网格交点的位置相对固定, 并使用对齐点作为网格交点，
;;任何对高差数字的移动,其方格将被忽略计算
;;本程序中网格按1图形单位为1米计算,如果按1:1绘图先将图缩小0.001倍
;;感谢秋枫哥
;;土方计算
(defun c:Ea:TfJs (/ #test_item #v1 #v2
#v3 #z_pt addtxt addline
caltf thisdrawing modelspace
)
;; elst 为 (h11 h12 h21 h22)
;;测试表中负值数目,返回表 (负值个数 (索引位置)),当三负时索引值为正值的索引位置
(defun #test_item (lst / a i plst nlst)
(setq i 0
plst nil
nlst nil
)
(foreach a lst
(if (< 0 a)
(setq plst (append plst (list i)))
(setq nlst (append nlst (list i)))
)
(setq i (1+ i))
)
(list (length nlst)
(if (= 3 (length nlst))
plst
nlst
)
)
)
;;计算一: 一负或三负
(defun #v1 (h1 h2 h3 h4 a str / v- v+)
(if str
(progn
(setq v- (/ (* a h1 h1 h1) 6 (+ h1 h2) (+ h1 h3))
v+ (+ (/ (* a (- (+ (* 2 (+ h2 h3)) h4) h1)) 6) v-)
)
)
(progn
(setq v+ (/ (* a h1 h1 h1) 6 (+ h1 h2) (+ h1 h3))
v- (+ (/ (* a (- (+ (* 2 (+ h2 h3)) h4) h1)) 6) v+)
)
)
)
(list (rtos v- 2 2) (rtos v+ 2 2))
)
;;计算二: 两负(相邻)
(defun #v2 (h1 h2 h3 h4 a / v- v+)
(setq
v+ (/ (* a (+ h1 h2) (+ h1 h2))
(* 4 (+ h1 h2 h3 h4))
)
v- (/ (* a (+ h3 h4) (+ h3 h4))
(* 4 (+ h1 h2 h3 h4))
)
)
(list (rtos v- 2 2) (rtos v+ 2 2))
)
;;计算三: 两负(对角)
(defun #v3 (h1 h2 h3 h4 a / v1+ v2+ v- v+)
(setq
v1+
(/ (* a h2 h2 h2) (* 6 (+ h1 h2) (+ h1 h3)))
v2+
(/ (* a h3 h3 h3) (* 6 (+ h3 h1) (+ h3 h4)))
v-
(+ (/ (* a (- (* 2 (+ h1 h4)) h2 h3)) 6) v1+ v2+)
v+ (+ v1+ v2+) ;???
)
(list (rtos v- 2 2) (rtos v+ 2 2))
)
;;零线点
(defun #z_pt (h1 h2 p1 p2 / z_p)
(if (/= h2 0)
(setq z_p (polar p1
(angle p1 p2)
(/ (* (distance p1
p2
)
h1
)
(+ h1 h2)
)
)
)
(setq z_p p2)
)
z_p
)
;;计算主程序
(defun caltf (p1 p2 p3 p4 h1 h2 h3 h4 /
_area pmid pmid1 pmid2 #el n #_indx n-
#tf hi1 v z_p1 z_p2 z_p3 z_p4 _v
)
(setq _area (* (distance p1 p2) (distance p1 p3)) ;_网格面积
pmid (mapcar '* '(0.5 0.5) (mapcar '+ p1 p4))
pmid1 (polar pmid (* pi 0.5) 1.5)
pmid2 (polar pmid (- (* pi 0.5)) 0.2)
)
(setq #el (#test_item (list h1 h2 h3 h4))
; 0┍---------┐1
n (car #el) ;负值数量 │ │
#_indx (last #el) ;负值位置 │ │
) ; 2┗---------┚3
(cond
((or (= n 1) ;_一负或三负
(= n 3)
)
(setq n- (car #_indx))
(cond
((= n- 0)
(setq v (if (= n 1)
(#v1 (abs h1)
(abs h2)
(abs h3)
(abs h4)
_area
T
)
(#v1 (abs h1)
(abs h2)
(abs h3)
(abs h4)
_area
nil
)
)
z_p1 (#z_pt (abs h1) (abs h2) p1 p2)
z_p2 (#z_pt (abs h1) (abs h3) p1 p3)
)
)
((= n- 1)
(setq v (if (= n 1)
(#v1 (abs h2)
(abs h1)
(abs h4)
(abs h3)
_area
T
)
(#v1 (abs h2)
(abs h1)
(abs h4)
(abs h3)
_area
nil
)
)
z_p1 (#z_pt (abs h2) (abs h1) p2 p1)
z_p2 (#z_pt (abs h2) (abs h4) p2 p4)
)
)
((= n- 2)
(setq v (if (= n 1)
(#v1 (abs h3)
(abs h1)
(abs h4)
(abs h2)
_area
T
)
(#v1 (abs h3)
(abs h1)
(abs h4)
(abs h2)
_area
nil
)
)
z_p1 (#z_pt (abs h3) (abs h1) p3 p1)
z_p2 (#z_pt (abs h3) (abs h4) p3 p4)
)
)
(T
(setq v (if (= n 1)
(#v1 (abs h4)
(abs h2)
(abs h3)
(abs h1)
_area
T
)
(#v1 (abs h4)
(abs h2)
(abs h3)
(abs h1)
_area
nil
)
)
z_p1 (#z_pt (abs h4) (abs h2) p4 p2)
z_p2 (#z_pt (abs h4) (abs h3) p4 p3)
)
)
)
)
((= n 2) ;_两负,相临或对角
(cond
((equal #_indx '(0 3)) ;_对角
(setq v (#v3 (abs h2)
(abs h1)
(abs h4)
(abs h3)
_area
)
z_p1 (#z_pt (abs h1) (abs h3) p1 p3)
z_p2 (#z_pt (abs h4) (abs h3) p4 p3)
z_p3 (#z_pt (abs h1) (abs h2) p1 p2)
z_p4 (#z_pt (abs h4) (abs h2) p4 p2)
)
)
((equal #_indx '(1 2)) ;_对角
(setq v (#v3 (abs h1)
(abs h2)
(abs h3)
(abs h4)
_area
)
z_p1 (#z_pt (abs h2) (abs h1) p2 p1)
z_p2 (#z_pt (abs h3) (abs h1) p3 p1)
z_p3 (#z_pt (abs h2) (abs h4) p2 p4)
z_p4 (#z_pt (abs h3) (abs h4) p3 p4)
)
)
((equal #_indx '(0 1)) ;_相邻
(setq v (#v2 (abs h3)
(abs h4)
(abs h1)
(abs h2)
_area
)
Z_P1 (#z_pt (abs h1) (abs h3) p1 p3)
z_p2 (#z_pt (abs h2) (abs h4) p2 p4)
)
)
((equal #_indx '(0 2))
(setq v (#v2 (abs h2)
(abs h4)
(abs h1)
(abs h3)
_area
)
Z_P1 (#z_pt (abs h1) (abs h2) p1 p2)
z_p2 (#z_pt (abs h3) (abs h4) p3 p4)
)
)
((equal #_indx '(1 3))
(setq v (#v2 (abs h1)
(abs h3)
(abs h2)
(abs h4)
_area
)
Z_P1 (#z_pt (abs h2) (abs h1) p2 p1)
z_p2 (#z_pt (abs h4) (abs h3) p4 p3)
)
)
(T
;;(2 3)
(setq v (#v2 (abs h1)
(abs h2)
(abs h3)
(abs h4)
_area
)
Z_P1 (#z_pt (abs h3) (abs h1) p3 p1)
z_p2 (#z_pt (abs h4) (abs h2) p4 p2)
)
)
)
)
(T ;_全正(负)
(setq #tf (* (* (+ h1 h2 h3 h4) 0.25)
_area
)
#tf (if (> #tf 0)
(strcat "+"
(rtos #tf 2 2)
)
(rtos #tf 2 2)
)
)
) ;_全正
) ;_cond
(if (and (/= n 0)
(/= n 4)
(/= (distance z_p1 z_p2) 0)
)
(progn
(ybvl-addline modelspace z_p1 z_p2 "TF-LX") )
(if (and z_p3
(/= (distance z_p3 z_p4) 0)
)
(ybvl-addline modelspace z_p3 z_p4 "TF-LX")
)
)
)
(if v
(progn
(ybvl-addtext modelspace (strcat "-" (car v)) pmid1 0.9 1 "TF-TF")
(ybvl-addtext modelspace (strcat "+" (cadr v)) pmid2 0.9 1 "TF-TF")
)
(ybvl-addtext modelspace #tf pmid 0.9 1 "TF-TF")
)
)
;;main
(setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))
modelspace (vla-get-modelspace thisdrawing)
)
(vla-startundomark thisdrawing)
(vl-catch-all-apply
(function
(lambda (/ _v tb ll tf l1 l2 j11 j12 _l2)
(setq _v '(2.1 -0.5 0.))
(ybvl-clearcset)
(while
(progn (princ "\n请选取计算列的高程文字 <退出>: ")
(ssget '((0 . "TEXT") (8 . "TF-GC")))
)
(setq tb nil)
;;构造表(((x1 y1) "string1") ((x2 y2) "string2") ......)
(vlax-for obj (vla-get-activeselectionset thisdrawing)
;;(if tf (setq h (vla-get-height obj) tf nil))
(setq tb
(cons
(list
(ybl-pt->2d (vlax-get obj 'textalignmentpoint)) ;_标高右下对齐点
(read (vl-string-left-trim "+" (vla-get-textstring obj)) ;_高差
)
)
tb
)
)
)
(setq ll (ybl-ent-sort tb 0 1 0.001)) ;_按行排列 (((p11 h11) (p12 h12) ...) ((p21 h21) (p22 h22) ...) ...)
;; ll 网格交点坐标
(while (>= (length ll) 2) ;_保证一行方格
(setq l1 (car ll)
l2 (cadr ll)
_l2 l2
) ;_第二行
(while (> (length l1) 1) ;_第一行
;; L1 j11 +-------------+j12
;; | |
;; | |
;; | |
;; L2 j21 +-------------+j22
(setq j11 (car l1) ;_(p11 h11)
j12 (cadr l1) ;_(p12 h12)
tf t
)
(while (and tf _l2)
(if (equal (caaar _l2) (caar j11) 1e-3)
(setq tf nil)
(setq _l2 (cdr _l2))
)
)
(if (and _l2 ;_第二行中有对应的点
(equal (caar j11) (caaar _l2) 1e-3) ;_ x of j11 & x of j21
(equal (caar j12) (caaadr _l2) 1e-3) ;_ x of j21 & x of j22
) ;_矩形
(progn
(caltf (mapcar '+ (car j11) _v)
(mapcar '+ (car j12) _v)
(mapcar '+ (caar _l2) _v)
(mapcar '+ (caadr _l2) _v)
(last j11)
(last j12)
(last (car _l2))
(last (cadr _l2))
)
) ;_progn
) ;_if
(setq l1 (cdr l1))
) ;_while 第一行
(setq ll (cdr ll))
) ;_while 总行
) ;_while
)
)
)
(vla-endundomark thisdrawing)
(princ)
)

;;土方随手算系列二, 
;;本程序中高差点与网格交点的位置相对固定, 并使用对齐点作为网格交点， 
;;任何对高差数字的移动,其方格将被忽略计算 
;;本程序中网格按1图形单位为1米计算,如果按1:1绘图先将图缩小0.001倍 
;;感谢秋枫哥 
;;土方计算 
(defun c:Ea:TfJs (/      #test_item #v1    #v2 
    #v3      #z_pt addtxt    addline 
    caltf      thisdrawing    modelspace 
   ) 
  ;; elst 为 (h11 h12 h21 h22) 
  ;;测试表中负值数目,返回表 (负值个数 (索引位置)),当三负时索引值为正值的索引位置 
  (defun #test_item (lst / a i plst nlst) 
    (setq i    0 
   plst nil 
   nlst nil 
    ) 
    (foreach a lst 
      (if (< 0 a) 
 (setq plst (append plst (list i))) 
 (setq nlst (append nlst (list i))) 
      ) 
      (setq i (1+ i)) 
    ) 
    (list (length nlst) 
   (if (= 3 (length nlst)) 
     plst 
     nlst 
   ) 
    ) 
  ) 
  ;;计算一: 一负或三负 
  (defun #v1 (h1 h2 h3 h4 a str / v- v+) 
    (if str 
      (progn 
 (setq v- (/ (* a h1 h1 h1) 6 (+ h1 h2) (+ h1 h3)) 
       v+ (+ (/ (* a (- (+ (* 2 (+ h2 h3)) h4) h1)) 6) v-) 
 ) 
      ) 
      (progn 
 (setq v+ (/ (* a h1 h1 h1) 6 (+ h1 h2) (+ h1 h3)) 
       v- (+ (/ (* a (- (+ (* 2 (+ h2 h3)) h4) h1)) 6) v+) 
 ) 
      ) 
    ) 
    (list (rtos v- 2 2) (rtos v+ 2 2)) 
  ) 
  ;;计算二: 两负(相邻) 
  (defun #v2 (h1 h2 h3 h4 a / v- v+) 
    (setq 
      v+ (/ (* a (+ h1 h2) (+ h1 h2)) 
     (* 4 (+ h1 h2 h3 h4)) 
  ) 
      v- (/ (* a (+ h3 h4) (+ h3 h4)) 
     (* 4 (+ h1 h2 h3 h4)) 
  ) 
    ) 
    (list (rtos v- 2 2) (rtos v+ 2 2)) 
  ) 
  ;;计算三: 两负(对角) 
  (defun #v3 (h1 h2 h3 h4 a / v1+ v2+ v- v+) 
    (setq 
      v1+ 
   (/ (* a h2 h2 h2) (* 6 (+ h1 h2) (+ h1 h3))) 
      v2+ 
   (/ (* a h3 h3 h3) (* 6 (+ h3 h1) (+ h3 h4))) 
      v- 
   (+ (/ (* a (- (* 2 (+ h1 h4)) h2 h3)) 6) v1+ v2+) 
      v+  (+ v1+ v2+)   ;??? 
    ) 
    (list (rtos v- 2 2) (rtos v+ 2 2)) 
  ) 
  ;;零线点 
  (defun #z_pt (h1 h2 p1 p2 / z_p) 
    (if (/= h2 0) 
      (setq z_p (polar p1 
         (angle p1 p2) 
         (/ (* (distance p1 
           p2 
        ) 
        h1 
     ) 
     (+ h1 h2) 
         ) 
  ) 
      ) 
      (setq z_p p2) 
    ) 
    z_p 
  ) 
  ;;计算主程序 
  (defun caltf (p1    p2    p3   p4 h1    h2    h3   h4 / 
  _area pmid  pmid1 pmid2 #el   n     #_indx n- 
  #tf   hi1   v   z_p1 z_p2  z_p3  z_p4  _v 
        ) 
    (setq _area (* (distance p1 p2) (distance p1 p3)) ;_网格面积 
   pmid (mapcar '* '(0.5 0.5) (mapcar '+ p1 p4)) 
   pmid1 (polar pmid (* pi 0.5) 1.5) 
   pmid2 (polar pmid (- (* pi 0.5)) 0.2) 
    ) 
    (setq #el  (#test_item (list h1 h2 h3 h4)) 
     ;            0┍---------┐1 
   n  (car #el)  ;负值数量     │         │ 
   #_indx (last #el)  ;负值位置     │         │ 
    )     ;            2┗---------┚3 
    (cond 
      ((or (= n 1) ;_一负或三负 
    (= n 3) 
       ) 
       (setq n- (car #_indx)) 
       (cond 
  ((= n- 0) 
   (setq v    (if (= n 1) 
         (#v1 (abs h1) 
       (abs h2) 
       (abs h3) 
       (abs h4) 
       _area 
       T 
         ) 
         (#v1 (abs h1) 
       (abs h2) 
       (abs h3) 
       (abs h4) 
       _area 
       nil 
         ) 
       ) 
  z_p1 (#z_pt (abs h1) (abs h2) p1 p2) 
  z_p2 (#z_pt (abs h1) (abs h3) p1 p3) 
   ) 
  ) 
  ((= n- 1) 
   (setq v    (if (= n 1) 
         (#v1 (abs h2) 
       (abs h1) 
       (abs h4) 
       (abs h3) 
       _area 
       T 
         ) 
         (#v1 (abs h2) 
       (abs h1) 
       (abs h4) 
       (abs h3) 
       _area 
       nil 
         ) 
       ) 
  z_p1 (#z_pt (abs h2) (abs h1) p2 p1) 
  z_p2 (#z_pt (abs h2) (abs h4) p2 p4) 
   ) 
  ) 
  ((= n- 2) 
   (setq v    (if (= n 1) 
         (#v1 (abs h3) 
       (abs h1) 
       (abs h4) 
       (abs h2) 
       _area 
       T 
         ) 
         (#v1 (abs h3) 
       (abs h1) 
       (abs h4) 
       (abs h2) 
       _area 
       nil 
         ) 
       ) 
  z_p1 (#z_pt (abs h3) (abs h1) p3 p1) 
  z_p2 (#z_pt (abs h3) (abs h4) p3 p4) 
   ) 
  ) 
  (T 
   (setq v    (if (= n 1) 
         (#v1 (abs h4) 
       (abs h2) 
       (abs h3) 
       (abs h1) 
       _area 
       T 
         ) 
         (#v1 (abs h4) 
       (abs h2) 
       (abs h3) 
       (abs h1) 
       _area 
       nil 
         ) 
       ) 
  z_p1 (#z_pt (abs h4) (abs h2) p4 p2) 
  z_p2 (#z_pt (abs h4) (abs h3) p4 p3) 
   ) 
  ) 
       ) 
      ) 
      ((= n 2) ;_两负,相临或对角 
       (cond 
  ((equal #_indx '(0 3)) ;_对角 
   (setq v    (#v3 (abs h2) 
     (abs h1) 
     (abs h4) 
     (abs h3) 
     _area 
       ) 
  z_p1 (#z_pt (abs h1) (abs h3) p1 p3) 
  z_p2 (#z_pt (abs h4) (abs h3) p4 p3) 
  z_p3 (#z_pt (abs h1) (abs h2) p1 p2) 
  z_p4 (#z_pt (abs h4) (abs h2) p4 p2) 
   ) 
  ) 
  ((equal #_indx '(1 2)) ;_对角 
   (setq v    (#v3 (abs h1) 
     (abs h2) 
     (abs h3) 
     (abs h4) 
     _area 
       ) 
  z_p1 (#z_pt (abs h2) (abs h1) p2 p1) 
  z_p2 (#z_pt (abs h3) (abs h1) p3 p1) 
  z_p3 (#z_pt (abs h2) (abs h4) p2 p4) 
  z_p4 (#z_pt (abs h3) (abs h4) p3 p4) 
   ) 
  ) 
  ((equal #_indx '(0 1)) ;_相邻 
   (setq v    (#v2 (abs h3) 
     (abs h4) 
     (abs h1) 
     (abs h2) 
     _area 
       ) 
  Z_P1 (#z_pt (abs h1) (abs h3) p1 p3) 
  z_p2 (#z_pt (abs h2) (abs h4) p2 p4) 
   ) 
  ) 
  ((equal #_indx '(0 2)) 
   (setq v    (#v2 (abs h2) 
     (abs h4) 
     (abs h1) 
     (abs h3) 
     _area 
       ) 
  Z_P1 (#z_pt (abs h1) (abs h2) p1 p2) 
  z_p2 (#z_pt (abs h3) (abs h4) p3 p4) 
   ) 
  ) 
  ((equal #_indx '(1 3)) 
   (setq v    (#v2 (abs h1) 
     (abs h3) 
     (abs h2) 
     (abs h4) 
     _area 
       ) 
  Z_P1 (#z_pt (abs h2) (abs h1) p2 p1) 
  z_p2 (#z_pt (abs h4) (abs h3) p4 p3) 
   ) 
  ) 
  (T 
   ;;(2 3) 
   (setq v    (#v2 (abs h1) 
     (abs h2) 
     (abs h3) 
     (abs h4) 
     _area 
       ) 
  Z_P1 (#z_pt (abs h3) (abs h1) p3 p1) 
  z_p2 (#z_pt (abs h4) (abs h2) p4 p2) 
   ) 
  ) 
       ) 
      ) 
      (T ;_全正(负) 
       (setq #tf (* (* (+ h1 h2 h3 h4) 0.25) 
      _area 
   ) 
      #tf (if (> #tf 0) 
     (strcat "+" 
      (rtos #tf 2 2) 
     ) 
     (rtos #tf 2 2) 
   ) 
       ) 
      ) ;_全正 
    ) ;_cond 
    (if (and (/= n 0) 
      (/= n 4) 
      (/= (distance z_p1 z_p2) 0) 
 ) 
      (progn 
 (ybvl-addline modelspace z_p1 z_p2 "TF-LX") ) 
 (if (and z_p3 
   (/= (distance z_p3 z_p4) 0) 
     ) 
   (ybvl-addline modelspace z_p3 z_p4 "TF-LX") 
 ) 
      ) 
    ) 
    (if v 
      (progn 
 (ybvl-addtext modelspace (strcat "-" (car v)) pmid1 0.9 1 "TF-TF") 
 (ybvl-addtext modelspace (strcat "+" (cadr v)) pmid2 0.9 1 "TF-TF") 
      ) 
      (ybvl-addtext modelspace #tf pmid 0.9 1 "TF-TF") 
    ) 
  ) 
  ;;main 
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)) 
 modelspace  (vla-get-modelspace thisdrawing) 
  ) 
  (vla-startundomark thisdrawing) 
  (vl-catch-all-apply 
    (function 
      (lambda (/ _v tb ll tf l1 l2 j11 j12 _l2) 
 (setq _v '(2.1 -0.5 0.)) 
 (ybvl-clearcset) 
 (while 
   (progn (princ "\n请选取计算列的高程文字 <退出>: ") 
   (ssget '((0 . "TEXT") (8 . "TF-GC"))) 
   ) 
    (setq tb nil) 
    ;;构造表(((x1 y1) "string1") ((x2 y2) "string2") ......) 
    (vlax-for obj (vla-get-activeselectionset thisdrawing) 
      ;;(if tf (setq h (vla-get-height obj) tf nil)) 
      (setq tb 
      (cons 
        (list 
   (ybl-pt->2d (vlax-get obj 'textalignmentpoint)) ;_标高右下对齐点 
   (read (vl-string-left-trim "+" (vla-get-textstring obj)) ;_高差 
   ) 
        ) 
        tb 
      ) 
      ) 
    ) 
    (setq ll (ybl-ent-sort tb 0 1 0.001)) ;_按行排列 (((p11 h11) (p12 h12) ...) ((p21 h21) (p22 h22) ...) ...) 
    ;; ll 网格交点坐标 
    (while (>= (length ll) 2) ;_保证一行方格 
      (setq l1  (car ll) 
     l2  (cadr ll) 
     _l2 l2 
      ) ;_第二行 
      (while (> (length l1) 1) ;_第一行 
        ;;   L1    j11 +-------------+j12 
        ;;             |             | 
        ;;             |             | 
        ;;             |             | 
        ;;   L2    j21 +-------------+j22 
        (setq j11 (car l1) ;_(p11 h11) 
       j12 (cadr l1) ;_(p12 h12) 
       tf  t 
        ) 
        (while (and tf _l2) 
   (if (equal (caaar _l2) (caar j11) 1e-3) 
     (setq tf nil) 
     (setq _l2 (cdr _l2)) 
   ) 
        ) 
        (if (and _l2 ;_第二行中有对应的点 
   (equal (caar j11) (caaar _l2) 1e-3) ;_ x of j11 & x of j21 
   (equal (caar j12) (caaadr _l2) 1e-3) ;_ x of j21 & x of j22 
     ) ;_矩形 
   (progn 
     (caltf (mapcar '+ (car j11) _v) 
     (mapcar '+ (car j12) _v) 
     (mapcar '+ (caar _l2) _v) 
     (mapcar '+ (caadr _l2) _v) 
     (last j11) 
     (last j12) 
     (last (car _l2)) 
     (last (cadr _l2)) 
     ) 
   ) ;_progn 
        ) ;_if 
        (setq l1 (cdr l1)) 
      ) ;_while 第一行 
      (setq ll (cdr ll)) 
    ) ;_while 总行 
 ) ;_while 
      ) 
    ) 
  ) 
  (vla-endundomark thisdrawing) 
  (princ) 
)

fang_123 · 发表于 2013-5-29 17:49:03

看不到！！！来混个豆！！！！{:soso_e113:}

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

[他山之石] 一个排序函数,应用慢慢添加

评分

评分

评分