找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 3627|回复: 5

[LISP程序]:请看看我的程序,供大家使用

[复制链接]
发表于 2006-1-11 10:43:58 | 显示全部楼层 |阅读模式

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

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

×
站里已有这方面的LISP程序,这是我做的,供大家使用
  一个是Spline 线转 Polyline(网上已有相似的),我采用的方法是将SPLINE线转存成CADR12格式的DXF的文件实现线的转换,然后再调入到绘图区中,并对原始SPLINE线进行备份(存入到名为“WHGF”的图层中)。
  另一个是*Polypline线抽稀函数(俗称“减肥”)。其中抽稀因子可以调节,缺省值为0.08。采用计算斜率算法,计算速度快,效果好(个人看法)。
  这两个函数配合使用,对用SPLINE绘制的等高线进行转换非常有用。
  这些函数是用纯Autolisp编写,可用于R14---R2006各版本。
原码提供,以感谢xdcad朋友们的帮助。
========================================

;(defun Dxfset (n det e) (subst (Cons n det) (assoc n e) e)) ; 改 DXF 组码新参数
;(defun DXF (n e) (cdr (assoc n e)))        ; 取 DXF 组码的数据
;;====================================================================
;; ! =================================================================
;; ! SPL2PL        将 Spline 转换为 Polyline 线
;; ! =================================================================
;; ! Function : 将 Spline 转换为 POLYLINE 线。
;; !                生成新图元,将原 Spline 线保存到新图层中。
;; !                将 Spline 线以二进制形式写入临时的CAD12格式 DXF文件中。
;; !                然后读入 DXF 文件。实现 Spline 到 Polyline 的格式转换。
;; ! Arguments: NONE
;; !               
;; ! 内部调用 : dxfset  重置 DXF 组码值。
;; !                dxf     取 DXF 组码值。
;; !                根据需要选择外部SHELL命令"DEL"(DOS命令)
;; !                 或 DosLib 库文件中的"dos_delete" 删除临时文件
;; !                  和 vl-file-delete  删除临时文件
;; ! Updated  : 2005-12-31
;; !  作   者 : 雾海孤帆(WHGF)
;; ! e-mail   : L27182818@Tom.com
;; ! Web      :
;; ! =================================================================
(defun c:SPL2PL        (/ ss0 I0 N )        ;
  (setvar "CMDECHO" 0)                        ; 使执行过程没有回应
  (prompt "\n == 转换 SPLINE 线为 POLYLINE 线== 11:23 2005-12-31\n")
  (prompt "\n 选择样条线: " )                ; 选择需输出的对象

  (setq N (ssget))
  (if (and N (setq ss0 (ssget "P" '((0 . "SPLINE")))))                ; 从选择集中选择所有的Splin线
    (Progn
      (prompt (strcat "\n 实际 SPLINE线 图元数 " (itoa (sslength ss0)) "\n"))
      (Command "Dxfout" "D:/WHGF.dxf" "Objects" ss0 "" "Version" "R12" "Binary" )
;============ 将 Spline 线图元换层 ===============
      (setq N  (sslength ss0)        i0 0 )                ;        选择对象条数
      (repeat N
        (setq N (entget (ssname ss0 i0))        i0 (+ i0 1) )
        (setq N (dxfSet 8 "WHGF" N)) ;改新参数换层名
        (entmod N)
      )
      (Command "Layer" "OFF" "WHGF" "")        ;关闭层
      (Command "Dxfin" "D:/WHGF.dxf")
      (Command "Shell" "del D:\\WHGF.Dxf")
;;;;;;;;;;;;Use DosLib                (dos_delete "D:\\WHGF.dxf")
;;;;;;;;;;;;For Vlisp                (vl-file-delete "D:/WHGF.dxf")
    )
  )
)        ; SPL2PL
;;====================================================================

;;====================================================================
;; ! =================================================================
;; ! GetVerP        取出 *Polyline 线上的节点坐标
;; ! =================================================================
;; ! Function : 对选定的 *POLYLINE 线,取出 *Polyline 线上的所有节点坐标。
;; !                返回 *POLYLINE 上的节点坐标。
;; ! Arguments:
;; !                ent        : 是非曲直*POLYLINE 的名柄
;; ! 内部调用 : dxfset  重置 DXF 组码值。
;; !                dxf     取 DXF 组码值。
;; ! Updated  : 2006-01-02
;; !  作   者 : 雾海孤帆(WHGF)
;; ! e-mail   : L27182818@Tom.com
;; ! Web      :
;; !  参  照  : www.4d-technologies.com 中的 "PL_plist"
;; ! =================================================================
(defun GetVerP (ename / ent pt SS)
  (Setq    ent  (entget ename)  SS '())
  (cond
    ((= (Dxf 0 ent) "POLYLINE")
        (setq
           ename        (entnext ename)
           ent                (entget  ename)
        )
        (while (=  (Dxf 0  ent) "VERTEX")
          (setq pt (Dxf 70 ent))
          (if (and
                (zerop (logand pt 1))                (zerop (logand pt 2))
                (zerop (logand pt 8))                (/= pt 128)
              )
            (setq
                pt        (Dxf 10 ent)
                SS        (cons (List (car pt) (cadr pt)) SS)
;                I        (+ I 1)
            )
          )
          (setq
                ename        (entnext ename)
                ent        (EntGet  ename)
          )
        )
;        (Setq        SS (reverse SS)                SS (Dxfset 90 I SS) )
    )
        ;========================================       
    ((= (Dxf 0 ent)        "LWPOLYLINE")
          (foreach pt ent
            (if (= (car pt) 10)
              (setq SS (cons (list (cadr pt) (caddr pt) ) SS))
            )
          )
    )
  )
  (reverse SS)
)        ; GetVerP
;;====================================================================

;;====================================================================
;; ! =================================================================
;; ! CXX        抽稀 *Polyline 线
;; ! =================================================================
;; ! Function : 对选定的 *POLYLINE 线按抽稀因子指定的参数进行抽稀,
;; !            并将抽稀后的线替代原始线。(俗语:减肥)。
;; !  注   意 :        此函数在计算过程中,将不考虑3D线中的Z坐标值,因此具有
;; !                3D转2D的作用。
;; ! Arguments: NONE
;; ! 内部调用 : GetVerP 取 *Polyline 线上的节点。
;; !                dxfset  重置 DXF 组码值。
;; !                dxf     取   DXF 组码值。
;; ! 内部函数 : XL 计算两点联线的斜率
;; ! Updated  : 2006-01-04
;; !  作   者 : 雾海孤帆(WHGF)
;; ! e-mail   : L27182818@Tom.com
;; ! Web      :
;; ! =================================================================
;============= 计算斜率函数 ============
  (defun XL (P1 P2 / d1 d2)
    (setq d1 (Abs (- (car P1) (car P2)))   d2 (Abs (- (cadr P1) (cadr P2))))
    (If(> d1 d2)        (/ d2 d1)        (/ d1 d2)        )
  )
;=======================================
(defun c:CXX (/ ent ss ss0 ss1 I K Fan
                K1 K2 pt1 pt2)
  (setvar "CMDECHO" 0)                        ; 使执行过程没有回应
  (prompt    "\n == 抽稀 *POLYLINE 线== 11:23 2006-01-04\n"  )
  (setq Fan (GetDist "\n 给定抽稀因子(0< Fan <1.0) <0.08> ") )
  (If(= Fan Nil) (setq Fan 0.08))
  (prompt    "\n == 选择要抽稀的 *POLYLINE 线"  )
  (setq i (ssget))
  (if (and i (setq ss0 (ssget "P" '((0 . "*POLYLINE")))))                                        ; 从选择集中选择所有的LWPOLYPLINE线
    (Progn
      (setq K2  (sslength ss0)  i 0 )        ;        选择对象条数
      (prompt (strcat "\n 实际图元数 " (itoa K2) "\n"))
      (repeat K2
        (setq
          K   (ssname ss0 i)        i  (+ i 1)
          ent (entget K)
        )
        (prompt (strcat "\r第 " (itoa i ) " 个图元 ")) ; 相当于进度条
;============= 初始线参数 ==============
        (setq SS        (GetVerP K)
            SS1 '(
            (70 . 0)
            (90 . 9)
            (100 . "AcDbPolyline")
            (8 . "WHGF")                ; Layer
            (100 . "AcDbEntity")
            (0 . "LWPOLYLINE")                ; Object type
                )
            K2          (Dxf 8  ent)
            Pt1          (Dxf 62 ent)
        )
        (If (= (Dxf 70 ent) 9)                ; 封闭线
            (setq SS1 (cons (Cons 70  1) SS1))
        )
        (If (= PT1 nil)
            (setq        PT1        0)        ; 颜色值
            (setq        SS1        (cons (Cons '62 PT1)        SS1))
        )
        (setq            SS1                (Dxfset 8  K2 SS1))        ; 层图名
;============= 建立初始环境 ============
        (setq
              Pt1        (nth  0  SS)
              Pt2        (nth  1  SS)
              K2        (XL Pt1 Pt2)
              SS1        (cons (Cons 10 Pt1) SS1)        ; 首节点
              K                2                ; 抽稀后的节点数
              Ks        0
        )
;============ 遍历所有的节点 ===========
        (foreach        Pt1        SS
          (Progn
            (setq
                K1        (XL Pt2 Pt1)
                Ks        (+ (Abs(- K1 K2)) Ks)
            )
;;========= 这里进行抽稀 ===============
            (If (> Ks fan)        ;; <------- Fan 是抽稀因子 值大不光滑
              (setq
                SS1 (Cons (Cons 10 Pt2) SS1) ; 保留该节点
                K  (+ K 1)                Ks  0
              )
            )
            (setq  Pt2        Pt1                K2  K1)  
          )  
        )
        ;============  保留端点 ========
        (setq        SS1        (cons (Cons 10 Pt2) SS1))
;        (setq        K        (+ K 1) )
;=======================================
        ;============  线上点数 ========
        (setq ss1 (dxfset 90 K ss1))
        (setq SS1 (reverse SS1))
        (entmake SS1)
      )
    )
  )  
  (Command "Erase" SS0 "")        ;; <--------- 这里删除原始线
  (setvar "CMDECHO" 1)
)        ; CXX
;;====================================================================

;;====================================================================
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
发表于 2006-1-11 19:53:42 | 显示全部楼层
不错的程序,先行谢过。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2007-12-28 18:25:25 | 显示全部楼层
Lisp确实在版本方面表现比较优越,但功能太有限了,感到很遗憾,要好的话估计也不会搞ARX了.
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2008-1-8 20:29:34 | 显示全部楼层
艾,这么高级的程序,很少用的了
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2014-7-25 16:51:29 | 显示全部楼层
我在cad2010中 输入cxx---回车---选多段线---回车,
然后就【错误】:no function definition: DXF!*取消*
请问大神怎么回事
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2014-7-25 16:55:06 | 显示全部楼层
上面那个粘错了 应该是这个
【错误】:no function definition: GETVERP!*取消*
是不是cad2010不能用,必须是cad2004或2006版本
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-5-29 07:45 , Processed in 0.383679 second(s), 42 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表