[lostbalance]我的通用函数库wyb-函数

fangmin723 · 发表于 2021-11-9 09:18

本帖最后由 fangmin723 于 2021-11-9 09:22 编辑

识别还不是很准确，基本上是可以用的

20060510412 · 发表于 2021-12-7 14:55

写代码的时候，怎么预加载函数库啊

lostbalance · 发表于 2021-12-20 16:35

fangmin723 发表于 2021-11-9 09:18
识别还不是很准确，基本上是可以用的

你说的不是很准确是指哪个？

你第一张截图里，所有黄箭头所指的都不对吗？粗看，除了最大的图框的斜线有问题，其他文字和图形的斜线看起来没什么问题啊。

图框这个，你是不是用块？块的基准点在图形外的话，容易出现这样的情况。

uualice2020 · 发表于 2021-12-23 10:21

感谢分享学习!!!!!

fangmin723 · 发表于 2022-12-9 15:52

优化内容：
1、单个图元无法创建包围框。
2、如果有多行文字时，多行文字外框超过文字内容时，无法准确识别（见截图代码下面的截图）。

优化后代码：
部分代码取自：KozMos AnnoQuarX Functions

(defun c:mBox (/ A B BOX C ent FLAG INTERSECT L L1 N RECTANG SS)
(defun box (e / b enx h j l lst n o obj p1 p2 p3 p4 r w xylst)
(setq enx (entget e))
(if (or (= "MTEXT" (cdr (assoc 0 enx))) (= "TEXT" (cdr (assoc 0 enx))))
(progn
(setq l
(cond
((= "TEXT" (cdr (assoc 0 enx)))
(setq
b (cdr (assoc 10 enx))
r (cdr (assoc 50 enx))
l (textbox enx)
n (cdr (assoc 210 enx))
)
(list
(list (caar l) (cadar l))
(list (caadr l) (cadar l))
(list (caadr l) (cadadr l))
(list (caar l) (cadadr l))
)
)
((= "MTEXT" (cdr (assoc 0 enx)))
(setq
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)
)
)
)
(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
xylst (apply 'mapcar (cons 'list (mapcar '(lambda (x) (trans x n 0)) l)))
p1 (list (apply 'min (car xylst)) (apply 'min (cadr xylst)))
p3 (list (apply 'max (car xylst)) (apply 'max (cadr xylst)))
)
)
(progn
(setq obj (vlax-ename->vla-object e))
(vla-GetBoundingBox obj 'p1 'p3)
(setq p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3)
p2 (list (car p1) (cadr p3) (caddr p1))
p4 (list (car p3) (cadr p1) (caddr p1))
)
(if (= "SPLINE" (cdr (assoc 0 enx)))
(progn
(setq lst
(mapcar '(lambda(a b)
(vlax-curve-getClosestPointToProjection e a b t)
)
(list p1 p2 p3 p4)
'((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
)
)
(setq
p1 (apply 'mapcar (cons 'min lst))
p3 (apply 'mapcar (cons 'max lst))
)
)
)
)
)
(list p1 p3)
)
(defun intersect (a b)
(if
(or
(and
(<= (caar a) (caar b) (caadr a))
(<= (cadar a) (cadar b) (cadadr a))
)
(and
(<= (caar a) (caar b) (caadr a))
(<= (cadar a) (cadadr b) (cadadr a))
)
(and
(<= (caar a) (caadr b) (caadr a))
(<= (cadar a) (cadadr b) (cadadr a))
)
(and
(<= (caar a) (caadr b) (caadr a))
(<= (cadar a) (cadar b) (cadadr a))
)
)
(list
(apply 'mapcar (cons 'min (append a b)))
(apply 'mapcar (cons 'max (append a b)))
)
)
)
(defun rectang (a b)
(if (not (tblsearch "LAYER" "批量打印层"))
(entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") '(70 . 0) '(62 . 1) '(6 . "Continuous") (cons 2 "批量打印层")))
)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(8 . "批量打印层")
'(62 . 1)
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 10 a)
(list 10 (car a) (cadr b))
(cons 10 b)
(list 10 (car b) (cadr a))
)
)
)
(if (setq ss (ssget))
(cond
((> (sslength ss) 1)
(setq n -1)
(while (setq ent (ssname ss (setq n (1+ n))))
(setq l (cons (box ent) l))
)
(setq l
(vl-sort
l
'(lambda(a b)
(if (equal (caar a) (caar b) 1e-3)
(if (equal (cadar a) (cadar b) 1e-3)
(if (equal (caadr a) (caadr b) 1e-3)
(< (cadadr a) (cadadr b))
(< (caadr a) (caadr b))
)
(< (cadar a) (cadar b))
)
(< (caar a) (caar b))
)
)
)
)
(setq a (car l) l (cdr l))
(while l
(setq l1 nil flag nil)
(while l
(setq b (car l) l (cdr l))
(if (setq c (intersect a b))
(setq a c flag t)
(setq l1 (cons b l1))
)
)
(setq l (reverse l1))
(if (not flag)
(progn
(rectang (car a) (cadr a))
(setq a (car l)
l (cdr l)
)
)
)
(if (not l) (rectang (car a) (cadr a)))
)
)
(T
(setq a (box (ssname ss 0)))
(rectang (car a) (cadr a))
)
)
)
(princ)
)

