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

cjjh8301

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

vectra

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

1. (defun c:tt (/ p ss str doins)
   
2.   (setvar 'cmdecho 0)
   
3.   (if (and (setq ss (ssget))
   
4.            (setq str (car (entsel "选择块名文字对象:")))
   
5.            (setq p (getpoint "指定基点:"))
   
6.       )
   
7.     (progn
   
8.       (setq str          (cdr (assoc 1 (entget str)))
   
9.             doins "Y"
   
10.       )
    
11. 
    
12.       (if (vl-catch-all-error-p
    
13.             (vl-catch-all-apply
    
14.               'vla-item
    
15.               (list (vla-get-blocks
    
16.                       (vla-get-activedocument (vlax-get-acad-object))
    
17.                     )
    
18.                     str
    
19.               )
    
20.             )
    
21.           )
    
22.         (command ".block" str p ss "")
    
23.         (progn
    
24.           (initget "Y N")
    
25.           (setq doins (getkword "是否替换同名块[是(Y)/否(N)]:"))
    
26.           (if (= "Y" doins)
    
27.             (command ".block" str "Y" p ss "")
    
28.           )
    
29.         )
    
30.       )
    
31.       (if (= "Y" doins)
    
32.         (command ".insert" str p 1. 1. 0.)
    
33.       )
    
34.     )
    
35.   )
    
36.   (setvar 'cmdecho 1)
    
37. )

(defun c:tt (/ p ss str doins)<br />   (setvar 'cmdecho 0)<br />   (if (and (setq ss (ssget))<br />            (setq str (car (entsel "选择块名文字对象:")))<br />            (setq p (getpoint "指定基点:"))<br />       )<br />     (progn<br />       (setq str          (cdr (assoc 1 (entget str)))<br />             doins "Y"<br />       )<br /> <br />       (if (vl-catch-all-error-p<br />             (vl-catch-all-apply<br />               'vla-item<br />               (list (vla-get-blocks<br />                       (vla-get-activedocument (vlax-get-acad-object))<br />                     )<br />                     str<br />               )<br />             )<br />           )<br />         (command ".block" str p ss "")<br />         (progn<br />           (initget "Y N")<br />           (setq doins (getkword "是否替换同名块[是(Y)/否(N)]:"))<br />           (if (= "Y" doins)<br />             (command ".block" str "Y" p ss "")<br />           )<br />         )<br />       )<br />       (if (= "Y" doins)<br />         (command ".insert" str p 1. 1. 0.)<br />       )<br />     )<br />   )<br />   (setvar 'cmdecho 1)<br /> )

vectra

2. (defun c:tt (/ p ss str)
   
3.   (setvar 'cmdecho 0)
   
4.   (if (and (setq ss (ssget))
   
5.            (setq str (car (entsel "选择块名文字对象:")))
   
6.            (setq p (getpoint "指定基点:"))
   
7.       )
   
8.     (progn
   
9.       (setq str (cdr (assoc 1 (entget str))))
   
10.       (command ".block" str p ss "")
    
11.       (command ".insert" str p 1. 1. 0.)
    
12.     )
    
13.   )
    
14.   (setvar 'cmdecho 1)
    
15. )

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

htlaser

(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

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

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

vectra

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

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

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

vectra

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

1. (defun c:tt (/ p ss str)
   
2.   (setvar 'cmdecho 0)
   
3.   (if (and (setq ss (ssget))
   
4.            (setq str (car (entsel "选择块名文字对象:")))
   
5.            (setq p (getpoint "指定基点:"))
   
6.       )
   
7.     (progn
   
8.       (setq str (cdr (assoc 1 (entget str))))
   
9. 
   
10.       (if (vl-catch-all-error-p
    
11.             (vl-catch-all-apply
    
12.               'vla-item
    
13.               (list (vla-get-blocks
    
14.                       (vla-get-activedocument (vlax-get-acad-object))
    
15.                     )
    
16.                     str
    
17.               )
    
18.             )
    
19.           )
    
20.         (command ".block" str p ss "")
    
21.         (command ".block" str "Y" p ss "")
    
22.       )
    
23.       (command ".insert" str p 1. 1. 0.)
    
24.     )
    
25.   )
    
26.   (setvar 'cmdecho 1)
    
27. )

(defun c:tt (/ p ss str)<br />   (setvar 'cmdecho 0)<br />   (if (and (setq ss (ssget))<br />            (setq str (car (entsel "选择块名文字对象:")))<br />            (setq p (getpoint "指定基点:"))<br />       )<br />     (progn<br />       (setq str (cdr (assoc 1 (entget str))))<br /> <br />       (if (vl-catch-all-error-p<br />             (vl-catch-all-apply<br />               'vla-item<br />               (list (vla-get-blocks<br />                       (vla-get-activedocument (vlax-get-acad-object))<br />                     )<br />                     str<br />               )<br />             )<br />           )<br />         (command ".block" str p ss "")<br />         (command ".block" str "Y" p ss "")<br />       )<br />       (command ".insert" str p 1. 1. 0.)<br />     )<br />   )<br />   (setvar 'cmdecho 1)<br /> )

cjjh8301

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

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

cjjh8301

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

同时感谢这位兄弟！