图形功能(处理存在图形) - 图元居中构思与实现(Foreach-2021.1.2 10 ：41) - 《技术博客》

;;;While  循环：共处理4970单元格；耗时: 67.844 秒
;;;Mapcar 循环：共处理4970单元格；耗时: 67.66  秒
;;;Foreach循环：共处理4970单元格；耗时: 67.134 秒-----------------------------------
;;说明:2021.1.2 10:41完善多行文字的处理效果
(defun c:tt(/ ang by cell cellex celley cells cellsx cellsy cept cl coldislst coltopent colvlst crossrl cspt cylst ent entisinrectang entss getccrossr getptdis getptx getpty getrcrossc hlst interwithpt lshlst lsvlst lx n ptmid remhlst remore remvlst rept rl rowlst rspt rx rxlst sortline ss time1 time2 ty vlst xdislst ydislst)
    (progn
        ;;说明:判断图元是中心点是否在两点构成的矩形框内
        ;;参数:ent:图元图元名
        ;;参数:pt1:矩形框第一点
        ;;参数:pt2:矩形框第一点
        ;;返回:如果图元中心点在两点构成的矩形框内，则返回【图元的中心点】，否则返回【nil】
        (defun EntIsInRectang(ent pt1 pt2 / box isptinrectang pt tmp)
            ;;;判断p点是否在P1，P2构成的矩形框内
            ;;;(IsPtInRectang (getpoint) (getpoint) (getpoint))
            (defun IsPtInRectang(p p1 p2) (vl-every '>= (mapcar '* (mapcar '- p p1) (mapcar '- p2 p)) '(0 0)))
            (defun box(e / getmtextbox ll ur)
                (defun getMTextBox (en / b enx h j l n o r w)
                    (setq
                        enx (entget en)
                        n (cdr (assoc 210 enx))
                        b (trans (cdr (assoc 10 enx)) 0 n)
                        r (angle '(0.0 0.0 0.0) (trans (cdr (assoc 11 enx)) 0 n))
                        w (cdr (assoc 42 enx))
                        h (cdr (assoc 43 enx))
                        j (cdr (assoc 71 enx))
                        o (list
                                (cond
                                    ((member j '(2 5 8)) (/ w -2.0))
                                    ((member j '(3 6 9)) (- w))
                                    (0.0)
                                )
                                (cond
                                    ((member j '(1 2 3)) (- h))
                                    ((member j '(4 5 6)) (/ h -2.0))
                                    (0.0)
                                )
                            )
                        l (list
                                (list (car o) (cadr o))
                                (list (+ (car o) w) (cadr o))
                                (list (+ (car o) w) (+ (cadr o) h))
                                (list (car o) (+ (cadr o) h))
                            )
                    )
                    (setq l 
                        (
                            (lambda (m)
                                (mapcar
                                    '(lambda (p)
                                         (mapcar '+(mapcar '(lambda (r) (apply '+ (mapcar '* r p))) m) b)
                                     )
                                    l
                                )
                            )
                            (list
                                (list (cos r) (sin (- r)) 0.0)
                                (list (sin r) (cos r) 0.0)
                                '(0.0 0.0 1.0)
                            )
                        )
                    )
                    (setq l (mapcar '(lambda (x) (trans x n 0)) l))
                    (list (car l) (caddr l))
                )
                (if (= "MTEXT" (cdr (assoc 0 (entget e))))
                    (getMTextBox e)
                    (progn
                        (vla-getboundingbox (vlax-ename->vla-object e) 'll 'ur)
                        (mapcar 'vlax-safearray->list (list ll ur))
                    )
                )
            )
            (setq tmp (box ent) pt (mapcar '* (mapcar '+ (car tmp) (cadr tmp)) '(0.5 0.5 0.5)))
            (if (IsPtInRectang pt pt1 pt2)
                pt
                nil
            )
        )
        ;;说明:消除合并重复直线程序(***消除合并重复线条yad_undup***  YAD建筑")
        ;;参数:ss:需要消重的选择集
        ;;返回:消重后的选择集
        (defun remore(sss / chg_ent dxf on_ent os pmt sdel tang undup)
            (defun dxf(ent i)
                (cdr (assoc i (entget ent)))
            )
            (defun tang(ang sty)
                (rem (+ (* 2 pi) ang) sty)
            )
            (defun chg_ent(ent i pt / en)
                (setq en (entget ent) en (subst (cons i pt) (assoc i en) en))
                (entmod en)
            )
            (defun on_ent(a a1 a2)
                (equal (+ (distance a1 a) (distance a a2)) (distance a1 a2) 0.01)
            )
            (defun undup(s / c ent ent1 ent2 ept1 ept2 m n nm sdels spt1 spt2 ss)
                (setq n -1 nm 0 sdels s)
                (while (setq ent1 (ssname s (setq n (1+ n))))
                    (if (entget ent1)
                        (progn
                            (setq spt1 (dxf ent1 10) ept1 (dxf ent1 11))
                            (if (setq ss (ssget "cp" (list (polar spt1 (angle ept1 spt1) 0.1)
                                                                                 (polar ept1 (- (angle spt1 ept1) (/ pi 4)) 0.15)
                                                                                 (polar ept1 (+ (angle spt1 ept1) (/ pi 4)) 0.15)
                                                                             ) '((0 . "line"))
                                                     )
                                    )
                                (progn
                                    (ssdel ent1 ss)
                                    (setq m -1 c (sslength ss))
                                    (repeat c
                                        (setq ent (ssname ss (setq m (1+ m))))
                                        (if (not (ssmemb ent s))
                                            (progn
                                                (ssdel ent ss)
                                                (setq m (1- m))
                                            )
                                        )
                                    )
                                    (setq m -1 c (sslength ss))
                                    (repeat c
                                        (setq ent2 (ssname ss (setq m (1+ m))))
                                        (setq spt2 (dxf ent2 10) ept2 (dxf ent2 11))
                                        (cond
                                            ((and (on_ent spt2 spt1 ept1) (on_ent ept2 spt1 ept1))
                                                (entdel ent2)
                                                (if (ssmemb ent2 sdels) (ssdel ent2 sdels))
                                            )
                                            ((and (on_ent spt1 spt2 ept2) (on_ent ept1 spt2 ept2))
                                                (entdel ent1)
                                                (if (ssmemb ent1 sdels) (ssdel ent1 sdels))
                                                (setq ent1 ent2 spt1 spt2 ept1 ept2)
                                            )
                                            ((and (equal (tang (angle spt1 ept1) pi) (tang (angle spt2 ept2) pi) 0.001)
                                                 (or (on_ent spt2 spt1 ept1) (on_ent ept2 spt1 ept1))
                                             )
                                                (entdel ent2)
                                                (if (ssmemb ent2 sdels) (ssdel ent2 sdels))
                                                (progn
                                                    (if (on_ent spt2 spt1 ept1)
                                                        (setq spt2 ept2)
                                                    )
                                                    (if (> (distance spt1 spt2) (distance ept1 spt2))
                                                        (progn (chg_ent ent1 11 spt2) (setq ept1 spt2))
                                                        (progn (chg_ent ent1 10 spt2) (setq spt1 spt2))
                                                    )
                                                )
                                            )
                                            (T (setq nm (1- nm)))
                                        )
                                        (setq nm (1+ nm))
                                    )
                                )
                            )
                        )
                    )
                )
                sdels
            )
            (command "_.undo" "_be")
            (command "_.ucs" "")
            (setq os (getvar "osmode") sdel (ssadd))
            (setvar "cmdecho" 0)
            (setvar "osmode" 0)
            (if (> (sslength sss) 1) (progn (setq sdel (undup sss)) (setq pmt T)) (setq sdel sss))
            (if (and sss (not pmt)) sss)
            (setvar "osmode" os)
            (command "_.undo" "_e")
            sdel
        )
        ;;说明:获取两个对象交点
        ;;参数:ent1:图元1
        ;;参数:ent2:图元2
        ;;返回:有交点则返回交点列表，没有交点则返回nil
        (defun InterWithPt(ent1 ent2 / bf-list-split-3d var)
            ;;;name:BF-list-split-3d
            ;;;desc:列表按顺序切分为3元素表组成的表,不足部分用nil表示
            ;;;arg:lst:列表
            ;;;return:((x x x )(x x x)...)
            ;;;example:(BF-list-split-3d '(1 2 3 4))
            (defun BF-list-split-3d    (lst)
                (if lst
                    (cons
                        (list
                            (car lst)
                            (cadr lst)
                            (caddr lst)
                        )
                        (BF-list-split-3d (cdddr lst))
                    )
                )
            )
            (if (>
                        (vlax-safearray-get-u-bound
                            (setq
                                var (vlax-variant-value
                                            (vla-IntersectWith (vlax-ename->vla-object ent1) (vlax-ename->vla-object ent2) acExtendNone)
                                        )
                            )
                            1
                        )
                        1
                    )
                (BF-list-split-3d (vlax-safearray->list var))
                nil
            )
        )
        (defun getptx(ent) (cadr (assoc 10 (entget ent))))
        (defun getpty(ent) (caddr (assoc 10 (entget ent))))
        ;;说明:获取图元间距离表
        ;;参数:entlst:图元表
        ;;返回:返回图元间距离表
        (defun GetPtDis(entlst isx)
            (if isx
                (mapcar (function (lambda (x y) (abs (- (getptx x) (getptx y))))) (cdr entlst) (reverse (cdr (reverse entlst))))
                (mapcar (function (lambda (x y) (abs (- (getpty x) (getpty y))))) (cdr entlst) (reverse (cdr (reverse entlst))))
            )
        )
        (defun GetRCrossC(ent lst)
            (setq xlst nil clst nil)
            (foreach e lst
                (if (setq pt (InterWithPt ent e))
                    (setq xlst (cons (caar pt) xlst) clst (cons e clst))
                )
            )
            (list (reverse xlst) (vl-sort clst (function (lambda (x y) (< (getptx x) (getptx y))))))
        )
        (defun GetCCrossR(ent lst)
            (setq ylst nil)
            (foreach e lst
                (if (setq pt (InterWithPt ent e))
                    (setq ylst (cons (cadar pt) ylst))
                )
            )
            (reverse ylst)
        )
        ;;说明:直线根据坐标排序
        ;;参数:lst:直线图元表
        ;;参数:Symbol:升降序：<、>
        ;;参数:Isx:T：对X轴排序，nil：对Y轴排序
        ;;返回:排序后的图元表
        (defun SortLine(lst Symbol Isx)
            (if isx
                (vl-sort lst (function (lambda (x y) (Symbol (getptx x) (getptx y)))))
                (vl-sort lst (function (lambda (x y) (Symbol (getpty x) (getpty y)))))
            )
        )
    )
    (setvar "CMDECHO" 0)
    (princ "\n请选择网格线：")
    (setq time1 (getvar "date")) ;;计时1
    (if (setq ss (remore (ssget '((0 . "LINE")))))
        (progn
            (setq n -1 lshlst nil remhlst nil lsvlst nil remvlst nil hlst nil vlst nil)
            (while (setq ent (ssname ss (setq n (1+ n))))
                (setq ang (vla-get-Angle (vlax-ename->vla-object ent)))
                (cond
                    ((or (equal 0 ang 1e-5) (equal pi ang 1e-5) (equal (* 2 pi) ang 1e-5))
                        (setq lshlst (cons ent lshlst))
                        (if (vl-member-if (function (lambda (x) (= (getpty ent) (getpty x)))) remhlst)
                            ()
                            (setq remhlst (cons ent remhlst))
                        )
                        ;(setq lshlst (cons ent lshlst))
                    )
                    ((or (equal (* 0.5 pi) ang 1e-5) (equal (* 1.5 pi) ang 1e-5))
                        (setq lsvlst (cons ent lsvlst))
                        (if (vl-member-if (function (lambda (x) (= (getptx ent) (getptx x)))) remvlst)
                            ()
                            (setq remvlst (cons ent remvlst))
                        )
                    )
                )
            )
            (setq hlst (SortLine remhlst > nil))
            (setq vlst (SortLine remvlst < T))
            (setq rowlst (GetPtDis hlst nil))
            (setq
                cells nil cell nil rxlst nil cylst nil
                lx (getptx (car vlst)) rx (getptx (last vlst))
                ty (getpty (car hlst)) by (getpty (last hlst))
            );;(setq cells nil)
            (foreach RowTopEnt hlst
                (if (not (equal RowTopEnt (last hlst)))
                    (progn
                        (setq 
                            rspt (list lx (- (getpty RowTopEnt) (* 0.5 (car rowlst))))
                            rept (list rx (- (getpty RowTopEnt) (* 0.5 (car rowlst))))
                            rowlst (cdr rowlst)
                            rl (entmakex (list '(0 . "LINE") (cons 10 rspt) (cons 11 rept)))
                            rxlst (car (setq CrossRl (GetRCrossC rl (SortLine lsvlst < T))))
                            colvlst (cadr CrossRl)
                            coldislst (GetPtDis colvlst T)
                        )
                        (entdel rl)
                        (foreach cwid coldislst
                            (setq
                                ColTopEnt (car colvlst) colvlst (cdr colvlst)
                                cellsx (car rxlst) xdislst (cdr rxlst)
                                cspt (list (+ (getptx ColTopEnt) (* 0.5 cwid)) ty)
                                cept (list (+ (getptx ColTopEnt) (* 0.5 cwid)) by)
                                cl (entmakex (list '(0 . "LINE") (cons 10 cspt) (cons 11 cept)))
                                cylst (GetCCrossR cl (SortLine lshlst > nil))
                                cellsy (car cylst)
                                ydislst (cdr cylst)
                            )
                            (entdel cl)
                            (while (< (setq cellex (car xdislst)) (car cspt)) (setq cellsx cellex xdislst (cdr xdislst)))
                            (while (> (setq celley (car ydislst)) (cadr rspt)) (setq cellsy celley ydislst (cdr ydislst)))
                            (setq
                                cell
                                (list
                                    (list cellsx cellsy)
                                    (list cellex celley)
                                )
                            )
                            ;;(entmake (list '(0 . "LINE") (cons 10 (car cell)) (cons 11 (cadr cell)) (cons 62 1)))
                            (if (vl-member-if (function (lambda (x) (and (equal (car x) (car cell)) (equal (cadr x) (cadr cell))))) cells);;(vl-position cell cells)
                                ()
                                (setq cells (cons cell cells))
                            )
                        )
                    )
                )
            )
            (command "undo" "be")
            (foreach x cells
                (setq entss (ssget "C" (car x) (cadr x)) n -1)
                (while (setq ent (ssname entss (setq n (1+ n))))
                    (if (not (ssmemb ent ss))
                        (if (setq ptmid (EntIsInRectang ent (car x) (cadr x)))
                            (command "move" ent "" "non" ptmid "non" (mapcar '* (mapcar '+ (car x) (cadr x)) '(0.5 0.5 0.5)))
                        )
                    )
                )
            )
            (command "undo" "e")
            (setq time2 (getvar "date")) ;;计时2
            (princ (strcat "\n共处理" (rtos (length cells)) "单元格；耗时: " (rtos (* 86400 (- time2 time1)) 2 4) " 秒"))
        )
    )
    (prin1)
)