点取对象，根据颜色加粗所有对象------终于完成

自贡黄明儒 · 发表于 2013-7-20 09:34:18

本帖最后由自贡黄明儒于 2013-7-30 08:25 编辑

按理说，绘图我们不需要指定对象宽度，CAD打印时有一个简单的办法，指定颜色的宽度来指印。
我看见设计院的图，估计是他们偷懒，只画主要轮廓线，而且画得很粗，看起来也象模象样的。
有谁写过这样的程序吗，点取对象，根据颜色加粗所有对象？

;;*****************根据颜色，来加宽线自贡黄明儒 2013年7月24日
;;特此鸣谢mccad wowan1314 ll_j
(defun C:HHBC (/ COLOR EN FIL LAYLIS LEN PEDITVAR SS0 SSCIR SSLIN)
;;(setvar "CLAYER" "0")
;;1 Public1 分离选择集
;;SSCIR SSLIN
(defun getMyss (ss0)
(command "_.select" ss0 "")
(setq ssCIR (ssget "_p" (list (cons 0 "CIRCLE"))))
(command "_.select" ss0 "")
(setq ssLIN (ssget "_p"
(list (cons 0 "ARC,LINE,LWPOLYLINE"))
)
)
)
;;2 Public2 处理圆选择集
(defun cirSS (ssCIR LEN color / CENTER EN ENTLIST N R)
(if ssCIR
(repeat (setq n (sslength ssCIR))
(setq en (ssname ssCIR (setq n (1- n))))
(setq entlist (entget en))
(setq r (* (cdr (assoc 40 entlist)) 2))
(setq center (cdr (assoc 10 entlist)))
(command "_.donut" (- r len) (+ r len) center "")
(vlax-put (vlax-ename->vla-object (entlast)) 'color color)
(command "_.erase" en "")
)
)
)
;;3 Public3 处理线选择集
(defun LineSS (SSLIN len)
(SETQ PEDITVAR (GETVAR "PEDITACCEPT"))
(setvar "PEDITACCEPT" 1)
(if SSLIN
(command "_.pedit" "_M" ssLIN "" "_j" "" "w" len "")
)
(setvar "PEDITACCEPT" PEDITVAR)
)
;;4 获取颜色
;;color EN
(defun getcolor (/ ENTLIST LAYER)
(while (not en) (setq en (car (entsel "\n 点取颜色"))))
(setq entlist (entget en))
(if (setq color (cdr (assoc 62 entlist)))
nil
(progn
(setq layer (cdr (assoc 8 entlist)))
(setq color (cdr (assoc 62 (tblsearch "layer" layer))))
)
)
)
;;5 预设线宽
(defun PreWidth (en / CENTER ENLAST ENTLIST LEN LEN1 LI R)
(setq entlist (entget en))
(if (member (setq li (cdr (assoc 0 entlist)))
(list "ARC" "LINE" "CIRCLE" "LWPOLYLINE")
)
(progn
(setq len (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))
(setq len (/ len 100))
(cond ((= li "CIRCLE")
(setq r (* (cdr (assoc 40 entlist)) 2))
(setq center (cdr (assoc 10 entlist)))
(command "donut" (- r len) (+ r len) center "")
(setq enlast (entlast))
)
((= li "LWPOLYLINE") (command "_.PEDIT" en "W" len ""))
(T
(if (= (atof (getvar "acadver")) 16.1)
(command "_.PEDIT" en "Y" "W" len "")
;昨天测试不加Y,今天测还是要加Y(7月25日)
(command "_.PEDIT" en "Y" "W" len "")
)
)
)
(princ "\n 当前线宽是 ")
(princ len)
(initget (+ 2 4))
(setq len1 (getreal (strcat "\n 输入线宽<" (rtos len 2 3) ">")))
(if len1
(progn (setq len len1)
(if enlast
(command "_.erase" enlast "")
)
)
)
)
(progn (princ "\n 默认线宽") (princ (setq len 2.0)))
)
len
)
;;6 处理颜色为指定颜色的对象
;; LAYLIS
(defun Pro:color (color / D LAYER)
;;指定颜色的随层随块层名
(while (setq d (tblnext "LAYER" (null d)))
(setq layer (cdr (assoc 2 d)))
(if (equal (cdr (assoc 62 d)) color)
(setq layLis (if layLis
(strcat layLis "," layer)
layer
)
)
)
)
)

;;*****************根据颜色，来加宽线   自贡黄明儒 2013年7月24日 
;;特此鸣谢mccad wowan1314 ll_j 
(defun C:HHBC (/ COLOR EN FIL LAYLIS LEN PEDITVAR SS0 SSCIR SSLIN) 
  ;;(setvar "CLAYER" "0") 
  ;;1 Public1 分离选择集 
  ;;SSCIR SSLIN 
  (defun getMyss (ss0) 
    (command "_.select" ss0 "") 
    (setq ssCIR (ssget "_p" (list (cons 0 "CIRCLE")))) 
    (command "_.select" ss0 "") 
    (setq ssLIN (ssget "_p" 
         (list (cons 0 "ARC,LINE,LWPOLYLINE")) 
  ) 
    ) 
  ) 
  ;;2 Public2 处理圆选择集 
  (defun cirSS (ssCIR LEN color / CENTER EN ENTLIST N R) 
    (if ssCIR 
      (repeat (setq n (sslength ssCIR)) 
(setq en (ssname ssCIR (setq n (1- n)))) 
(setq entlist (entget en)) 
(setq r (* (cdr (assoc 40 entlist)) 2)) 
(setq center (cdr (assoc 10 entlist))) 
(command "_.donut" (- r len) (+ r len) center "") 
(vlax-put (vlax-ename->vla-object (entlast)) 'color color) 
(command "_.erase" en "") 
      ) 
    ) 
  ) 
  ;;3 Public3 处理线选择集 
  (defun LineSS (SSLIN len) 
    (SETQ PEDITVAR (GETVAR "PEDITACCEPT")) 
    (setvar "PEDITACCEPT" 1) 
    (if SSLIN 
      (command "_.pedit" "_M" ssLIN "" "_j" "" "w" len "") 
    ) 
    (setvar "PEDITACCEPT" PEDITVAR) 
  ) 
  ;;4 获取颜色 
  ;;color EN 
  (defun getcolor (/ ENTLIST LAYER) 
    (while (not en) (setq en (car (entsel "\n 点取颜色")))) 
    (setq entlist (entget en)) 
    (if (setq color (cdr (assoc 62 entlist))) 
      nil 
      (progn 
(setq layer (cdr (assoc 8 entlist))) 
(setq color (cdr (assoc 62 (tblsearch "layer" layer)))) 
      ) 
    ) 
  ) 
  ;;5 预设线宽   
  (defun PreWidth (en / CENTER ENLAST ENTLIST LEN LEN1 LI R) 
    (setq entlist (entget en)) 
    (if (member (setq li (cdr (assoc 0 entlist))) 
  (list "ARC" "LINE" "CIRCLE" "LWPOLYLINE") 
) 
      (progn 
(setq len (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en))) 
(setq len (/ len 100)) 
(cond ((= li "CIRCLE") 
        (setq r (* (cdr (assoc 40 entlist)) 2)) 
        (setq center (cdr (assoc 10 entlist))) 
        (command "donut" (- r len) (+ r len) center "") 
        (setq enlast (entlast)) 
       ) 
       ((= li "LWPOLYLINE") (command "_.PEDIT" en "W" len "")) 
       (T 
        (if (= (atof (getvar "acadver")) 16.1) 
   (command "_.PEDIT" en "Y" "W" len "") 
        ;昨天测试不加Y,今天测还是要加Y(7月25日) 
   (command "_.PEDIT" en "Y" "W" len "") 
        ) 
       ) 
) 
(princ "\n 当前线宽是 ") 
(princ len) 
(initget (+ 2 4)) 
(setq len1 (getreal (strcat "\n 输入线宽<" (rtos len 2 3) ">"))) 
(if len1 
   (progn (setq len len1) 
   (if enlast 
     (command "_.erase" enlast "") 
   ) 
   ) 
) 
      ) 
      (progn (princ "\n 默认线宽") (princ (setq len 2.0))) 
    ) 
    len 
  ) 
  ;;6 处理颜色为指定颜色的对象 
  ;; LAYLIS 
  (defun Pro:color (color / D LAYER) 
    ;;指定颜色的随层随块层名 
    (while (setq d (tblnext "LAYER" (null d))) 
      (setq layer (cdr (assoc 2 d))) 
      (if (equal (cdr (assoc 62 d)) color) 
(setq layLis (if layLis 
         (strcat layLis "," layer) 
         layer 
       ) 
) 
      ) 
    ) 
  )

;;7 本程序主程序
 (setvar "nomutt" 1)
 (princ "\n 拾取颜色")
 (setvar "nomutt" 0)
 (getcolor) ;取得颜色color EN
 (setq len (PreWidth en)) ;线宽
 (setvar "nomutt" 1)
 (princ "\n 窗选处理范围<全部>")
 (Pro:color color) ;得LAYLIS
 (setq fil (list
 '(-4 . "<AND")
 (cons 0 "ARC,LINE,CIRCLE,LWPOLYLINE")
 '(-4 . "<OR")
 (cons 62 color)
 '(-4 . "<AND")
 (cons 8 layLis)
 '(-4 . "<OR")
 (cons 62 0)
 (cons 62 256)
 '(-4 . "OR>")
 '(-4 . "AND>")
 '(-4 . "OR>")
 '(-4 . "AND>")
 )
 )
 (if (setq ss0 (ssget fil))
nil
(setq ss0 (ssget "X" fil))
 )
 (setvar "nomutt" 0)
 (IF ss0
(progn (getMyss ss0) ;分离出选择集SSCIR SSLIN
(cirSS ssCIR LEN color) ;处理圆选择集
(LineSS SSLIN len) ;处理线选择集
)
 )
 ;;8 根据wowan1314建议,块就算了
 (princ)
)
;;*****************根据颜色，来加宽线自贡黄明儒 2013年7月24日

wowan1314,以上程序中当
(setvar "PEDITACCEPT" 1)时
(command "_.PEDIT" en "Y" "W" len "")这个不加Y

lgzh0008 · 发表于 2018-9-3 21:57:58

下下来看看。，学习学习

oistre · 发表于 2018-8-26 03:19:25

大神牛牛牛牛！

依然小小鸟 · 发表于 2018-10-24 11:34:07

不错的帖子

mccad · 发表于 2013-7-20 09:46:47

圆需要处理成两个半圆弧段的多段线

wowan1314 · 发表于 2013-7-20 10:14:08

圆用(command "donut"
其他用(command "pedit"

你是不是已经告别command 了？我喜欢command

自贡黄明儒 · 发表于 2013-7-20 10:14:59

mccad 发表于 2013-7-20 09:46
圆需要处理成两个半圆弧段的多段线

这样一来，块中圆就比较麻烦了。牵涉到删除添加对象,又是矩阵转换。

自贡黄明儒 · 发表于 2013-7-20 10:18:57

wowan1314 发表于 2013-7-20 10:14
圆用(command "donut"
其他用(command "pedit"

用command程序很简单，也容易理解。
我只不过在练习矩阵而已，有时用它确实快，省略了中间过程。比如你用al命令，明显可以看到，是先移动，然后旋转的，用矩阵就没有中间过程

自贡黄明儒 · 发表于 2013-7-23 13:25:10

操作三步：
第一步，点取对象
第二步，输入线宽
第三步，窗选范围

自贡黄明儒 · 发表于 2013-7-23 13:25:47

本帖最后由自贡黄明儒于 2013-7-23 14:38 编辑

(defun C:w1 (/ CENTER COLOR EN ENTLIST LAYER LEN LI R)
  ;;第一步，获取颜色
  ;;  (princ "\n 点取颜色")
  ;;(setvar "nomutt" 1)
  ;;(setq ss0 (ssget ":S:L" '((0 . "ARC,*LINE,CIRCLE"))))
  ;;(setvar "nomutt" 0)
  ;;(setq en (ssname ss0 0))
  (while (not en) (setq en (car (entsel "\n 点取颜色"))))
  (setq entlist (entget en))
  (if (setq color (cdr (assoc 62 entlist)))
nil
(progn
   (setq layer (cdr (assoc 8 entlist)))
   (setq color (cdr (assoc 62 (tblsearch "layer" layer))))
)
  )
  ;;第二步,预设线宽
  (if (member (setq li (cdr (assoc 0 entlist)))
   (list "ARC" "LINE" "CIRCLE" "LWPOLYLINE")
   )
(progn
   (setq len (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))
   (setq len (/ len 100))
   (cond ((= li "CIRCLE")
   (setq r (* (cdr (assoc 40 entlist)) 2))
   (setq center (cdr (assoc 10 entlist)))
   (command "donut" (- r len) (+ r len) center "")
   (command "_.erase" en "")
   )
   (t
   (command "_.PEDIT" en "W" len "")
   )
   )
   (princ "\n 当前线宽是 ")
   (princ len)
   (initget (+ 1 2 4))
   (setq len (getreal "\n 输入线宽:"))
)
  )
  ;;第三步，处理颜色为指定颜色的对象
  ;;第四步，处理随层随块为指定颜色的对象
  ;;第五步，块就算了
)

ucuc2003 · 发表于 2013-7-24 19:22:49

wowan1314 发表于 2013-7-24 05:14
圆用(command "donut"
其他用(command "pedit"

学习中...还得继续用command！

ucuc2003 · 发表于 2013-7-24 19:23:39

顶起来！！

hao3ren · 发表于 2013-7-24 19:24:07

呵呵，command好理解

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

[讨论] 点取对象，根据颜色加粗所有对象------终于完成

本帖子中包含更多资源

点评

点评

点评

点评

浏览过的版块