API应用文字移至圆中心

st788796 · 发表于 2013-11-8 23:29:34

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(defun c:tt (/ ss el)
(if (progn
(princ "\nSelect Text and Circle .....")
(setq ss (ssget '((0 . "text,circle"))))
)
(progn
(setq el (mapcar
'(lambda (x / typ)
(if (= (setq typ (xdrx_getpropertyvalue x "IsA"))
"AcDbText"
)
(list (nth 4 (XD::Geom:Box->9pt (XD::Entity:Box x)))
(list x typ)
)
(list (xdrx_getpropertyvalue x "Center") (list x typ))
)
)
(xdrx_pickset->ents ss)
)
el (XD::List:GroupByIndex el 120.);_误差根据自己图形情况调整
el (vl-remove-if '(lambda (x) (= (length x) 2)) el)
el (vl-remove-if
'(lambda (x)
(apply
'=
(mapcar 'cadr (cdr x))
)
)
el
)
mat (xdrx_matrix_identity 3)
)
(mapcar '(lambda (x)
(xdrx_setpropertyvalue
(cadr x)
"Position"
(xdrx_getpropertyvalue (car x) "Center")
)
)
(mapcar '(lambda (a) (mapcar 'car a))
(mapcar
'(lambda
(c)
(vl-sort
c
'(lambda
(m n)
(< (cadr m) (cadr n))
)
)
)
(mapcar
'cdr
el
)
)
)
)
)
)
(princ)
)

(defun c:tt (/ ss el) 
  (if (progn 
        (princ "\nSelect Text and Circle .....") 
        (setq ss (ssget '((0 . "text,circle")))) 
      ) 
    (progn 
      (setq el        (mapcar 
                  '(lambda (x / typ) 
                     (if (= (setq typ (xdrx_getpropertyvalue x "IsA")) 
                            "AcDbText" 
                         ) 
                       (list (nth 4 (XD::Geom:Box->9pt (XD::Entity:Box x))) 
                             (list x typ) 
                       ) 
                       (list (xdrx_getpropertyvalue x "Center") (list x typ)) 
                     ) 
                   ) 
                  (xdrx_pickset->ents ss) 
                ) 
            el        (XD::List:GroupByIndex el 120.);_误差根据自己图形情况调整 
            el        (vl-remove-if '(lambda (x) (= (length x) 2)) el) 
            el        (vl-remove-if 
                  '(lambda (x) 
                     (apply 
                       '= 
                       (mapcar 'cadr (cdr x)) 
                     ) 
                   ) 
                  el 
                ) 
            mat        (xdrx_matrix_identity 3) 
      ) 
      (mapcar '(lambda (x) 
                 (xdrx_setpropertyvalue 
                   (cadr x) 
                   "Position" 
                   (xdrx_getpropertyvalue (car x) "Center") 
                 ) 
               ) 
              (mapcar '(lambda (a) (mapcar 'car a)) 
                      (mapcar 
                        '(lambda 
                           (c) 
                            (vl-sort 
                              c 
                              '(lambda 
                                 (m n) 
                                  (< (cadr m) (cadr n)) 
                               ) 
                            ) 
                         ) 
                        (mapcar 
                          'cdr 
                          el 
                        ) 
                      ) 
              ) 
      ) 
    ) 
  ) 
  (princ) 
)

xyp1964 · 发表于 2013-11-9 11:46:22

