cjjh8301 发表于 2020-5-9 16:10:16

求程序-快速做快并拾取文字为块名

10币求个偷懒小程序，程序过程如下：
选取图元，输入命令，空格，拾取文字为块名，空格，选择基点同时完成块制作！

vectra 发表于 2020-5-9 16:10:17

cjjh8301 发表于 2020-5-12 11:17
有同名块没有提示就直接替换了，我是想，出现同名块，就提示下有同名块，然后有(N/Y)选择是否替换，默认 ...

(defun c:tt (/ p ss str doins)
(setvar 'cmdecho 0)
(if (and (setq ss (ssget))
           (setq str (car (entsel "选择块名文字对象:")))
           (setq p (getpoint "指定基点:"))
      )
    (progn
      (setq str          (cdr (assoc 1 (entget str)))
          doins "Y"
      )

      (if (vl-catch-all-error-p
          (vl-catch-all-apply
              'vla-item
              (list (vla-get-blocks
                      (vla-get-activedocument (vlax-get-acad-object))
                  )
                  str
              )
          )
          )
        (command ".block" str p ss "")
        (progn
          (initget "Y N")
          (setq doins (getkword "是否替换同名块[是(Y)/否(N)]:"))
          (if (= "Y" doins)
          (command ".block" str "Y" p ss "")
          )
        )
      )
      (if (= "Y" doins)
        (command ".insert" str p 1. 1. 0.)
      )
    )
)
(setvar 'cmdecho 1)
)

vectra 发表于 2020-5-9 23:42:52

(defun c:tt (/ p ss str)
(setvar 'cmdecho 0)
(if (and (setq ss (ssget))
           (setq str (car (entsel "选择块名文字对象:")))
           (setq p (getpoint "指定基点:"))
      )
    (progn
      (setq str (cdr (assoc 1 (entget str))))
      (command ".block" str p ss "")
      (command ".insert" str p 1. 1. 0.)
    )
)
(setvar 'cmdecho 1)
)

htlaser 发表于 2020-5-10 09:44:52

(defun c:tt (/ p ss ssbox str)   ;已加入块基点
(setvar 'cmdecho 0)
(if (and
                             (setq ssbox (zg-GetSSBoundingbox (setq ss (ssget))))
         (setq str (car (entsel "\n选择块名文字对象:")))                       
                        (setq p (apply 'mapcar (cons (function (lambda (a b) (/ (+ a b) 2))) ssbox))))
    (progn
      (setq str (cdr (assoc 1 (entget str))))
      (command ".block" str p ss "")
      (command ".insert" str p 1. 1. 0.)))
(setvar 'cmdecho 1))
;块基点为选择集中心点原作者：namezg
(defun zg-GetSSBoundingbox (ss / i ssn ll rr box ptlist ssbox)
                (if ss
                        (progn
                                (setq i -1)
                                (repeat (sslength ss)
                                        (setq ssn (ssname ss (setq i (1+ i))))
                                        (vla-GetBoundingBox (vlax-ename->vla-object ssn) 'll 'rr);得到对象的包围盒
                                        (setq box (list (vlax-safearray->list ll) (vlax-safearray->list rr)))
                                        (setq ptlist (append box ptlist)))
                                (setq ssbox (mapcar '(lambda (x) (apply 'mapcar (cons x ptlist))) (list 'min 'max))))))


cjjh8301 发表于 2020-5-10 22:44:30

vectra 发表于 2020-5-9 23:42


可以用，但是我我忽略了一个问题，就是有同名块时，能否提示有同名块，然后可以选择N/Y,
N不替换程序结束；Y替换同名块，结束程序，(默认N)

vectra 发表于 2020-5-11 17:22:58

cjjh8301 发表于 2020-5-10 22:44
可以用，但是我我忽略了一个问题，就是有同名块时，能否提示有同名块，然后可以选择N/Y,
N不替换程序结 ...

(defun c:tt (/ p ss str)
(setvar 'cmdecho 0)
(if (and (setq ss (ssget))
           (setq str (car (entsel "选择块名文字对象:")))
           (setq p (getpoint "指定基点:"))
      )
    (progn
      (setq str (cdr (assoc 1 (entget str))))

      (if (vla-item (vla-get-blocks
                      (vla-get-activedocument (vlax-get-acad-object))
                  )
                  str
          )
        (command ".block" str "Y" p ss "")
        (command ".block" str p ss "")
      )

      (command ".insert" str p 1. 1. 0.)
    )
)
(setvar 'cmdecho 1)
)

cjjh8301 发表于 2020-5-12 08:59:17

vectra 发表于 2020-5-11 17:22
(defun c:tt (/ p ss str)
(setvar 'cmdecho 0)
(if (and (setq ss (ssget))


选择基点后没有成块，麻烦看下，是什么问题！！！

vectra 发表于 2020-5-12 09:58:08

cjjh8301 发表于 2020-5-12 08:59
选择基点后没有成块，麻烦看下，是什么问题！！！

(defun c:tt (/ p ss str)
(setvar 'cmdecho 0)
(if (and (setq ss (ssget))
           (setq str (car (entsel "选择块名文字对象:")))
           (setq p (getpoint "指定基点:"))
      )
    (progn
      (setq str (cdr (assoc 1 (entget str))))

      (if (vl-catch-all-error-p
          (vl-catch-all-apply
              'vla-item
              (list (vla-get-blocks
                      (vla-get-activedocument (vlax-get-acad-object))
                  )
                  str
              )
          )
          )
        (command ".block" str p ss "")
        (command ".block" str "Y" p ss "")
      )
      (command ".insert" str p 1. 1. 0.)
    )
)
(setvar 'cmdecho 1)
)

cjjh8301 发表于 2020-5-12 11:17:14

vectra 发表于 2020-5-12 09:58

有同名块没有提示就直接替换了，我是想，出现同名块，就提示下有同名块，然后有(N/Y)选择是否替换，默认为不替换，帮我再修改下

cjjh8301 发表于 2020-5-12 16:58:03

htlaser 发表于 2020-5-10 09:44
(defun c:tt (/ p ss ssbox str)   ;已加入块基点
(setvar 'cmdecho 0)
(if (and


同时感谢这位兄弟！
页: [1] 2
查看完整版本: 求程序-快速做快并拾取文字为块名