连续加粗（绝对原创）

958620832

;;;1.设置了缺省值；
;;; 2.也可以刷宽度；
;;; 3.加粗线段既可点选，也可框选；
;;; 4.可以连续加粗；
;;; 5.按右键、空格键或enter键，即可退出。
(defun gg () ;将圆转化为多义线
  (setq len (sslength ss) i 0)
  (repeat len
    (setq ent (entget (setq en (ssname ss i))))
    (if (= (cdr (assoc 0 ent)) "CIRCLE") (progn
      (setq c (cdr (assoc 10 ent)) r (cdr (assoc 40 ent)))
      (setq p1 (polar c 0 r) p2 (polar c pi r))
      (entdel en)
      (entmake (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 3)(cons 10 p1)(cons 42 1.0)
        (cons 10 p2)(cons 42 1.0)(cons 10 p1)))
      (ssadd (entlast) ss)))
      (setq i (+ i 1))))
(defun c:cc (/ *error*) ;主程序开始
  (defun *error* (msg) ;将描述错误的字符串存入变量msg
    (setvar "osmode" os)
    (princ "错误: ")(princ msg)) ;打印错误信息
  (or kd (setq kd 0)) ;初次打开时，kd为nil，否则，均为前一次的输入。
  (initget 4 "C")
  (princ "\n指定宽度<") (princ kd) (princ ">/[刷宽度(C)]:") ;下一步getint函数的提示语，提示语中含有变量kd。
  (setq kd1 (getint))
  (if (= kd1 "C") (progn
    (setq ent (entget (car (entsel "\n选择参考对象:"))))
    (setq kd1 (cdr (assoc 43 ent)))
    (princ "\n参考宽度:") (princ (fix kd1)) (princ "   <<<"))
    (princ "\n"))
  (if kd1 (setq kd (fix kd1)))
  (princ "选择对象(线、弧、圆或多段线):") ;加粗后对象类型均为"LWPOLYLINE"
  (setq os (getvar "osmode"))
  (setvar "osmode" 0)
  (setq pd t)
  (while pd
    (while (not (member (car (setq gr (grread t 4 2))) '(2 3 11))))
    ;鼠标移动时重复，键盘输入、左键点击或右键点击后退出循环。
    (if (= (car gr) 3)
     (progn
       (setq pt (cadr gr))
       (if (not (setq ss (ssget pt))) (progn
         (setq pt1 (getcorner pt))
         (if (< (car pt1) (car pt)) (setq ss (ssget "c" pt pt1)))
         (if (> (car pt1) (car pt)) (setq ss (ssget "w" pt pt1)))))
         ;从右到左为框选，从左到右为窗选。
        (if ss (progn
          (gg) ;将圆转化为多义线
          (command "pedit" "m" ss "" "w" kd ""))))
     (setq pd nil)))
  (setvar "osmode" os)
  (princ))

emk

支持一下楼主，虽然用不到，源码就要顶一下。回帖一直要输验证码，烦

云中孤鹰

楼主辛苦！

958620832

emk 发表于 2013-10-11 08:23
支持一下楼主，虽然用不到，源码就要顶一下。回帖一直要输验证码，烦

对于autolisp刚刚入门的新手来说，学习方面的价值更大一些，程序中用到了一些比较常用的技巧，可以在其他autolisp程序套用。

zs2002zs

顶原码继续关注…………

vvcd

顶，还是不错哈，谢谢分享

emk

958620832 发表于 2013-10-11 08:46
对于autolisp刚刚入门的新手来说，学习方面的价值更大一些，程序中用到了一些比较常用的技巧，可以在其他 ...

是啊，确实如此，理解下程序结构和函数用法是很不错的，
(or kd (setq kd 0)) 这个写得不错，我还没这样用过，kd存在直接跳过，否则设为0
grread函数我一直没用过
(if (< (car pt1) (car pt)) (setq ss (ssget "c" pt pt1)))
(if (> (car pt1) (car pt)) (setq ss (ssget "w" pt pt1)))
可以改写为：(if (< (car pt1)(car pt))(setq ss (ssget "c" pt pt1))(setq ss (ssget "w" pt pt1)))

emk

是不是考虑排除(= (car pt1) (car pt)) )才这样写的？

vlisp2012

多谢分享了，下来试用一下。