将颜色指定给2d

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

大家圣诞快乐！

我正在寻找一种方法来解决我遇到的两个问题。
1）我正在处理等高线，我正在寻找一种lisp，它可以检测二维多段线或具有相同高程的多段线，并为它们指定预定义的颜色。
例如
标高=1,6,101001000=蓝色
标高-2,7,202002000=颜色32
标高=3,8,3030003000=绿色
等等

我不知道这是否有帮助，但所有的轮廓都在同一层。

2）我有很多文本元素（不是多行文字），其中许多相互重叠。所以我正在寻找一个程序来识别这些文本并高亮显示或更改它们的颜色，这样我就可以手动移动它们。

我非常感谢你的帮助！
谢谢

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

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

copy


(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

第二部分：

copy

;; TextOverlap.lsp  CAB 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

copy


(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)
)