[试用]：画线过程中实现自动移屏

19992008 · 发表于 2006-9-20 09:02:12

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

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

×

这是别人做的程序,请大家测试并帮忙改进.使它画出来的线能连接起来,并实现线头转换等功能.

(defun c:pp ()
  (setvar "cmdecho" 0)
  (vl-load-com)
  (if (setq point (getpoint "\nfrom point"))
(progn
   (setq draw    t
      ss       (ssadd)
      pts       nil
      pts       (cons point pts)
      modespace (vla-get-ModelSpace
         (vla-get-ActiveDocument (vlax-get-acad-object))
            )
   )
   (while draw
(initget 128 "U E C_u e c")
(setq point
         (getpoint (car pts) "\nUndo/Close/<Endpoint to line>:")
)
(cond
   ((or (= point nil) (= point "e") (= point "c"))
   (command "pline" (car pts) (car pts) "")
   (setq ss (ssadd (entlast) ss))
   (setq draw nil)
   )
   ((= point "u")
   (if (= (length pts) 1)
      (print "can't undo.")
      (progn
         (setq pts (cdr pts))
         (command "zoom" "c" (car pts) "100")
         (command "erase" (entlast) "")
      )
   )
   )
   ((= (type point) 'list)
   (command "zoom" "c" point "100")
   (command "pline" (car pts) point "")
   (setq pts (cons point pts))
   (setq ss (ssadd (entlast) ss))
   )
)
   )
   (if (> (length pts) 1)
(progn
   (setq ven (vla-addPolyline
            modespace
            (apply 'append (reverse pts))
         )
   )
   (if (= point "c")
      (vla-put-Closed ven t)
   )
   (vlax-release-object ven)
)
   )
   (command "erase" ss "")
)
  )
  (prin1)
)

h222222 · 发表于 2006-10-11 03:20:50

确实好用

xinyiguda · 发表于 2006-10-24 11:49:43

呵呵！不错！谢谢楼主

sxlxf · 发表于 2006-11-2 08:01:24

键盘输线长不好用

WHGF · 发表于 2006-11-2 11:47:27

画出的线是用LINE组成的,如果是画复义线能用就好了

zhynt · 发表于 2006-11-11 03:31:11

[php]
(defun c:pp (/ id DRAW MODESPACE POINT PTS SS VEN ss1)
  (setvar "cmdecho" 0)
  (vl-load-com)
  (if (setq point (getpoint "\nfrom point"))
(progn
   (setq id       t
      draw    t
      ss       (ssadd)
      pts       nil
      pts       (cons point pts)
   )
   (while draw
(initget 128 "U E C_u e c")
(setq point
         (getpoint (car pts) "\nUndo/Close/:")
)
(cond
   ((or (= point nil) (= point "e") (= point "c"))
   (command "pline" (car pts) (car pts) "")
   (setq ss (ssadd (entlast) ss))
   (setq draw nil)
   )
   ((= point "u")
   (if (= (length pts) 1)
      (print "can't undo.")
      (progn
         (setq pts (cdr pts))
         (command "'zoom" "c" (car pts) "100")
         (command "erase" (entlast) "")
      )
   )
   )
   ((= (type point) 'list)
   (command "'zoom" "c" point "100")
   (command "pline" (car pts) point "")
   (if (= id t)
      (progn
         (Setq id    nil
      ss1 (entlast)
         )
      )
   )
   (setq pts (cons point pts))
   (setq ss (ssadd (entlast) ss))
   )
)
   )
)
  )
  (command "pedit" ss1 "j" ss "" "x")
  (prin1)
)
[/php]

pico298 · 发表于 2006-11-18 11:22:12

呵呵！不错！谢谢楼主

hhzcfx · 发表于 2006-11-22 16:46:32

很不错的工具

evergreenxq · 发表于 2006-11-25 15:00:58

不错啊

huiling6868 · 发表于 2006-12-2 01:36:59

不错.

szmax · 发表于 2006-12-3 17:46:16

很有新意，画平面的轮廓线用得上。

dlutstar · 发表于 2006-12-5 16:33:50

呵呵！不错！谢谢楼主

happyliubin · 发表于 2006-12-7 17:29:24

为什么不让我下呀非要逼我刷屏呀

19992008 · 发表于 2006-12-16 16:51:52

是不错。谢谢

问“zhynt ”斑主：能不能让程序显示比例自由设计？

zxdvip · 发表于 2006-12-18 23:09:21

程序有点怪，没想到如何应用

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

[试用]：画线过程中实现自动移屏

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

相关帖子