品茗新秀 发表于 2015-5-2 00:39:07

求块替换文字

求块替换文字






鱼与熊掌 发表于 2015-8-11 21:18:59

风流少年时 发表于 2015-8-11 20:43 static/image/common/back.gif
要删除圆圈，得到钢筋线坐标算出长度，然后写字。看楼组的发帖数量感觉应该能完成啊。

你可以看他发的帖子,每一篇前面都有个求字.

风流少年时 发表于 2015-8-11 20:43:51

要删除圆圈，得到钢筋线坐标算出长度，然后写字。看楼组的发帖数量感觉应该能完成啊。

tigcat 发表于 2021-8-4 12:51:31

;;liviu_dova@yahoo.com
;;;https://forums.augi.com/showthread.php?175247-AutoCAD-Lisp-For-Replacing-Text-With-A-Block
;;;2020-10-10, 06:59 PM
;;;LiDo
(vl-load-com)
(DEFUN C:tt1 (/ *error* $Name bName EgEnt ENT lsBlN)
(defun *error* (s)
    (or (wcmatch (strcase s) "*BREAK,*CANCEL*,*EXIT*") (prompt (strcat "\nError: " s)))
    (princ)
) ;;*error*
;List of block names
(vlax-for
   itm
    (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
    (if (and
          (vlax-property-available-p itm "Name")
          (/= (substr (setq $Name (vla-get-name itm)) 1 1) "*")
      )
      (setq lsBlN (cons $Name lsBlN))
    )
)
(if lsBlN
    (progn
      (princ "\n选择替换的图块：")
      (setq ent (entsel))
      (setq vobj (Vlax-Ename->Vla-Object (car ent)))
      (setq bname (vla-get-name vobj))
      
;;Choose the block
;;;      (while (not bName)
;;;      (setq bName (getstring T "\nEnter block name or [?]: "))
;;;      (cond
;;;          ( (= bName "?")
;;;            (textscr)
;;;            (prompt "\nDefined blocks:")
;;;            (foreach el lsBlN (prompt (strcat "\n" el)))
;;;            (prompt "\nClick or Press any key to continue...")
;;;            (vl-catch-all-apply (function grread) (list nil 14 0))
;;;            (setq bName (graphscr))
;;;          )
;;;          ( (= bName "")
;;;            (setq bName nil)
;;;          )
;;;          ( (and bName(not (vl-position (strcase bName) (mapcar (function strcase) lsBlN))))
;;;            (setq bName (prompt (strcat "\nCould not find block name \"" bName "\".")))
;;;          )
;;;          (T nil)
;;;      )
;;;      )
;;Choose the text and replace it with the choosed block.
      (while(and(setq ENT (car (entsel "\nSelect the text to be replaced: ")))
                  (= (cdr (assoc 0 (setq EgEnt (entget ENT)))) "TEXT")
            )
      (if (= (logand 4 (cdr (assoc 70 (entget (tblobjname "LAYER" (cdr (assoc 8 EgEnt))))))) 0) ;;Layer not locked
          (progn
            (entdel ENT)
            (entmake
            (list
                (quote (0 . "INSERT"))
                (quote (100 . "AcDbEntity"))
                (cons 67(cdr (assoc 67EgEnt)))
                (cons 410 (cdr (assoc 410 EgEnt)))
                (cons 8   (cdr (assoc 8   EgEnt)))
                (quote (100 . "AcDbBlockReference"))
                (cons 2 bName)
                (cons 10 (cdr (assoc 10 EgEnt)))
                (cons 50 (cdr (assoc 50 EgEnt)))
            )
            )
          )
          (prompt "\nText is on a locked layer.")
      )
      )
    )
    (prompt "\nNo block definitions in the drawing.")
)
(princ)
) ;;REP-TXBK
页: [1]
查看完整版本: 求块替换文字