第一个图像显示原始DWG。
第二幅图显示了运行重叠时发生的情况。lsp。
第三张图显示了我希望它做什么。
我已经找了几个小时的东西，可以做到这一点，但找不到任何东西。这样的事情可能吗？
这是在更换过滤器之后吗？ 我已经修改了过滤器列表，请尝试一下：
(defun c:overlap (/ *error* RotateByMatrix AddLwPoly BBox->List GroupByNum GetTextIns Point
ALLOBJS DOC FILTLST ILST LAYER LL NOBJ POLY PT R SPC SS UFLAG UR)
;; Lee Mac~15.03.10
(vl-load-com)
(defun *error* (msg)
(and uFlag (vla-EndUndomark doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ))
(setq layer "OverLapCheck")
(setq FiltLst '((-4 . "<NOT") (0 . "VIEWPORT") (-4 . "NOT>")))
(defun RotateByMatrix (obj pt ang / RotationMatrix Vector)
;; Rotation by Matrix~Lee Mac
(setq RotationMatrix (list (list (cos ang) (- (sin ang))0.0)
(list (sin ang) (cos ang) 0.0)
(list 0.0 0.0 1.0)))
(setq Vector (mapcar (function -) pt
(mapcar
(function
(lambda (row) (apply (function +)
(mapcar (function *) row pt))))
RotationMatrix)))
(vla-transformby obj
(vlax-tmatrix
(append
(mapcar
(function
(lambda (r x) (append r (list x))))
RotationMatrix Vector)
'((0.0 0.0 0.0 1.0))))))
(defun AddLWPoly (blk lst)
(vla-AddLightWeightPolyline blk
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble
(cons 0 (1- (* 2 (length lst)))))
(apply (function append) lst)))))
(defun BBox->List (bbox)
((lambda (bbox)
(mapcar
(function
(lambda (funcs)
(mapcar
(function
(lambda (func)
(apply func bbox)))
funcs)))
'((caarcadar)(caadr cadar)
(caadr cadadr) (caarcadadr))))
(list bbox)))
(defun GroupByNum (lst num / rtn)
(setq rtn nil)
(if lst
(cons (reverse
(repeat num
(progn
(setq rtn (cons (car lst) rtn)
lst (cdr lst))
rtn)))
(GroupByNum lst num))))
(defun GetTextIns (object)
(vlax-get object
(if (eq "AcDbText" (vla-get-ObjectName object))
(if (eq acAlignmentLeft (vla-get-Alignment object))
'InsertionPoint 'TextAlignmentPoint)
'InsertionPoint)))
(defun Point (pt)
(entmakex (list (cons 0 "POINT")
(cons 8 layer)
(cons 10 pt)
(cons 62 2))))
(defun SS->VLA (ss / i e lst)
(setq i -1)
(if ss
(while (setq e (ssname ss (setq i (1+ i))))
(setq lst (cons (vlax-ename->vla-object e) lst))))
lst)
(setq doc (vla-get-ActiveDocument
(vlax-get-acad-object))
spc (if (or (eq acModelSpace (vla-get-ActiveSpace doc))
(eq :vlax-true (vla-get-MSpace doc)))
(vla-get-ModelSpace doc)
(vla-get-PaperSpace doc)))
(or (tblsearch "LAYER" layer)
(vla-add (vla-get-layers doc) layer))
(setq AllObjs (ss->VLA (ssget "_X" FiltLst)))
(if (ssget '((0 . "TEXT,MTEXT,INSERT")))
(progn
(setq uFlag (not (vla-StartUndoMark doc)))
(vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
(if (not (zerop (setq r (+ (vla-get-Rotation obj)
(setq ucsx
(if (eq (vla-get-Objectname obj) "AcDbMText")
(angle '(0 0 0) (getvar 'UCSXDIR)) 0.))))))
(progn
(vla-put-rotation (setq nobj (vla-copy obj)) (- 0.0 ucsx))
(vla-getBoundingBox nobj 'll 'ur)
(RotateByMatrix
(setq Poly
(AddLWPoly spc
(BBox->List
(mapcar (function vlax-safearray->list)
(list ll ur)))))
(GetTextIns obj) r)
(vla-put-layer Poly layer)
(vla-put-Closed Poly :vlax-true)
(vla-delete nobj))
(progn
(vla-getBoundingBox obj 'll 'ur)
(vla-put-layer
(setq Poly
(AddLWPoly spc
(BBox->List
(mapcar (function vlax-safearray->list)
(list ll ur)))))
layer)
(vla-put-Closed Poly :vlax-true)))
(if (setq iLst
(apply (function append)
(vl-remove-if (function null)
(mapcar
(function
(lambda (object)
(GroupByNum
(vlax-invoke Poly
'IntersectWith object acExtendNone) 3)))
(vl-remove obj AllObjs)))))
(progn
(vla-put-color Poly acRed)
(mapcar (function Point) iLst))
(vla-put-color Poly acGreen)))
(vla-delete ss)
(setq uFlag (vla-EndUndoMark doc))))
(princ))
我更改了过滤器，删除了文本过滤器。当我这样做时，文本周围会出现一个红色框，而不像以前那样是绿色的。同样的事情发生在你刚刚发布的代码上。我会继续玩它，也许我错过了什么。。。。 完全正确-表示文本重叠。。。
它不会移动文本-这由你来做 我担心你会这么说。唯一的问题是我可以有500多个文本重叠。哦，很感谢你的帮助。
页:
1
[2]