[测试]：铁路线－程序

xyp1964 · 发表于 2005-9-22 22:39:41

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

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

×

用户可修改层颜色

;;;
(load "xyp_lib")
;|加载通用函数(可在签名栏直接下载)
如果已经下载xyp_lib并放到搜索路径下可以不再下载!
利用以下任何一种方式即可加载和运行通用函数内的所有子程序：
1.在acad.lsp中增加(load"xyp_lib")
2.在每个程序内增加(load"xyp_lib")
3.在command下，输入(load"xyp_lib")
4.在菜单.mnl中增加(load"xyp_lib")
5.将xyp_lib.vlx文件直接拽到cad屏幕
[COLOR=red] ★通用函数下载地址：[/COLOR]
[url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url]
[url]http://www.mjtd.com/bbs/dispbbs.asp?boardID=3&ID=37554&page=1[/url]|;
;;;铁路线
;;;------------------------------------------------------------------------
(defun c:tlx ()
(cmdla0)
(setvar "osmode" 0)
(SETQ TX1 (UKWORD 7 "1 2" "\n填充方式 : 1-SOLID/2-宽拟合线" TX1)
no1 (UREAL 7 "" "\n铁路线宽度" no1)
wide (/ no1 2.0)
no2 (UREAL 7 "" "\n黑白段长度" no2)
n -1
)
(princ "\选择SPLINE线 : ")
(setq ss (ssget '((0 . "SPLINE"))))
(cond ((= tx1 "1") (tieluxian1))
((= tx1 "2") (tieluxian2))
)
(cmdla1)
)
;;;SOLID------------------------------------------------------------------------
(defun tieluxian1()
(while (setq s1 (ssname ss (setq n (1+ n))))
(setq pts (vlax-curve-getStartPoint s1)
pt1 (PT-FAXIAN s1 pts wide)
pt2 (PT-FAXIAN s1 pts (* wide -1.0))
)
(command "offset" wide s1 pt1 s1 pt2 "")
(setq ptlst1 (CURVE-DIV-PTLST s1 no2)
ptlst2 (CURVE-DIV-PTLST s1 (/ no2 2.0))
)
(mkla "枕木" 6)
(while (setq pt (car ptlst1))
(setq ptlst1 (cdr ptlst1)
pt1 (PT-FAXIAN s1 pt (* wide 1.25))
pt2 (PT-FAXIAN s1 pt (* wide -1.25))
)
(command "line" pt1 pt2 "")
)
(entdel s1)
(mkla "填充" 1)
(while (setq pt0 (car ptlst2))
(if (and (setq ptlst2 (cdr ptlst2))
(setq pt (car ptlst2))
)
(progn ;;确保填充范围在显示区内
(command "zoom"
"w"
(polar pt (* pi 1.25) (* no2 0.75))
(polar pt (* pi 0.25) (* no2 0.75))
)
(working)
(command "_bhatch" "p" "solid" pt "")
(setq ptlst2 (cdr ptlst2))
(if (and (setq ptlst2 (cdr ptlst2))
(setq pt (car ptlst2))
)
(setq ptlst2 (cdr ptlst2))
)
)
)
)
)
(command "zoom" "e")
)
;;;宽拟合线-----------------------------------------------------------
(defun tieluxian2 ()
(while (setq s1 (ssname ss (setq n (1+ n))))
(setq pts (vlax-curve-getStartPoint s1)
pt1 (PT-FAXIAN s1 pts wide)
pt2 (PT-FAXIAN s1 pts (* wide -1.0))
ptlst1 (CURVE-DIV-PTLST s1 no2)
ptlst2 (CURVE-DIV-PTLST s1 (/ no2 2.0))
)
(command "offset" wide s1 pt1 s1 pt2 "")
(mkla "枕木" 6)
(while (setq pt (car ptlst1))
(setq ptlst1 (cdr ptlst1)
pt1 (PT-FAXIAN s1 pt (* wide 1.3))
pt2 (PT-FAXIAN s1 pt (* wide -1.3))
)
(command "line" pt1 pt2 "")
)
(entdel s1)
(mkla "填充" 1)
(while (setq pt0 (car ptlst2))
(setq ptnum (length ptlst2))
(if (<= ptnum 3)
(if (= ptnum 2)
(progn
(setq pt1 (cadr ptlst2)
pt2 (_midp pt0 pt1)
pt2 (osnap pt2 "near")
ptlst2 nil
)
(command "pline" pt0 pt1 pt2 "")
(command "pedit" (entlast) "s" "w" no1 "")
(working)
)
(progn
(setq pt1 (cadr ptlst2)
pt2 (caddr ptlst2)
ptlst2 nil
)
(command "pline" pt0 pt1 pt2 "")
(command "pedit" (entlast) "s" "w" no1 "")
(working)
)
)
(progn
(if (and (setq ptlst2 (cdr ptlst2))
(setq pt1 (car ptlst2))
(setq ptlst2 (cdr ptlst2))
(setq pt2 (car ptlst2))
(setq ptlst2 (cdr ptlst2))
)
(progn
(command "pline" pt0 pt1 pt2 "")
(command "pedit" (entlast) "s" "w" no1 "")
(setq ptlst2 (cdr ptlst2))
(working)
)
)
)
)
)
)
)
(defun working ()
(princ ".")
(princ)
)
;;;
(pxyp "tlx (铁路线)")[FONT=courier new][/FONT]

;;; 
(load "xyp_lib") 
;|加载通用函数(可在签名栏直接下载) 
如果已经下载xyp_lib并放到搜索路径下可以不再下载! 
利用以下任何一种方式即可加载和运行通用函数内的所有子程序： 
1.在acad.lsp中增加(load"xyp_lib") 
2.在每个程序内增加(load"xyp_lib") 
3.在command下，输入(load"xyp_lib") 
4.在菜单.mnl中增加(load"xyp_lib") 
5.将xyp_lib.vlx文件直接拽到cad屏幕 
[COLOR=red] ★通用函数下载地址：[/COLOR] 
[url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url] 
[url]http://www.mjtd.com/bbs/dispbbs.asp?boardID=3&ID=37554&page=1[/url]|; 
 
;;;铁路线 
;;;------------------------------------------------------------------------ 
(defun c:tlx () 
  (cmdla0) 
  (setvar "osmode" 0) 
  (SETQ        TX1  (UKWORD 7 "1 2" "\n填充方式 : 1-SOLID/2-宽拟合线" TX1) 
        no1  (UREAL 7 "" "\n铁路线宽度" no1) 
        wide (/ no1 2.0) 
        no2  (UREAL 7 "" "\n黑白段长度" no2) 
        n    -1 
  ) 
  (princ "\选择SPLINE线 : ") 
  (setq ss (ssget '((0 . "SPLINE")))) 
  (cond        ((= tx1 "1") (tieluxian1)) 
        ((= tx1 "2") (tieluxian2)) 
  ) 
  (cmdla1) 
) 
;;;SOLID------------------------------------------------------------------------ 
(defun tieluxian1() 
  (while (setq s1 (ssname ss (setq n (1+ n)))) 
    (setq pts (vlax-curve-getStartPoint s1) 
          pt1 (PT-FAXIAN s1 pts wide) 
          pt2 (PT-FAXIAN s1 pts (* wide -1.0)) 
    ) 
    (command "offset" wide s1 pt1 s1 pt2 "") 
    (setq ptlst1 (CURVE-DIV-PTLST s1 no2) 
          ptlst2 (CURVE-DIV-PTLST s1 (/ no2 2.0)) 
    ) 
    (mkla "枕木" 6) 
    (while (setq pt (car ptlst1)) 
      (setq ptlst1 (cdr ptlst1) 
            pt1           (PT-FAXIAN s1 pt (* wide 1.25)) 
            pt2           (PT-FAXIAN s1 pt (* wide -1.25)) 
      ) 
      (command "line" pt1 pt2 "") 
    ) 
    (entdel s1) 
    (mkla "填充" 1) 
    (while (setq pt0 (car ptlst2)) 
      (if (and (setq ptlst2 (cdr ptlst2)) 
               (setq pt (car ptlst2)) 
          ) 
        (progn ;;确保填充范围在显示区内 
               (command        "zoom" 
                        "w" 
                        (polar pt (* pi 1.25) (* no2 0.75)) 
                        (polar pt (* pi 0.25) (* no2 0.75)) 
               ) 
               (working) 
               (command "_bhatch" "p" "solid" pt "") 
               (setq ptlst2 (cdr ptlst2)) 
               (if (and        (setq ptlst2 (cdr ptlst2)) 
                        (setq pt (car ptlst2)) 
                   ) 
                 (setq ptlst2 (cdr ptlst2)) 
               ) 
        ) 
      ) 
    ) 
  ) 
  (command "zoom" "e") 
) 
;;;宽拟合线----------------------------------------------------------- 
(defun tieluxian2 () 
  (while (setq s1 (ssname ss (setq n (1+ n)))) 
    (setq pts         (vlax-curve-getStartPoint s1) 
          pt1         (PT-FAXIAN s1 pts wide) 
          pt2         (PT-FAXIAN s1 pts (* wide -1.0)) 
          ptlst1 (CURVE-DIV-PTLST s1 no2) 
          ptlst2 (CURVE-DIV-PTLST s1 (/ no2 2.0)) 
    ) 
    (command "offset" wide s1 pt1 s1 pt2 "") 
    (mkla "枕木" 6) 
    (while (setq pt (car ptlst1)) 
      (setq ptlst1 (cdr ptlst1) 
            pt1           (PT-FAXIAN s1 pt (* wide 1.3)) 
            pt2           (PT-FAXIAN s1 pt (* wide -1.3)) 
      ) 
      (command "line" pt1 pt2 "") 
    ) 
    (entdel s1) 
    (mkla "填充" 1) 
    (while (setq pt0 (car ptlst2)) 
      (setq ptnum (length ptlst2)) 
      (if (<= ptnum 3) 
        (if (= ptnum 2) 
          (progn 
            (setq pt1         (cadr ptlst2) 
                  pt2         (_midp pt0 pt1) 
                  pt2         (osnap pt2 "near") 
                  ptlst2 nil 
            ) 
            (command "pline" pt0 pt1 pt2 "") 
            (command "pedit" (entlast) "s" "w" no1 "") 
            (working) 
          ) 
          (progn 
            (setq pt1         (cadr ptlst2) 
                  pt2         (caddr ptlst2) 
                  ptlst2 nil 
            ) 
            (command "pline" pt0 pt1 pt2 "") 
            (command "pedit" (entlast) "s" "w" no1 "") 
            (working) 
          ) 
        ) 
        (progn 
          (if (and (setq ptlst2 (cdr ptlst2)) 
                   (setq pt1 (car ptlst2)) 
                   (setq ptlst2 (cdr ptlst2)) 
                   (setq pt2 (car ptlst2)) 
                   (setq ptlst2 (cdr ptlst2)) 
              ) 
            (progn 
              (command "pline" pt0 pt1 pt2 "") 
              (command "pedit" (entlast) "s" "w" no1 "") 
              (setq ptlst2 (cdr ptlst2)) 
              (working) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
) 
(defun working () 
  (princ ".") 
  (princ) 
) 
;;; 
(pxyp "tlx  (铁路线)")[FONT=courier new][/FONT]

20050923版－相间
20050924版－填充方式可选：1-SOLID/2-宽拟合线
20051020版－修改BUG

xyp1964 · 发表于 2005-9-22 22:39:57

效果：
HATCH及POLYLINE

xyp1964 · 发表于 2005-9-23 11:57:27

用solid填充，有时会出错，改为宽拟合线可能更好！
用宽拟合线可以不考虑所画位置是否在显示区内，填充不会遗漏但不精确。

西北野狼 · 发表于 2005-10-19 13:57:03

使用您编制的小程序,效果不错,谢谢了!

有点小烦 · 发表于 2005-10-20 11:24:37

请告诉我该怎么用啊？

陈西 · 发表于 2005-10-20 21:41:17

在2006是否能用?为什么有时行,在有的图中就不行?请指教!谢谢!

li_03319 · 发表于 2006-1-11 14:15:13

怀念我的堕落街，思念我的师大mm，
在八年抗战四级的路上慢慢遗忘，回首却发现已在少林市敲起了木鱼！————枫叶是否又已红遍！！！
遥远的铃声轻颤, 在天边渺茫的响起,
再沉落……
那是奈何桥上, 亡魂不舍昼夜的歌声……
奈何桥上,孟婆悠悠端起汤碗…
喝一碗孟婆汤忘了前世的忧伤
喝一碗孟婆汤来生跟你再续缘
无论谁,都要走奈何桥,喝孟婆汤
所以,今生今世,该珍惜的,就去珍惜!

jeepanda · 发表于 2006-8-8 11:43:41

我是搞规划的，原来用CAD不多，现在开始用了，向大家请教

TLHMQH · 发表于 2006-11-18 17:57:01

我用的是2004版的，加载后运行出现下面提示：
命令: _appload 已成功加载铁路线.lsp。
已成功加载铁路线.lsp。
命令: ; 错误: no function definition: PXYP
命令: ; 错误: no function definition: PXYP
命令:
命令: TLX
; 错误: no function definition: CMDLA0
不知什么原因，怎样解决？
E-mail：TLHMQH@163.COM

无影人 · 发表于 2006-11-19 11:37:30

楼上的你加了通用函数没?

xyp1964 · 发表于 2006-11-19 17:15:38

编译程序：

zhangcf0323 · 发表于 2006-12-15 17:35:40

不错谢谢了

awpcn · 发表于 2009-3-12 10:00:02

为什么不让下载？

yangchunfeng · 发表于 2009-8-21 20:14:38

谁给我发一份
yangchunfeng7008@126.com

生如夏花8888968 · 发表于 2009-9-19 16:07:12

爱心能用钱还来么？
有好心人能不能给我发一份，本人将无限感激，在此先谢谢了。aqi7222785@163.com

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

[测试]：铁路线－程序

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

相关帖子

铁路线

浏览过的版块