(defun c:mBox (/ A B BOX C ent FLAG INTERSECT L L1 N RECTANG SS) 
  (defun box (e / b enx h j l lst n o obj p1 p2 p3 p4 r w xylst) 
    (setq enx (entget e)) 
    (if (or (= "MTEXT" (cdr (assoc 0 enx))) (= "TEXT" (cdr (assoc 0 enx)))) 
      (progn 
        (setq  l 
          (cond 
            ((= "TEXT" (cdr (assoc 0 enx))) 
              (setq 
                b (cdr (assoc 10 enx)) 
                r (cdr (assoc 50 enx))    
                l (textbox enx)       
                n (cdr (assoc 210 enx))    
              ) 
              (list 
                (list (caar l) (cadar l))    
                (list (caadr l) (cadar l)) 
                (list (caadr l) (cadadr l)) 
                (list (caar l) (cadadr l)) 
              ) 
            ) 
            ((= "MTEXT" (cdr (assoc 0 enx))) 
              (setq 
                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) 
                      
                    ) 
                  ) 
              ) 
              (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 
          xylst (apply 'mapcar (cons 'list (mapcar '(lambda (x) (trans x n 0)) l))) 
          p1 (list (apply 'min (car xylst)) (apply 'min (cadr xylst))) 
          p3 (list (apply 'max (car xylst)) (apply 'max (cadr xylst))) 
        ) 
      ) 
      (progn 
        (setq obj (vlax-ename->vla-object e)) 
        (vla-GetBoundingBox obj 'p1 'p3) 
        (setq p1 (vlax-safearray->list p1) 
          p3 (vlax-safearray->list p3) 
          p2 (list (car p1) (cadr p3) (caddr p1)) 
          p4 (list (car p3) (cadr p1) (caddr p1)) 
        ) 
        (if  (= "SPLINE" (cdr (assoc 0 enx))) 
          (progn 
            (setq lst 
              (mapcar '(lambda(a b) 
                         (vlax-curve-getClosestPointToProjection e a b t) 
                       ) 
                (list p1 p2 p3 p4) 
                '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0)) 
              ) 
            ) 
            (setq 
              p1 (apply 'mapcar (cons 'min lst)) 
              p3 (apply 'mapcar (cons 'max lst)) 
            ) 
          ) 
        ) 
      ) 
    ) 
    (list p1 p3) 
  ) 
  (defun intersect (a b) 
    (if 
      (or 
        (and 
          (<= (caar a) (caar b) (caadr a)) 
          (<= (cadar a) (cadar b) (cadadr a)) 
        ) 
        (and 
          (<= (caar a) (caar b) (caadr a)) 
          (<= (cadar a) (cadadr b) (cadadr a)) 
        ) 
        (and 
          (<= (caar a) (caadr b) (caadr a)) 
          (<= (cadar a) (cadadr b) (cadadr a)) 
        ) 
        (and 
          (<= (caar a) (caadr b) (caadr a)) 
          (<= (cadar a) (cadar b) (cadadr a)) 
        ) 
      ) 
      (list 
        (apply 'mapcar (cons 'min (append a b))) 
        (apply 'mapcar (cons 'max (append a b))) 
      ) 
    ) 
  ) 
  (defun rectang (a b) 
    (if (not (tblsearch "LAYER" "批量打印层")) 
      (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") '(70 . 0) '(62 . 1) '(6 . "Continuous") (cons 2 "批量打印层"))) 
    ) 
    (entmake 
      (list 
        '(0 . "LWPOLYLINE") 
        '(100 . "AcDbEntity") 
        '(8 . "批量打印层") 
        '(62 . 1) 
        '(100 . "AcDbPolyline") 
        '(90 . 4) 
        '(70 . 1) 
        (cons 10 a) 
        (list 10 (car a) (cadr b)) 
        (cons 10 b) 
        (list 10 (car b) (cadr a)) 
      ) 
    ) 
  ) 
  (if (setq ss (ssget)) 
    (cond 
      ((> (sslength ss) 1) 
        (setq n -1) 
        (while (setq ent (ssname ss (setq n (1+ n)))) 
          (setq l (cons (box ent) l)) 
        ) 
        (setq l 
          (vl-sort 
            l 
            '(lambda(a b) 
               (if (equal (caar a) (caar b) 1e-3) 
                 (if  (equal (cadar a) (cadar b) 1e-3) 
                   (if (equal (caadr a) (caadr b) 1e-3) 
                     (< (cadadr a) (cadadr b)) 
                     (< (caadr a) (caadr b)) 
                   ) 
                   (< (cadar a) (cadar b)) 
                 ) 
                 (< (caar a) (caar b)) 
               ) 
             ) 
          ) 
        ) 
        (setq a (car l) l (cdr l)) 
        (while l 
          (setq l1 nil flag nil) 
          (while l 
            (setq  b (car l) l (cdr l)) 
            (if (setq c (intersect a b)) 
              (setq a c flag t) 
              (setq l1 (cons b l1)) 
            ) 
          ) 
          (setq l (reverse l1)) 
          (if (not flag) 
            (progn 
              (rectang (car a) (cadr a)) 
              (setq a (car l) 
                l (cdr l) 
              ) 
            ) 
          ) 
          (if (not l) (rectang (car a) (cadr a))) 
        ) 
      ) 
      (T 
        (setq a (box (ssname ss 0))) 
        (rectang (car a) (cadr a)) 
      ) 
    ) 
  ) 
  (princ) 
)

magicheno · 发表于 2022-12-9 22:27

感谢大佬分享

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

[源码] [lostbalance]我的通用函数库wyb-函数

本帖子中包含更多资源

本帖子中包含更多资源