定位并突出显示特定位置

Manila Wolf · 发表于 2022-7-6 07:38:09

大家好。

我想知道这里有没有海报可以帮忙。我必须提前说，我的lisp技能确实非常有限。

我知道内置的AutoCAD find命令，我可以找到许多可以查找和缩放特定文本的Lisp，但我正在寻找更专用于特定任务的东西。

下面的lisp“LocatePart.lsp”帮助我根据用户输入的文本字符串查找并高亮显示特定块（块名“PartTag”）中特定属性标记（标记名“PART”）的所有实例。
lisp在找到的每个相关属性文本字符串处绘制一个圆环。

这很好，但如果不是在每个找到的点绘制一个甜甜圈，而是从每个找到的属性到原点0,0,0绘制一条线，则更容易看到结果

如果没有lisp知识，我不确定这是否快速简单。

copy

(defun c:LocatePart (/ usrprtnm prtfound enttyp blknm lccosnapm lccentcolr) 
(setq lccosnapm  (getvar "OSMODE"))
;(setq lccentcolr (getvar "CECOLOR"))
;(setvar "CECOLOR" "1")
(setvar "OSMODE" 0)
(setvar "cmdecho" 0)
(getuserprtnum)
(findprtnm)
;(setvar "CECOLOR" lccentcolr)
(setvar "OSMODE" lccosnapm)
(prin1)
;(setvar "cmdecho" 1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; GETUSERPRTNUM - Get Part number from user
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun getuserprtnum ()
 (setq usrprtnm (getstring "\nEnter Partnumber to locate : "))
 (while (= "" usrprtnm)
     (setq usrprtnm (getstring "\nIncorrect input, 
                     enter again (ctrl-c to exit) : "))
 )     
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;  FINDATT - Find attributes in drawing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun findprtnm ()
(setq ctprblk 0)        ;part assembly counter
(setq prtfound 0)        ;reset search counter
(setq e (entnext))
 (progn (prompt "\nSeraching unit assembly ... ")
  (while e
    (setq enttyp (cdr (assoc 0 (entget e))))
    (setq blknm (cdr (assoc 2 (entget e))))
     (if
       (and
         (equal enttyp "INSERT")
  (equal blknm "PartTag")
         ;(equal (cdr (assoc 66 (entget e))) 1)
       ) ;and
        (updprtnmprop e)
     ) ;if
      (setq e (entnext e))
   ) ;while
 ) ;progn
 ;report search status
 (cond ((= prtfound 0)
        (princ (strcase usrprtnm))
        (princ " NOT found !")
        (prin1))
       ((/= prtfound 0)
        (princ prtfound)
        (princ " ")
        (princ (strcase usrprtnm))
        (princ " found")
        (prin1))
 ) ;cond
 
) ;defun findprtnm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;  UPDPRTNMPROP - Compare Part number, change color if found
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun updprtnmprop (e / blkscle insertpt dndia nx ny dnpt)
  (setq blkscle (cdr (assoc 41 (entget e))))
  ;(princ blkscle)
  (setq insertpt (cdr (assoc 10 (entget e))))
  
  (while (not (equal (cdr (assoc 0 (entget e))) "SEQEND"))
      (if
        (and 
           (equal (cdr (assoc 0 (entget e))) "ATTRIB")
           (equal (cdr (assoc 2 (entget e))) "PART")
        ) ;and
                  (progn
                     (setq partnm (strcase (cdr (assoc 1 (entget e)))))
                     ;(princ partnm)
                     (if (= (strcase usrprtnm) (strcase partnm))
                       ;(princ "\nPart name : ")
                ;(princ partnm)
                         (progn
                           ;(princ insertpt)
                           (setq dnind (* 1.0 (abs blkscle)))
                           (setq dndia (* 3.5 (abs blkscle)))
                           (setq ny (cadr insertpt))
                           (setq ofstx (* (abs blkscle) 6.5))
                           (setq nx (+ (car insertpt) ofstx))
                           ;(princ nx)
                           (setq dnpt (list nx ny))
                    ;(princ dndia)
                    (command "donut" 0  dndia dnpt "") 
                           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                    ;change color
                    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                           ;(setq ed (entget e))
                           ;; 62 - color property
                           ;(setq ed (subst (cons 62 1) (assoc 62 ed) ed))
                           ;(entmod ed)
                    ;(entupd e)
                            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                    ;; counter ++
                    (setq prtfound (+ prtfound 1))
                    ;(princ prtfound)
                          ) ;progn
                     )        ;if                                                                                        
                   ) ;progn
      ) ;if
      (setq e (entnext e))
  ) ;while
  
) ;defun updprtnmprop

我附上图纸“TagSystemExample.dwg”以供参考。

我想我正在尝试实现类似于此lisp的功能，即查找块并绘制到原点的直线，如此处所示：-

http://autocadtips.wordpress.com/2011/12/20/autolisp-find-blocks-mark-them/

如有任何帮助或建议，我们将不胜感激。
标记系统示例。图纸

Lee Mac · 发表于 2022-7-6 08:15:50

这适用于文本、多行文字或属性：

copy

(defun c:myfind ( / ent enx inc sel str )
   (if (setq sel
           (ssget "_X"
               (list
                  '(-4 . "<OR")
                      '(0 . "TEXT,MTEXT")
                      '(-4 . "<AND") '(0 . "INSERT") '(66 . 1) '(-4 . "AND>")
                  '(-4 . "OR>")
                   (if (= 1 (getvar 'cvport))
                       (cons 410 (getvar 'ctab))
                      '(410 . "Model")
                   )
               )
           )
       )
       (if (/= "" (setq str (strcase (getstring t "\nFind What?: "))))
           (progn
               (repeat (setq inc (sslength sel))
                   (if (= "INSERT" (cdr (assoc 0 (setq enx (entget (setq ent (ssname sel (setq inc (1- inc)))))))))
                       (while (= "ATTRIB" (cdr (assoc 0 (setq enx (entget (setq ent (entnext ent)))))))
                           (if (= str (strcase (cdr (assoc 1 (reverse enx)))))
                               (entmake (list '(0 . "LINE") (assoc 10 enx) '(11 0.0 0.0 0.0)))
                           )
                       )
                       (if (= str (strcase (cdr (assoc 1 enx))))
                           (entmake (list '(0 . "LINE") (assoc 10 enx) '(11 0.0 0.0 0.0)))
                       )
                   )
               )
           )
       )
       (princ "\nNo Text, MText or Attributes found in this Layout.")
   )
   (princ)
)