乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 68|回复: 5

meflying 请进来帮帮我,谢谢!

[复制链接]

6

主题

18

帖子

2

银币

初来乍到

Rank: 1

铜币
42
发表于 2004-10-20 16:37:00 | 显示全部楼层 |阅读模式
meflying 这两天我又研究了一下你给我写的程序,当输入的点排完序后,再往里面追加满足条件长方形的四个角点时,当(> lMax l)成立,且有两个相邻点之间夹有两个角点时,循环程序只能在这两点之间追加一个角点。我改了好多次实在是改不明白啊,再请你帮帮忙吧。以下程序中我给定的点是出现的哪种情况,其中注释的哪一点运行时同样出现哪种情况。
(vl-load-com)
(defun c:test( / ent ptLst ptLstc ptLstn pt ptn pti pta j i n dist l lMax)
(setq pt1 '(200 1000 0)         pt2 '(400 1000 0)         pt3 '(500 0 0) pt4 '(200 0 0)         )
;(setq pt1 '(200 1000 0)         pt2 '(400 1000 0)         pt3 '(2000 500         0) pt4 '(200 0 0)         )
(setq ptc1 '(0 1000 0)         )
(setq ptc2 '(2000 1000 0)         )
(setq ptc3 '(2000 0 0)         )
(setq ptc4 '(0 0 0)         )
(command "rectang" ptc1 ptc3 "")
(setq ent         (entlast))
;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******
(setq ptLst (list pt1 pt2 pt3 pt4 ))
(setq ptLstc (list ptc1 ptc2 ptc3 ptc4))
;****************************************************************
(setq ptLst (mapcar '(lambda(x) (list (vlax-curve-getDistAtPoint ent x) x)) ptLst))
(setq ptLst (vl-sort ptLst '(lambda (x1 x2) ( lMax l)
(progn
(setq n (vl-position lMax dist))
(repeat (1+ n)
(setq ptLst (reverse (cons (car ptLst) (reverse (cdr ptLst)))))
)
)
)
(setq ptLst (mapcar 'cadr ptLst))
(setq i 0)
(repeat (1- (length ptLst))
(setq pt (nth i ptLst))
(setq ptn (nth (1+ i) ptLst))
(setq ptLstn (append ptLstn (list pt)))
(setq j 0)
(setq m t)
(while m
(setq pti (nth j ptLstc))
(cond
        ((> (vlax-curve-getDistAtPoint ent pt) (vlax-curve-getDistAtPoint ent ptn))
                 (if (or (equal (vlax-curve-getStartPoint ent) pti 0.001)
                                                         ( (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent pt))
                                                                                         ( j 3) (setq m nil))
)
(setq i (1+ i))
)
(setvar "osmode" 0)
(command "color" 170 "")
(command "_.pline")
(mapcar 'command ptLstn)
(command (last ptLst) "")
(command "color" "bylayer" "")
(command "erase" ent "")
)
回复

使用道具 举报

6

主题

18

帖子

2

银币

初来乍到

Rank: 1

铜币
42
发表于 2004-10-21 08:47:00 | 显示全部楼层
谁能帮我把这程序修改一下,我想要的是连线中(0,0,0)点也在连线中,即线条是正交的。
回复

使用道具 举报

26

主题

3072

帖子

10

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3177
发表于 2004-10-21 10:27:00 | 显示全部楼层
  1. (vl-load-com)
  2. (defun c:test( / ent ptLst ptLstc ptLstn pt ptn pti ptt pta j i n dist l lMax)
  3. ;;;   (setq ent (car (entsel)))
  4. ;;;   
  5. ;;;   ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******
  6. ;;;   (repeat 6
  7. ;;;       (setq ptLst (append ptLst (list (getpoint "\nPick a point:"))))
  8. ;;;   )
  9. ;;;   (repeat 4
  10. ;;;       (setq ptLstc (append ptLstc (list (getpoint "\nPick a point:"))))
  11. ;;;   )
  12. ;;;   ;****************************************************************
  13.    
  14. (setq pt1 '(200 1000 0)   pt2 '(400 1000 0)   pt3 '(500 0 0) pt4 '(200 0 0)   )
  15. ;(setq pt1 '(200 1000 0)   pt2 '(400 1000 0)   pt3 '(2000 500   0) pt4 '(200 0 0)   )
  16. (setq ptc1 '(0 1000 0)   )
  17. (setq ptc2 '(2000 1000 0)   )
  18. (setq ptc3 '(2000 0 0)   )
  19. (setq ptc4 '(0 0 0)   )
  20. (command "rectang" ptc1 ptc3)
  21. (setq ent   (entlast))
  22. ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******
  23. (setq ptLst (list pt1 pt2 pt3 pt4 ))
  24. (setq ptLstc (list ptc1 ptc2 ptc3 ptc4))
  25. ;****************************************************************
  26.    (setq ptLst (mapcar '(lambda(x) (list (vlax-curve-getDistAtPoint ent x) x)) ptLst))
  27.    (setq ptLst (vl-sort ptLst '(lambda (x1 x2) ( lMax l)
  28.        (progn
  29.            (setq n (vl-position lMax dist))
  30.            (repeat (1+ n)
  31.   (setq ptLst (reverse (cons (car ptLst) (reverse (cdr ptLst)))))
  32.            )
  33.        )
  34.    )
  35.    (setq ptLst (mapcar 'cadr ptLst))
  36.    (setq i 0)
  37.    (repeat (1- (length ptLst))
  38.        (setq pt (nth i ptLst))
  39.        (setq ptn (nth (1+ i) ptLst))
  40.        (setq ptLstn (append ptLstn (list pt)))
  41.        (setq j 0)
  42.        (setq m t)
  43.        (while m
  44.            (setq pti (nth j ptLstc))
  45.            (cond
  46.   ((> (vlax-curve-getDistAtPoint ent pt)
  47.          (vlax-curve-getDistAtPoint ent ptn))
  48.    (if (or (equal (vlax-curve-getStartPoint ent) pti 0.001)
  49.      ( (vlax-curve-getDistAtPoint ent pti)
  50.    (vlax-curve-getDistAtPoint ent pt)
  51.        )
  52.        (setq ptt (cons pti ptt))
  53.    )
  54.   );1
  55.   (( (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent pt))
  56.        ( j 3) (setq m nil))
  57.        )
  58.        (setq ptLstn (append ptLstn ptt))
  59.        (setq ptt nil)
  60.        (setq i (1+ i))
  61.    )
  62.    (setvar "osmode" (logior (getvar "osmode") 16384))
  63.    (command "_.pline")
  64.    (mapcar 'command ptLstn)
  65.    (command (last ptLst) "")
  66. )
回复

使用道具 举报

6

主题

18

帖子

2

银币

初来乍到

Rank: 1

铜币
42
发表于 2004-10-22 09:02:00 | 显示全部楼层
谢谢辉哥,让我学到不少东西,总算把这程序看明白了,vlisp里确实有很多好用的命令。(setvar "osmode" (logior (getvar "osmode") 16384)这个用法看你在别的帖子里也发过,真是高人。
回复

使用道具 举报

26

主题

3072

帖子

10

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3177
发表于 2004-10-22 11:13:00 | 显示全部楼层
一个纯计算型的方法...你先测试一下
  1. (vl-load-com)
  2. (defun Getin(pt1 pt2 ptlst / pt pts i)
  3.    (cond
  4.        ((equal (car pt1) (car pt2) 0.00001) (setq fun 'car))
  5.        ((equal (cadr pt1) (cadr pt2) 0.00001) (setq fun 'cadr))
  6.        (t (princ "Wrong!") (exit))
  7.    )
  8.    (setq i 0)
  9.    (repeat (length ptlst)
  10.        (setq pt (nth i ptlst))
  11.        (if (equal ((eval fun) pt1) ((eval fun) pt) 0.00001)
  12.            (setq pts (cons pt pts))
  13.        )
  14.        (setq i (1+ i))
  15.    )
  16.    (setq pts (mapcar '(lambda (x) (list (distance x pt1) x)) pts))
  17.    (setq pts (vl-sort pts '(lambda (x1 x2) ( (length ptlstc) 0)
  18.        (setq pt (car ptlstc))
  19.        (if (or (equal (car pt) (caar pt1) 0.00001)
  20.          (equal (cadr pt) (cadar pt1) 0.00001))
  21.            (setq pt1 (cons pt pt1) ptlstc (vl-remove (car pt1) ptlstc))
  22.            (setq ptlstc (append (cdr ptlstc) (list (car ptlstc))))
  23.        )
  24.    )
  25.    (setq ptlstc pt1)
  26.    (setq ptlstc (append ptlstc (list (car ptlstc))))
  27.    (setq i 0 pt2 nil)
  28.    (repeat 4
  29.        (setq pt (nth i ptlstc)
  30.      pt1 (nth (1+ i) ptlstc))
  31.        (setq pt2 (append pt2 (cons pt (Getin pt pt1 ptlst))))
  32.        (setq i (1+ i))
  33.    )
  34.    (setq ptlst pt2)
  35.    (while (member (car ptlst) ptlstc)
  36.        (setq ptlst (cons (last ptlst) (reverse (cdr (reverse ptlst)))))
  37.    )
  38.    (setq ptlst (append ptlst (list (car ptlst))))
  39.    (setq lens (getlen ptlstc ptlst))
  40.    (setq n (vl-position (apply 'max lens) lens))
  41.    (setq i 0 m 0)
  42.    (while (<= m (1+ n))
  43.        (setq pt (nth i ptlst))
  44.        (if (not (member pt ptlstc))
  45.            (setq m (1+ m))
  46.        )
  47.        (setq i (1+ i))
  48.    )
  49.    (setq ptlst (reverse (cdr (reverse ptlst))))
  50.    (repeat (1- i)
  51.        (setq ptlst (append (cdr ptlst) (list (car ptlst))))
  52.    )
  53.    (while (member (car ptlst) ptlstc) (setq ptlst (cdr ptlst)))
  54.    (while (member (last ptlst) ptlstc) (setq ptlst (reverse (cdr (reverse ptlst)))))
  55.    
  56.    (setvar "osmode" (logior (getvar "osmode") 16384))
  57.    (command "_.pline")
  58.    (mapcar 'command ptLst)
  59.    (command "")
  60. )
回复

使用道具 举报

6

主题

18

帖子

2

银币

初来乍到

Rank: 1

铜币
42
发表于 2004-10-22 19:46:00 | 显示全部楼层
好啊,辉哥,你效率真高啊。
回复

使用道具 举报

发表回复

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

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-8-20 22:00 , Processed in 0.376141 second(s), 65 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表