图片为刷块程序，有心人分享一下

fkyourmather · 发表于 2013-5-29 08:47:41

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

图片为刷块程序，有心人分享一下，

fkyourmather · 发表于 2013-5-29 08:49:29

layiso 不能隔离属性块，如果可以加上隔离，再加刷子，会更好

牢固 · 发表于 2013-5-29 09:20:47

本帖最后由牢固于 2013-5-29 09:38 编辑

只要修改块组码2的块名即可将块修改过来！再修改41 42 43的组码修改比例！

(defun c:tt ()
(if (and (setq e (car(entsel "\n选择块:")))
(= "INSERT" (cdr (assoc 0 (setq e (entget e)))))
(setq dxf2 (assoc 2 e)
dxf8 (assoc 8 e)
dxf41 (assoc 41 e)
dxf42 (assoc 42 e)
dxf43 (assoc 43 e)
dxf50 (assoc 50 e)
)
(not (redraw (cdr (assoc -1 e)) 3))
)
(while (setq ss (ssget ":L" '((0 . "INSERT"))))
(repeat (setq n (sslength ss))
(setq el (entget (ssname ss (setq n (1- n)))))
(setq el (subst dxf2 (assoc 2 el) el)
el (subst dxf8 (assoc 8 el) el)
el (subst dxf41 (assoc 41 el) el)
el (subst dxf42 (assoc 42 el) el)
el (subst dxf43 (assoc 43 el) el)
el (subst dxf50 (assoc 50 el) el)
)
(entmod el)
)
)
)
(princ)
)

(defun c:tt () 
  (if (and (setq e (car(entsel "\n选择块:"))) 
           (= "INSERT" (cdr (assoc 0 (setq e (entget e))))) 
           (setq dxf2 (assoc 2 e) 
                 dxf8 (assoc 8 e) 
                 dxf41 (assoc 41 e) 
                 dxf42 (assoc 42 e) 
                 dxf43 (assoc 43 e) 
                 dxf50 (assoc 50 e) 
                 ) 
           (not (redraw (cdr (assoc -1 e)) 3)) 
           ) 
    (while (setq ss (ssget ":L" '((0 . "INSERT")))) 
      (repeat (setq n (sslength ss)) 
        (setq el (entget (ssname ss (setq n (1- n))))) 
        (setq el (subst dxf2 (assoc 2 el) el) 
              el (subst dxf8 (assoc 8 el) el) 
              el (subst dxf41 (assoc 41 el) el) 
              el (subst dxf42 (assoc 42 el) el) 
              el (subst dxf43 (assoc 43 el) el) 
              el (subst dxf50 (assoc 50 el) el) 
              ) 
        (entmod el) 
        ) 
      ) 
    ) 
  (princ) 
  )

fkyourmather · 发表于 2013-5-29 12:27:24

牢固发表于 2013-5-29 09:20
只要修改块组码2的块名即可将块修改过来！再修改41 42 43的组码修改比例！

;;; 　　　《相同刷》v1.0
;;; ========================================================
;;; 功能：将目标文字内容刷成源文字内容，将目标圆大小刷成源圆
;;; 的大小，将目标块刷成源块一样，将目标线、圆、圆弧、
;;; 多段线等刷成源多段线相同的线宽。源为线、尺寸、填充
;;; 圆弧则目标特性匹配
;;; 使用：命令：xts，选择一个源对象，程序自动判断，再选择集
;;; 作者：langjs qq:59509100 日期:2011年12月19日
;;; ========================================================
(defun c:xts (/ ent i lst mame na pt ss tp ty u1 u2 u3 u4 uu)
(setvar "cmdecho" 0)
(vl-load-com)
(defun #err (s)
(redraw mame 4)
(setvar "nomutt" 0)
(command ".UNDO" "E")
(setq *error* $orr)
(princ)
)
(setq $orr *error*)
(setq *error* #err)
(command ".UNDO" "BE")
(while (not (and
(setq mame (car (entsel "\n选择源对象:")))
(setq ent (entget mame))
(setq ty (cdr (assoc 0 ent)))
(member ty '("TEXT" "MTEXT"
"LWPOLYLINE" "CIRCLE"
"INSERT" "LINE"
"ARC" "HATCH"
"DIMENSION"
)
)
)
)
(if (= 52 (getvar "errno"))
(vl-exit-with-error "")
)
)
(redraw mame 3)
(setvar "nomutt" 1)
(if (member ty '("TEXT" "MTEXT"))
(progn
(setq uu (cdr (assoc 1 ent)))
(princ "\n选择目标对象:<文字相同>")
(setq ss (ssget '((0 . "TEXT,MTEXT"))))
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(entmod (subst
(cons 1 uu)
(assoc 1 ent)
ent
)
)
)
)
)
(if (= ty "CIRCLE")
(progn
(setq uu (cdr (assoc 40 ent)))
(princ "\n选择目标对象:<圆相同>")
(setq ss (ssget '((0 . "CIRCLE"))))
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(entmod (subst
(cons 40 uu)
(assoc 40 ent)
ent
)
)
)
)
)
(if (= ty "INSERT")
(progn
(setq u1 (cdr (assoc 2 ent)))
(setq u2 (cdr (assoc 41 ent)))
(setq u3 (cdr (assoc 42 ent)))
(setq u4 (* (/ (cdr (assoc 50 ent)) pi) 180))
(princ "\n选择目标对象:<块相同>")
(setq ss (ssget '((0 . "INSERT"))))
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(setq lst (cons (cdr (assoc 10 ent)) lst))
)
(command "erase" ss "")
(repeat (setq i (length lst))
(setq pt (nth (setq i (1- i))
lst
)
)
(command "insert" u1 pt u2 u3 u4)
)
)
)
(if (= ty "LWPOLYLINE")
(progn
(if (setq uu (cdr (assoc 43 ent)))
(princ)
(setq uu (cdr (assoc 40 ent)))
)
(princ "\n选择目标对象:<线宽相同>")
(setq ss (ssget '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE,CIRCLE"))))
(repeat (setq i (sslength ss))
(setq na (ssname ss (setq i (1- i))))
(setq ent (entget na))
(setq tp (cdr (assoc 0 ent)))
(if (member tp '("LINE" "ARC"))
(command "pedit" na "Y" "w" uu "x")
)
(if (member tp '("POLYLINE" "LWPOLYLINE"))
(command "pedit" na "w" uu "x")
)
(if (= tp "CIRCLE")
(progn
(setq u1 (cdr (assoc 10 ent)))
(setq u2 (cdr (assoc 40 ent)))
(setq u3 (- (* u2 2) uu))
(setq u4 (+ (* u2 2) uu))
(command "donut" u3 u4 u1 "")
(entdel na)
)
)
)
)
)
(if (member ty '("LINE" "ARC"
"HATCH" "DIMENSION"
)
)
(progn
(princ "\n选择目标对象:<特性匹配>")
(setq ss (ssget (list (cons 0 ty))))
(command "matchprop" mame ss "")
)
)
(redraw mame 4)
(setvar "nomutt" 0)
(command ".UNDO" "E")
(setq *error* $orr)
(princ)
)

;;; 　　　      《相同刷》v1.0 
;;; ======================================================== 
;;; 功能：将目标文字内容刷成源文字内容，将目标圆大小刷成源圆 
;;;       的大小，将目标块刷成源块一样，将目标线、圆、圆弧、 
;;;       多段线等刷成源多段线相同的线宽。源为线、尺寸、填充 
;;;       圆弧则目标特性匹配 
;;; 使用：命令：xts，选择一个源对象，程序自动判断，再选择集 
;;; 作者：langjs     qq:59509100        日期:2011年12月19日 
;;; ======================================================== 
(defun c:xts (/ ent i lst mame na pt ss tp ty u1 u2 u3 u4 uu) 
  (setvar "cmdecho" 0) 
  (vl-load-com) 
  (defun #err (s) 
    (redraw mame 4) 
    (setvar "nomutt" 0) 
    (command ".UNDO" "E") 
    (setq *error* $orr) 
    (princ) 
  ) 
  (setq $orr *error*) 
  (setq *error* #err) 
  (command ".UNDO" "BE") 
  (while (not (and 
  (setq mame (car (entsel "\n选择源对象:"))) 
  (setq ent (entget mame)) 
  (setq ty (cdr (assoc 0 ent))) 
  (member ty '("TEXT" "MTEXT" 
    "LWPOLYLINE" "CIRCLE" 
    "INSERT" "LINE" 
    "ARC" "HATCH" 
    "DIMENSION" 
   ) 
  ) 
       ) 
  ) 
    (if (= 52 (getvar "errno")) 
      (vl-exit-with-error "") 
    ) 
  ) 
  (redraw mame 3) 
  (setvar "nomutt" 1) 
  (if (member ty '("TEXT" "MTEXT")) 
    (progn 
      (setq uu (cdr (assoc 1 ent))) 
      (princ "\n选择目标对象:<文字相同>") 
      (setq ss (ssget '((0 . "TEXT,MTEXT")))) 
      (repeat (setq i (sslength ss)) 
(setq ent (entget (ssname ss (setq i (1- i))))) 
(entmod (subst 
    (cons 1 uu) 
    (assoc 1 ent) 
    ent 
  ) 
) 
      ) 
    ) 
  ) 
  (if (= ty "CIRCLE") 
    (progn 
      (setq uu (cdr (assoc 40 ent))) 
      (princ "\n选择目标对象:<圆相同>") 
      (setq ss (ssget '((0 . "CIRCLE")))) 
      (repeat (setq i (sslength ss)) 
(setq ent (entget (ssname ss (setq i (1- i))))) 
(entmod (subst 
    (cons 40 uu) 
    (assoc 40 ent) 
    ent 
  ) 
) 
      ) 
    ) 
  ) 
  (if (= ty "INSERT") 
    (progn 
      (setq u1 (cdr (assoc 2 ent))) 
      (setq u2 (cdr (assoc 41 ent))) 
      (setq u3 (cdr (assoc 42 ent))) 
      (setq u4 (* (/ (cdr (assoc 50 ent)) pi) 180)) 
      (princ "\n选择目标对象:<块相同>") 
      (setq ss (ssget '((0 . "INSERT")))) 
      (repeat (setq i (sslength ss)) 
(setq ent (entget (ssname ss (setq i (1- i))))) 
(setq lst (cons (cdr (assoc 10 ent)) lst)) 
      ) 
      (command "erase" ss "") 
      (repeat (setq i (length lst)) 
(setq pt (nth (setq i (1- i)) 
        lst 
   ) 
) 
(command "insert" u1 pt u2 u3 u4) 
      ) 
    ) 
  ) 
  (if (= ty "LWPOLYLINE") 
    (progn 
      (if (setq uu (cdr (assoc 43 ent))) 
(princ) 
(setq uu (cdr (assoc 40 ent))) 
      ) 
      (princ "\n选择目标对象:<线宽相同>") 
      (setq ss (ssget '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE,CIRCLE")))) 
      (repeat (setq i (sslength ss)) 
(setq na (ssname ss (setq i (1- i)))) 
(setq ent (entget na)) 
(setq tp (cdr (assoc 0 ent))) 
(if (member tp '("LINE" "ARC")) 
   (command "pedit" na "Y" "w" uu "x") 
) 
(if (member tp '("POLYLINE" "LWPOLYLINE")) 
   (command "pedit" na "w" uu "x") 
) 
(if (= tp "CIRCLE") 
   (progn 
     (setq u1 (cdr (assoc 10 ent))) 
     (setq u2 (cdr (assoc 40 ent))) 
     (setq u3 (- (* u2 2) uu)) 
     (setq u4 (+ (* u2 2) uu)) 
     (command "donut" u3 u4 u1 "") 
     (entdel na) 
   ) 
) 
      ) 
    ) 
  ) 
  (if (member ty '("LINE" "ARC" 
        "HATCH" "DIMENSION" 
       ) 
      ) 
    (progn 
      (princ "\n选择目标对象:<特性匹配>") 
      (setq ss (ssget (list (cons 0 ty)))) 
      (command "matchprop" mame ss "") 
    ) 
  ) 
  (redraw mame 4) 
  (setvar "nomutt" 0) 
  (command ".UNDO" "E") 
  (setq *error* $orr) 
  (princ) 
)

yangliucq · 发表于 2013-5-29 17:13:08

很实用的功能

fang_123 · 发表于 2013-5-29 17:38:00

这个程序以前在哪看过！

金鹅起飞 · 发表于 2013-9-11 09:29:42

谢谢楼主分享，这是个好程序，向楼主致敬！

tianyi1230 · 发表于 2013-11-14 19:27:11

相同刷出新版本了2.0版本，感谢郎大师

455383153 · 发表于 2016-12-27 18:35:51

非常好

账号		自动登录	找回密码
密码			立即注册

[求助] 图片为刷块程序，有心人分享一下

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

评分

浏览过的版块