[LISP程序]加粗曲线

eachy · 发表于 2006-1-9 22:17:16

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

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

×

本程序取自晓东工具箱，改用Lisp完成，但Spline 和 Ellipse 模拟使用了ET函数（该函数包含在哪个文件中未知）

(defun xdl-dxf (elst code)
(cdr (assoc code elst))
)
;|(mapcar '(lambda (x) (load x nil))
'("acetutil.fas"
"acetutil2.fas"
"acetutil3.fas"
"acetutil4.fas"
)
)|;
(DEFUN C:plw_match (/ tf e0 wid ss cr rad d1 d2 ent
xform i ll e tp cr r oldwid
sc d1 d2 tf tol e40 i ssl e el
olderr myerr ucstf
)
(defun myerr (msg)
(if (/= msg "CANCEL")
(princ "\n*Cancel*")
)
(setvar "plinewid" oldwid)
(setvar "osmode" oldos)
(command ".undo" "end")
(if ucstf
(command ".ucs" "p")
)
(princ)
)
(setq oldwid (getvar "plinewid"))
(if (or (setq e0 (entsel "\n请选择匹配源(回车输入加粗方式): "))
(progn
(initget "1 2")
(setq tf (getkword "\n请选择方式[1:加粗 2:变比]<1>:"))
)
)
(progn
(setq oldos (getvar "osmode")
olderr *error*
*error* myerr
)
(cond
((= (type e0) 'LIST)
(setq el (entget (car e0)))
(progn
(if (wcmatch (xdl-dxf el 0) "*POLYLINE")
(setq wid (xdl-dxf el 40))
(setq wid 0)
)
)
)
(T
(if (not tf)
(setq tf "1")
)
(if (not #xd_width)
(setq #xd_width 50)
)
(if (not #xd_scale)
(setq #xd_scale 1.0)
)
(if (= tf "1")
(progn
(initget 4)
(if (setq wid (getreal (strcat "\n请输入加粗后的的宽度<"
(rtos #xd_width 2 0)
">:"
)
)
)
(setq #xd_width wid)
)
)
(progn
(initget 6)
(setq sc (getreal (strcat "\n请输入比例系数<"
(rtos #xd_scale
2
2
)
">:"
)
)
)
(if (not sc)
(setq sc #xd_scale)
(setq #xd_scale sc)
)
)
)
)
)
;;(xdrx_begin)
;;(xdrx_ucson)
(command ".undo" "begin")
(if (/= (getvar "worlducs") 0)
(progn
(command ".ucs" "W")
(setq ucstf t)
)
)
(if
(if (= (type e0) 'LIST)
(progn
(princ "\n线宽= ")
(princ wid)
(princ
"\n选择需要匹配的直线、圆、弧、椭圆、spline、多义线<退出>..."
)
(setq #xd_width wid)
(setq ss (ssget '((0 . "*line,circle,arc,ellipse,spline"))))
)
(progn
(if (= tf "1")
(progn
(princ
"\n请选取要加粗的直线、圆、弧、椭圆、spline、多义线<退出>..."
)
(setq ss
(ssget '((0 . "*line,circle,arc,ellipse,spline")))
)
)
(progn
(princ "\n请选取要宽度变比的多义线<退出>...")
(setq ss (ssget '((0 . "*polyline"))))
)
)
)
)
(progn
;;(xdrx_setsstodb ss 0)
(setq ssl (sslength ss)
i -1
)
(if (or
(= tf "1")
e0
)
(progn
;;(while (setq e (xdrx_getentdata 0))
(repeat ssl
(setq e (ssname ss (setq i (1+ i)))
el (entget e)
)
(setq tp (xdl-dxf el 0))
(cond
((= tp "CIRCLE")
(setq cr (xdl-dxf el 10)
r (xdl-dxf el 40)
)
(setq d1 (+ (* 2 r) #xd_width)
d2 (- (* 2 r) #xd_width)
)
;;(setq xForm (xdrx_matrix_wcs2ucs))
;;(setq cr (xdrx_point_transform cr xForm))
(command ".donut" d1 d2 cr "")
(entdel e)
)
((or
(= tp "SPLINE")
(= tp "ELLIPSE")
)
(setq tol (getvar "viewsize")
tol (/ tol 400.0)
)
(setvar "plinewid" #xd_width)
(setvar "osmode" 0)
(setq el (acet-geom-object-point-list e h)) ;_此处使用了ET函数
(apply
'command
(cons ".pline" el)
)
(command "")
(entdel e)
)
((wcmatch tp "*POLYLINE")
(command ".pedit" e "w" #xd_width "")
)
((or
(= tp "ARC")
(= tp "LINE")
)
(command ".pedit" e "y" "w" #xd_width "")
)
)
)
)
(progn
(setq ssl (sslength ss)
i -1
)
;;(while (setq e (xdrx_getentdata 0))
(repeat ssl
(setq e (ssname ss (setq i (1+ i)))
el (entget e)
)
(setq e40 (xdl-dxf el 40))
(command ".pedit" e "w" (* e40 sc) "")
)
)
)
)
)
;;(xdrx_ucsoff)
;;(xdrx_end)
(command ".undo" "end")
(if ucstf
(command ".ucs" "p")
)
(setq *error* olderr)
(setvar "osmode" oldos)
)
)
(setvar "plinewid" oldwid)
(princ)
)

(defun xdl-dxf (elst code) 
  (cdr (assoc code elst)) 
) 
 ;|(mapcar        '(lambda (x) (load x nil)) 
        '("acetutil.fas" 
          "acetutil2.fas" 
          "acetutil3.fas" 
          "acetutil4.fas" 
        ) 
)|; 
(DEFUN C:plw_match (/         tf   e0   wid        ss   cr          rad  d1   d2         ent 
                    xform     i           ll        e    tp          cr   r    oldwid 
                    sc         d1   d2   tf        tol  e40  i    ssl  e         el 
                    olderr    myerr        ucstf 
                   ) 
  (defun myerr (msg) 
    (if        (/= msg "CANCEL") 
      (princ "\n*Cancel*") 
    ) 
    (setvar "plinewid" oldwid) 
    (setvar "osmode" oldos) 
    (command ".undo" "end") 
    (if        ucstf 
      (command ".ucs" "p") 
    ) 
    (princ) 
  ) 
  (setq oldwid (getvar "plinewid")) 
  (if (or (setq e0 (entsel "\n请选择匹配源(回车输入加粗方式): ")) 
          (progn 
            (initget "1 2") 
            (setq tf (getkword "\n请选择方式[1:加粗 2:变比]<1>:")) 
          ) 
      ) 
    (progn 
      (setq oldos   (getvar "osmode") 
            olderr  *error* 
            *error* myerr 
      ) 
      (cond 
        ((= (type e0) 'LIST) 
         (setq el (entget (car e0))) 
         (progn 
           (if (wcmatch (xdl-dxf el 0) "*POLYLINE") 
             (setq wid (xdl-dxf el 40)) 
             (setq wid 0) 
           ) 
         ) 
        ) 
        (T 
         (if (not tf) 
           (setq tf "1") 
         ) 
         (if (not #xd_width) 
           (setq #xd_width 50) 
         ) 
         (if (not #xd_scale) 
           (setq #xd_scale 1.0) 
         ) 
         (if (= tf "1") 
           (progn 
             (initget 4) 
             (if (setq wid (getreal (strcat "\n请输入加粗后的的宽度<" 
                                            (rtos #xd_width 2 0) 
                                            ">:" 
                                    ) 
                           ) 
                 ) 
               (setq #xd_width wid) 
             ) 
           ) 
           (progn 
             (initget 6) 
             (setq sc (getreal (strcat "\n请输入比例系数<" 
                                       (rtos #xd_scale 
                                             2 
                                             2 
                                       ) 
                                       ">:" 
                               ) 
                      ) 
             ) 
             (if (not sc) 
               (setq sc #xd_scale) 
               (setq #xd_scale sc) 
             ) 
           ) 
         ) 
        ) 
      ) 
      ;;(xdrx_begin) 
      ;;(xdrx_ucson) 
      (command ".undo" "begin") 
      (if (/= (getvar "worlducs") 0) 
        (progn 
          (command ".ucs" "W") 
          (setq ucstf t) 
        ) 
      ) 
      (if 
        (if (= (type e0) 'LIST) 
          (progn 
            (princ "\n线宽= ") 
            (princ wid) 
            (princ 
              "\n选择需要匹配的直线、圆、弧、椭圆、spline、多义线<退出>..." 
            ) 
            (setq #xd_width wid) 
            (setq ss (ssget '((0 . "*line,circle,arc,ellipse,spline")))) 
          ) 
          (progn 
            (if        (= tf "1") 
              (progn 
                (princ 
                  "\n请选取要加粗的直线、圆、弧、椭圆、spline、多义线<退出>..." 
                ) 
                (setq ss 
                       (ssget '((0 . "*line,circle,arc,ellipse,spline"))) 
                ) 
              ) 
              (progn 
                (princ "\n请选取要宽度变比的多义线<退出>...") 
                (setq ss (ssget '((0 . "*polyline")))) 
              ) 
            ) 
          ) 
        ) 
         (progn 
           ;;(xdrx_setsstodb ss 0) 
           (setq ssl (sslength ss) 
                 i   -1 
           ) 
           (if (or 
                 (= tf "1") 
                 e0 
               ) 
             (progn 
               ;;(while (setq e (xdrx_getentdata 0)) 
               (repeat ssl 
                 (setq e  (ssname ss (setq i (1+ i))) 
                       el (entget e) 
                 ) 
                 (setq tp (xdl-dxf el 0)) 
                 (cond 
                   ((= tp "CIRCLE") 
                    (setq cr (xdl-dxf el 10) 
                          r  (xdl-dxf el 40) 
                    ) 
                    (setq d1 (+ (* 2 r) #xd_width) 
                          d2 (- (* 2 r) #xd_width) 
                    ) 
                    ;;(setq xForm (xdrx_matrix_wcs2ucs)) 
                    ;;(setq cr (xdrx_point_transform cr xForm)) 
                    (command ".donut" d1 d2 cr "") 
                    (entdel e) 
                   ) 
                   ((or 
                      (= tp "SPLINE") 
                      (= tp "ELLIPSE") 
                    ) 
                    (setq tol (getvar "viewsize") 
                          tol (/ tol 400.0) 
                    ) 
                    (setvar "plinewid" #xd_width) 
                    (setvar "osmode" 0) 
                    (setq el (acet-geom-object-point-list e h)) ;_此处使用了ET函数 
                    (apply 
                      'command 
                      (cons ".pline" el) 
                    ) 
                    (command "") 
                    (entdel e) 
                   ) 
                   ((wcmatch tp "*POLYLINE") 
                    (command ".pedit" e "w" #xd_width "") 
                   ) 
                   ((or 
                      (= tp "ARC") 
                      (= tp "LINE") 
                    ) 
                    (command ".pedit" e "y" "w" #xd_width "") 
                   ) 
                 ) 
               ) 
             ) 
             (progn 
               (setq ssl (sslength ss) 
                     i         -1 
               ) 
               ;;(while (setq e (xdrx_getentdata 0)) 
               (repeat ssl 
                 (setq e  (ssname ss (setq i (1+ i))) 
                       el (entget e) 
                 ) 
                 (setq e40 (xdl-dxf el 40)) 
                 (command ".pedit" e "w" (* e40 sc) "") 
               ) 
             ) 
           ) 
         ) 
      ) 
      ;;(xdrx_ucsoff) 
      ;;(xdrx_end) 
      (command ".undo" "end") 
      (if ucstf 
        (command ".ucs" "p") 
      ) 
      (setq *error* olderr) 
      (setvar "osmode" oldos) 
    ) 
  ) 
  (setvar "plinewid" oldwid) 
  (princ) 
)

liuyj · 发表于 2006-1-10 13:55:23

这一部分要调一下，要不回车不相应。

(or (setq e0 (entsel "\n请选择匹配源(回车输入加粗方式): "))
(progn
(initget "1 2")
(setq tf (getkword "\n请选择方式[1:加粗 2:变比]<1>:"))
(if (not tf)
(setq tf "1")
tf
)
)
)

同时把后面的这句话删掉。

(if (not tf)
(setq tf "1")
)

小菜 · 发表于 2006-1-12 12:34:54

这个程序对某些多义线不能进行处理，返回错误是：
“The object is not parallel to the UCS.”
下面贴一个我写的函数，可以处理这类多义线（没有考虑SPLINE）
[PHP]
;改变ent的宽度为wid 测试：(chgwd (car(entsel)) (getreal))
(defun chgwd ( ent wid / ent1 entn ent210 cen rad lay8 d1 d2 )
(setq ent1 (entget ent) entn (cdr (assoc 0 ent1)) ent210 (cdr (assoc 210 ent1)))
(if (member entn '("VERTEX" "POLYLINE" "LWPOLYLINE" "LINE" "ARC" "CIRCLE")) (progn
(if (not (equal ent210 '(0.0 0.0 1.0)))  ;;实体与当前UCS不平行时，将当前UCS设为实体UCS
   (progn
   (vl-cmdf "ucs" "save" "ch_ucs1") (if (= (getvar "cmdactive") 1) (command "y")) ;;改变UCS前先存
         (if (>= (atof (getvar "ACADVER")) 15.0) (command "ucs" "n" "ob" ent) (command "ucs" "ob" ent))
)); end of if;因为线与当前UCS不平行时，PEDIT命令不能修改线宽
  (cond
((or(= entn "VERTEX")(= entn "POLYLINE")(= entn "LWPOLYLINE"))(command "pedit" ent "w" wid ""))
((or (= entn "LINE") (= entn "ARC")) (command "pedit" ent "y" "w" wid ""))
((= entn "CIRCLE") (progn
   (setq cen (cdr (assoc 10 (entget ent)))
      cen (trans cen ent 1)
         rad (cdr (assoc 40 (entget ent)))
      lay8 (cdr (assoc 8 (entget ent)))
         d1 (- (* 2 rad) wid)
         d2 (+ (* 2 rad) wid)
      )
   (command "donut" d1 d2 cen "") ;;;erase circle ,create donut
   ;;(subdxf (entlast) 8 lay8)  ;;改变至圆所在的图层
   (entdel ent)
   ))
  )  ;;;cond
  (if (and ent210 (not (equal ent210 '(0.0 0.0 1.0)))) (vl-cmdf "ucs" "restore" "ch_ucs1"))  ;恢复UCS
));;end of if
)  ;end of defun
[/PHP]

梦断江南 · 发表于 2006-5-13 11:10:44

ea, ucs下圆圈会跑掉...

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

[LISP程序]加粗曲线

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

相关帖子

浏览过的版块