958620832 发表于 2013-10-11 07:31:38

连续加粗（绝对原创）

;;;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 发表于 2013-10-11 08:23:45

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

云中孤鹰 发表于 2013-10-11 08:43:28

楼主辛苦！

958620832 发表于 2013-10-11 08:46:16

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

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

zs2002zs 发表于 2013-10-11 09:44:18

顶原码继续关注…………

vvcd 发表于 2013-10-11 10:30:25

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

emk 发表于 2013-10-11 11:44:10

958620832 发表于 2013-10-11 08:46 static/image/common/back.gif
对于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 发表于 2013-10-11 11:47:28

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

峰峰兒 发表于 2013-10-11 12:14:46

vlisp2012 发表于 2013-10-11 13:07:38

多谢分享了，下来试用一下。
页: [1] 2
查看完整版本: 连续加粗（绝对原创）