社区 › Auto Lisp › 将颜色指定给2d

gvlisnas 发表于 2022-7-6 11:10:04

将颜色指定给2d

大家圣诞快乐！
 
我正在寻找一种方法来解决我遇到的两个问题。
1） 我正在处理等高线，我正在寻找一种lisp，它可以检测二维多段线或具有相同高程的多段线，并为它们指定预定义的颜色。
例如
标高=1,6,101001000=蓝色
标高-2,7,202002000=颜色32
标高=3,8,3030003000=绿色
等等
 
我不知道这是否有帮助，但所有的轮廓都在同一层。
 
2） 我有很多文本元素（不是多行文字），其中许多相互重叠。所以我正在寻找一个程序来识别这些文本并高亮显示或更改它们的颜色，这样我就可以手动移动它们。
 
我非常感谢你的帮助！
谢谢

VovKa 发表于 2022-7-6 11:14:19

这将试图解决您的第一个问题

(vl-load-com)
(defun c:test (/ Elev SS)
(princ "\nSelect contours: ")
(if (setq SS (ssget (list (cons 0 "LWPOLYLINE"))))
   (foreach EntObj (mapcar 'vlax-ename->vla-object
                  (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
          )
   (setq Elev (vla-get-Elevation EntObj))
   (vla-put-Color
EntObj
(cond ((vl-position Elev (list 1.0 6.0 10.0 100.0 1000.0)) 5)
      ((vl-position Elev (list 2.0 7.0 20.0 200.0 2000.0)) 32)
      ((vl-position Elev (list 3.0 8.0 30.0 3000.0 3000.0)) 3)
)
   )
   )
)
(princ)
)

CAB 发表于 2022-7-6 11:20:45

第二部分：
;; TextOverlap.lspCAB 12.27.07
;;Circle Text overlap in current space
;;Returns the list of circles created to flag the overlaps
(defun c:TOL() (c:TextOverlap))
(defun c:TextOverlap (/ ss *doc* lay olst obj1 obj2 intlst olf)
(vl-load-com)
;;==============================================================
;;return a list of intersect points
;;==============================================================
(defun get_interpts (obj1 obj2 / iplist)
   (if (not (vl-catch-all-error-p
            (setq iplist (vl-catch-all-apply
                           'vlax-safearray->list
                           (list
                               (vlax-variant-value
                                 (vla-intersectwith obj1 obj2 acextendnone)
                               ))))))
   iplist
   )
)

(defun makecircle (pts)
   (entmakex (list (cons 0 "CIRCLE")
            (cons 8 "OVERLAP")
            (cons 10 (list (car pts) (cadr pts)))
            (cons 40 10.0) ; radius
            ))
)

(and (setq *doc* (vla-get-activedocument (vlax-get-acad-object)))
      (setq lay (vla-add (vla-get-layers *doc*) "OVERLAP"))
      (or (vla-put-color lay acred) t)
      (setq ss (ssget "_x"
                      (list (cons 0 "TEXT,MTEXT") (cons 410 (getvar "ctab")))))
      (setq olst (mapcar 'vlax-ename->vla-object (mapcar 'cadr (ssnamex ss))))
      (princ (strcat "\n" (itoa(length olst)) " items to process, Please wait....\n"))
      (while (setq obj1 (car olst) olst (cdr olst))
      (foreach obj2 olst
          (if (setq pts (get_interpts obj1 obj2))
            (setq intlst (cons (cons obj1 obj2) intlst)
                  olf (cons (makecircle pts) olf))
          )
      )
      )
)
olf
)

gvlisnas 发表于 2022-7-6 11:23:12

非常感谢你！
 
第二个很有魅力！我真的很感激！谢谢你，出租车！
第一个很好用，这正是我想要的。但是你能修改它使它同时适用于多段线和二维多段线吗？
我可能在同一张有立面图的图纸中有两个。
 
非常感谢

VovKa 发表于 2022-7-6 11:27:52

(vl-load-com)
(defun c:test (/ Elev SS)
(princ "\nSelect contours: ")
(if (setq SS (ssget (list (cons 0 "*POLYLINE"))))
   (foreach EntObj (mapcar 'vlax-ename->vla-object
                  (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
          )
   (if (vlax-property-available-p EntObj 'Elevation)
(progn (setq Elev (vla-get-Elevation EntObj))
       ((lambda        (c)
          (if c
          (vla-put-Color EntObj c)
          )
        )
       (cond ((vl-position Elev (list 1.0 6.0 10.0 100.0 1000.0)) 5)
             ((vl-position Elev (list 2.0 7.0 20.0 200.0 2000.0)) 32)
             ((vl-position Elev (list 3.0 8.0 30.0 3000.0 3000.0)) 3)
             (t nil)
       )
       )
)
   )
   )
)
(princ)
)

gvlisnas 发表于 2022-7-6 11:30:33

很 完美！
：眨眼：
 
再次感谢你们！

blahdc 发表于 2022-7-6 11:37:32

很抱歉在这里打了一匹死马，但我使用了搜索并找到了这条线索
 
我试过运行上面CAB提供的“textoverlap.lsp”，但它似乎与我的2005 AutoCAD不兼容。我有很多相互重叠的文本，有没有人有任何lsp可以重新排列所有重叠的文本？

Lee Mac 发表于 2022-7-6 11:39:24

我试过解决这个问题。

blahdc 发表于 2022-7-6 11:43:20

李·麦克，
 
谢谢你的回复。我必须先在沼泽登记才能查看。我在考虑相同的文本重叠问题，但是lisp是否可以移动文本，使它们不再接触或在绘制的边界框内？
 
谢谢你的帮助！

Lee Mac 发表于 2022-7-6 11:46:45

我认为当前可能会设置为使用文本/多行文字过滤检查，您可能必须将其从过滤列表中删除-我不确定文本与文本相交时的准确性，因为我没有这样测试-但请告诉我您进展如何。

查看完整版本: 将颜色指定给2d