点取对象，根据颜色加粗所有对象------终于完成
本帖最后由 自贡黄明儒 于 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
)
)
)
)
)
**** Hidden Message *****
wowan1314,以上程序中当
(setvar "PEDITACCEPT" 1)时
(command "_.PEDIT" en "Y" "W" len "")这个不加Y
下下来看看。，学习学习 大神牛牛牛牛！ 不错的帖子 圆需要处理成两个半圆弧段的多段线 圆用(command "donut"
其他用(command "pedit"
你是不是已经告别command 了？我喜欢command mccad 发表于 2013-7-20 09:46 static/image/common/back.gif
圆需要处理成两个半圆弧段的多段线
这样一来，块中圆就比较麻烦了。牵涉到删除添加对象,又是矩阵转换。 wowan1314 发表于 2013-7-20 10:14 static/image/common/back.gif
圆用(command "donut"
其他用(command "pedit"
用command程序很简单，也容易理解。
我只不过在练习矩阵而已，有时用它确实快，省略了中间过程。比如你用al命令，明显可以看到，是先移动，然后旋转的，用矩阵就没有中间过程 操作三步：
第一步，点取对象
第二步，输入线宽
第三步，窗选范围 本帖最后由 自贡黄明儒 于 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 输入线宽:"))
)
)
;;第三步，处理颜色为指定颜色的对象
;;第四步，处理随层随块为指定颜色的对象
;;第五步，块就算了
) wowan1314 发表于 2013-7-24 05:14 static/image/common/back.gif
圆用(command "donut"
其他用(command "pedit"
学习中...还得继续用command！ 顶起来！！ 呵呵，command好理解