[分享]：一个画数据线的程序

wowoaicad · 发表于 2003-1-21 11:16:10

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

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

×

这是郑立楷先生的作品，对于形是X Y的带空格文本的数据自动画出，还有填充功能！还能察看程序运行时间。在cad2002下运行很爽。

;; PLTXT.LSP
;; 版权所有 (C) 2002-2003 郑立楷
;;
;; 本软件免费可供进行任何用途需求的拷贝、修改及发行, 但请遵循下述原则:
;;
;; 1) 上列的版权通告必须出现在每一份拷贝里。
;; 2) 相关的说明文档也必须载有版权通告及本项许可通告。
;;
;; 本软件仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。
;;
;; [url]http://www.mjtd.com[/url] [url]http://www.mccad.net[/url]
;;
;; e-mail:mccad@mjtd.com
;;
(defun c:pltxt (/ oldcmd oldblip oldsnap fle fn pt)
(vl-load-com)
(setq oldcmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq oldblip (getvar "blipmode"))
(setvar "blipmode" 0)
(setq oldsnap (getvar "osmode"))
(setvar "osmode" 0)
(setq fle (findfile "txt1.txt"))
(setq acadObject (vlax-get-acad-object))
(setq acadDocument (vla-get-ActiveDocument acadObject))
(setq mSpace (vla-get-ModelSpace acadDocument))
(setq blocks (vla-get-blocks acadDocument))
(if (not fle)
(setq fle (getfiled "请选择数据文件" "txt1" "txt;dat;*" 8))
)
(if fle
(progn
(initget "1 2 3 4")
(setq ctype
(getkword
"\n请选择数据点填充方式[无填充(1)/全填充(2)/半填充(3)/对角填充(4)]<无填充>:"
)
)
(setq stime(getvar"date"))
(if (not ctype)
(setq ctype "1")
)
(setq fn (open fle "r"))
(read-line fn)
(setq pt1 (read-line fn))
(setq pnt1 (read (strcat "(" pt1 ")")))
(setq blkname (makeblk 0.2 ctype blocks))
(vla-insertblock
mspace
(vlax-3d-point pnt1)
blkname
1
1
1
0
)
(setq pnt0 pnt1)
(while (setq pt2 (read-line fn))
(setq pnt2 (read (strcat "(" pt2 ")"))
pnt1 (drawline pnt1 pnt2 0.2 mSpace)
)
(vla-insertblock mspace (vlax-3d-point pnt1) blkname 1 1 1 0)
)
(close fn)
(grtext)
(setq etime(getvar"date"))
(princ "\n程序共耗用时间：")
(princ (* 86400.0 (- (- etime stime) (fix (- etime stime)))))
(princ "秒")
(command "zoom" "e")
)
(princ "\n未选择数据文件，退出")
)
(setvar "cmdecho" oldcmd)
(setvar "blipmode" oldblip)
(setvar "osmode" oldsnap)
(princ)
)
(defun drawline (pnt1 pnt2 r mSpace / a1 a2 p1 p2)
(setq a1 (angle pnt1 pnt2)
a2 (angle pnt2 pnt1)
p1 (polar pnt1 a1 r)
p2 (polar pnt2 a2 r)
)
(vla-addLine mSpace (vlax-3d-point p1) (vlax-3d-point p2))
pnt2
)
(defun ax:2Point (pt1 pt2)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 3))
(list (car pt1) (cadr pt1) (car pt2) (cadr pt2))
)
)
)
(defun makeblk (r CType blocks / pt1 pt2 pt3 pt4 pl1 pl2 inspnt blkobj basecircle blkname)
(setq inspnt (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 2))
'(0 0 0)
)
)
)
(setq blkobj (vla-add blocks inspnt "*U"))
(setq basecircle (vla-addCircle blkobj inspnt r))
(cond
((= CType "2")
(setq pt1 (polar '(0 0) 0 (/ r 2))
pt2 (polar '(0 0) pi (/ r 2))
)
(setq pl1 (vla-AddLightweightPolyline blkobj (ax:2Point pt1 pt2))
pl2 (vla-AddLightweightPolyline blkobj (ax:2Point pt2 pt1))
)
(vla-SetBulge pl1 0 1)
(vla-SetBulge pl2 0 1)
(vla-SetWidth pl1 0 r r)
(vla-SetWidth pl2 0 r r)
)
((= CType "3")
(setq pt1 (polar '(0 0) 0 (/ r 2))
pt2 (polar '(0 0) pi (/ r 2))
)
(setq pl1 (vla-AddLightweightPolyline blkobj (ax:2Point pt1 pt2))
)
(vla-SetBulge pl1 0 1)
(vla-SetWidth pl1 0 r r)
)
((= CType "4")
(setq pt1 (polar '(0 0) 0 (/ r 2))
pt2 (polar '(0 0) (/ pi 2) (/ r 2))
pt3 (polar '(0 0) pi (/ r 2))
pt4 (polar '(0 0) (+ pi (/ pi 2)) (/ r 2))
)
(setq pl1 (vla-AddLightweightPolyline blkobj (ax:2Point pt1 pt2))
pl2 (vla-AddLightweightPolyline blkobj (ax:2Point pt3 pt4))
)
(vla-SetBulge pl1 0 0.4142)
(vla-SetBulge pl2 0 0.4142)
(vla-SetWidth pl1 0 r r)
(vla-SetWidth pl2 0 r r)
)
)
(setq blkname (vla-get-name blkobj))
)

;; PLTXT.LSP 
;; 版权所有 (C) 2002-2003  郑立楷 
;; 
;;   本软件免费可供进行任何用途需求的拷贝、修改及发行, 但请遵循下述原则: 
;; 
;;   1)  上列的版权通告必须出现在每一份拷贝里。 
;;   2)  相关的说明文档也必须载有版权通告及本项许可通告。 
;; 
;;   本软件仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊 
;;   用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。 
;; 
;;   [url]http://www.mjtd.com[/url]   [url]http://www.mccad.net[/url] 
;; 
;;   e-mail:mccad@mjtd.com 
;; 
(defun c:pltxt (/ oldcmd oldblip oldsnap fle fn pt) 
  (vl-load-com) 
  (setq oldcmd (getvar "cmdecho")) 
  (setvar "cmdecho" 0) 
  (setq oldblip (getvar "blipmode")) 
  (setvar "blipmode" 0) 
  (setq oldsnap (getvar "osmode")) 
  (setvar "osmode" 0) 
  (setq fle (findfile "txt1.txt")) 
  (setq acadObject (vlax-get-acad-object)) 
  (setq acadDocument (vla-get-ActiveDocument acadObject)) 
  (setq mSpace (vla-get-ModelSpace acadDocument)) 
  (setq blocks (vla-get-blocks acadDocument)) 
 
  (if (not fle) 
    (setq fle (getfiled "请选择数据文件" "txt1" "txt;dat;*" 8)) 
  ) 
  (if fle 
    (progn 
      (initget "1 2 3 4") 
      (setq ctype 
             (getkword 
               "\n请选择数据点填充方式[无填充(1)/全填充(2)/半填充(3)/对角填充(4)]<无填充>:" 
             ) 
      ) 
      (setq stime(getvar"date")) 
      (if (not ctype) 
        (setq ctype "1") 
      ) 
      (setq fn (open fle "r")) 
      (read-line fn) 
      (setq pt1 (read-line fn)) 
      (setq pnt1 (read (strcat "(" pt1 ")"))) 
      (setq blkname (makeblk 0.2 ctype blocks)) 
      (vla-insertblock 
        mspace 
        (vlax-3d-point pnt1) 
        blkname 
        1 
        1 
        1 
        0 
      ) 
      (setq pnt0 pnt1) 
      (while (setq pt2 (read-line fn)) 
        (setq pnt2 (read (strcat "(" pt2 ")")) 
              pnt1 (drawline pnt1 pnt2 0.2 mSpace) 
        ) 
        (vla-insertblock mspace (vlax-3d-point pnt1) blkname 1 1 1 0) 
      ) 
      (close fn) 
      (grtext) 
      (setq etime(getvar"date")) 
      (princ "\n程序共耗用时间：") 
      (princ (* 86400.0 (- (- etime stime) (fix (- etime stime))))) 
      (princ "秒") 
      (command "zoom" "e") 
    ) 
 
    (princ "\n未选择数据文件，退出") 
  ) 
  (setvar "cmdecho" oldcmd) 
  (setvar "blipmode" oldblip) 
  (setvar "osmode" oldsnap) 
  (princ) 
) 
 
(defun drawline        (pnt1 pnt2 r mSpace / a1 a2 p1 p2) 
  (setq        a1 (angle pnt1 pnt2) 
        a2 (angle pnt2 pnt1) 
        p1 (polar pnt1 a1 r) 
        p2 (polar pnt2 a2 r) 
  ) 
  (vla-addLine mSpace (vlax-3d-point p1) (vlax-3d-point p2)) 
  pnt2 
) 
 
(defun ax:2Point (pt1 pt2) 
  (vlax-make-variant 
    (vlax-safearray-fill 
      (vlax-make-safearray vlax-vbdouble '(0 . 3)) 
      (list (car pt1) (cadr pt1) (car pt2) (cadr pt2)) 
    ) 
  ) 
) 
 
(defun makeblk (r CType blocks / pt1 pt2 pt3 pt4 pl1 pl2 inspnt blkobj basecircle blkname) 
  (setq        inspnt (vlax-make-variant 
                 (vlax-safearray-fill 
                   (vlax-make-safearray vlax-vbdouble '(0 . 2)) 
                   '(0 0 0) 
                 ) 
               ) 
  ) 
 
  (setq blkobj (vla-add blocks inspnt "*U")) 
 
 
  (setq basecircle (vla-addCircle blkobj inspnt r)) 
  (cond 
    ((= CType "2") 
     (setq pt1 (polar '(0 0) 0 (/ r 2)) 
           pt2 (polar '(0 0) pi (/ r 2)) 
     ) 
     (setq pl1 (vla-AddLightweightPolyline blkobj (ax:2Point pt1 pt2)) 
           pl2 (vla-AddLightweightPolyline blkobj (ax:2Point pt2 pt1)) 
     ) 
     (vla-SetBulge pl1 0 1) 
     (vla-SetBulge pl2 0 1) 
     (vla-SetWidth pl1 0 r r) 
     (vla-SetWidth pl2 0 r r) 
    ) 
    ((= CType "3") 
     (setq pt1 (polar '(0 0) 0 (/ r 2)) 
           pt2 (polar '(0 0) pi (/ r 2)) 
     ) 
     (setq pl1 (vla-AddLightweightPolyline blkobj (ax:2Point pt1 pt2)) 
     ) 
     (vla-SetBulge pl1 0 1) 
     (vla-SetWidth pl1 0 r r) 
    ) 
    ((= CType "4") 
     (setq pt1 (polar '(0 0) 0 (/ r 2)) 
           pt2 (polar '(0 0) (/ pi 2) (/ r 2)) 
           pt3 (polar '(0 0) pi (/ r 2)) 
           pt4 (polar '(0 0) (+ pi (/ pi 2)) (/ r 2)) 
     ) 
     (setq pl1 (vla-AddLightweightPolyline blkobj (ax:2Point pt1 pt2)) 
           pl2 (vla-AddLightweightPolyline blkobj (ax:2Point pt3 pt4)) 
     ) 
     (vla-SetBulge pl1 0 0.4142) 
     (vla-SetBulge pl2 0 0.4142) 
     (vla-SetWidth pl1 0 r r) 
     (vla-SetWidth pl2 0 r r) 
    ) 
  ) 
  (setq blkname (vla-get-name blkobj)) 
)

LUCAS · 发表于 2003-1-21 12:33:57

看看原贴子也不错

http://www.mjtd.com/bbs/dispbbs. ... ID=17234&skin=1

http://www.mjtd.com/bbs/dispbbs. ... =16404&ID=16404

游手好闲 · 发表于 2003-1-21 15:07:04

又发现一个CAD的网站，不过是搞机械的。

zhynt · 发表于 2003-1-21 15:20:34

你说的是明经通道吗，这也是一个很不错的cad网站哦。

游手好闲 · 发表于 2003-1-21 21:55:16

是啊！不太火的论坛，而且论坛页面有点乱。
不过资源还是很丰富的！

梦断江南 · 发表于 2003-5-4 17:31:13

谁来做个演示,有加分!

wowoaicad · 发表于 2003-5-4 17:54:55

在CAD2002、2004下能用，坐标点填充有四个选项：无、全、半、对角填充。

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

[分享]：一个画数据线的程序

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

相关帖子