;; 文本移到最近圆心
(defun c:test1411 ()
(xyp-CMDLA0)
(if (setq ss (ssget '((0 . "text,CIRCLE"))))
(progn
(setq lst (xyp-Sort-SsDxf ss 0)
ss1 (xyp-list2ss (cadar lst))
)
(foreach s0 (cadadr lst)
(setq s1 (xyp-EnameClosestToSsel s0 ss1 5))
(xyp-move s0 (xyp-9pt s0 5) (xyp-9pt s1 5))
)
)
)
(xyp-CMDLA1)
)

st788796 · 发表于 2013-11-9 13:47:33

xyp1964 发表于 2013-11-9 11:46

呵呵，院长也来了，用 API 仿写了下院长的函数

(defun List2SS (el / ss)
(setq ss (ssadd))
(foreach e el
(ssadd e ss)
)
ss
)
(defun sort-ssdxf (ss code / ll l)
(setq
lst (mapcar '(lambda (x) (list (cdr (assoc code (entget x))) x))
(xdrx_pickset->ents ss)
)
ll (list (list (car lst)))
lst (cdr lst)
)
(while lst
(if (setq
l (vl-remove-if-not '(lambda (x) (= (car x) (caaar ll))) lst)
)
(setq ll (cons (append l (car ll)) (cdr ll))
lst (vl-remove-if '(lambda (x) (= (car x) (caaar ll))) lst)
)
)
(setq ll (cons (list (car lst)) ll)
lst (cdr lst)
)
)
(mapcar '(lambda (x)
(cons (caar x) (mapcar 'cadr x))
)
(cdr ll)
)
)
(defun EnameClosestToSsel (e ss n / el p)
(ssdel e ss)
(setq p (nth n (XD::Geom:Box->9pt (XD::Entity:Box e)))
el (xdrx_pickset->ents ss)
el (mapcar
'(lambda (x)
(cons
(distance p
(nth n (XD::Geom:Box->9pt (XD::Entity:Box x)))
)
x
)
)
el
)
el (vl-sort el '(lambda (e1 e2) (< (car e1) (car e2))))
)
(cdar el)
)

(defun List2SS (el / ss) 
  (setq ss (ssadd)) 
  (foreach e el 
    (ssadd e ss) 
  ) 
  ss 
) 
(defun sort-ssdxf (ss code / ll l) 
  (setq 
    lst        (mapcar        '(lambda (x) (list (cdr (assoc code (entget x))) x)) 
                (xdrx_pickset->ents ss) 
        ) 
    ll        (list (list (car lst))) 
    lst        (cdr lst) 
  ) 
  (while lst 
    (if        (setq 
          l (vl-remove-if-not '(lambda (x) (= (car x) (caaar ll))) lst) 
        ) 
      (setq ll        (cons (append l (car ll)) (cdr ll)) 
            lst        (vl-remove-if '(lambda (x) (= (car x) (caaar ll))) lst) 
      ) 
    ) 
    (setq ll  (cons (list (car lst)) ll) 
          lst (cdr lst) 
    ) 
  ) 
  (mapcar '(lambda (x) 
             (cons (caar x) (mapcar 'cadr x)) 
           ) 
          (cdr ll) 
  ) 
) 
(defun EnameClosestToSsel (e ss n / el p) 
  (ssdel e ss) 
  (setq        p  (nth n (XD::Geom:Box->9pt (XD::Entity:Box e))) 
        el (xdrx_pickset->ents ss) 
        el (mapcar 
             '(lambda (x) 
                (cons 
                  (distance p 
                            (nth n (XD::Geom:Box->9pt (XD::Entity:Box x))) 
                  ) 
                  x 
                ) 
              ) 
             el 
           ) 
        el (vl-sort el '(lambda (e1 e2) (< (car e1) (car e2)))) 
  ) 
  (cdar el) 
)

xdcad9819 · 发表于 2020-5-6 22:06:30

这个程序怎么运行不了呢

trrt6767 · 发表于 2020-5-13 17:46:54

提示: 作者被禁止或删除内容自动屏蔽

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

trrt6767 trrt6767 当前离线 UID 793678 积分 1 精华贡献威望活跃度 D豆在线时间小时注册时间 2019-11-4 最后登录 1970-1-1 窥视卡雷达卡	发表于 2020-5-13 17:46:54 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽
	论坛插件加载方法发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
	回复支持反对使用道具举报

[每日一码] API应用文字移至圆中心

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

点评

[每日一码] API应用 文字移至圆中心

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

点评

[每日一码] API应用文字移至圆中心