meflying请进来看一下，有点小问题麻烦您

huayingjie

上次你给我写的连接六个点的程序，当出现6个点对称分布在两个相对边时，连线方法不能满足所需要求，请你再帮忙看一下! 以下是我说我情况的一种，请运行看一下，中间哪条线按要求应该是正交的。谢谢! (vl-load-com)
(defun c:test( / ent ptLst ptLstc ptLstn pt ptn pti pta j i n dist l lMax)
(setq pt1 '(0 200 200) pt2 '(0 600 200) pt3 '(0 1200 200) pt4 '(3200 900 200) pt5 '(3200 1800 200) pt6 '(3200 1300 200) )
(setq ptc1 '(0 2000 200) )
(setq ptc2 '(3200 2000 200) )
(setq ptc3 '(3200 0 200) )
(setq ptc4 '(0 0 200) )
(command "rectang" ptc1 ptc3 "")
(setq ent (entlast))
;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******
(setq ptLst (list pt1 pt2 pt3 pt4 pt5 pt6))
(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) (< (car x1) (car x2)))))
(setq ptLstc (mapcar '(lambda(x) (list (vlax-curve-getDistAtPoint ent x) x)) ptLstc))
(setq ptLstc (mapcar 'cadr (vl-sort ptLstc '(lambda (x1 x2) (< (car x1) (car x2))))))
(setq i 1)
(repeat 5
(setq dist (append dist (list (- (car (nth i ptLst)) (car (nth (1- i) ptLst))))))
(setq i (1+ i))
)
(setq lMax (apply 'max dist))
(setq l (+ (caar ptLst) (- (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (car (last ptLst)))))
(if (> 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 (equal (vlax-curve-getStartPoint ent) pti 0.001)
(setq ptLstn (append ptLstn (list pti)))
)
)
((< (vlax-curve-getDistAtPoint ent pt)
(vlax-curve-getDistAtPoint ent ptn))
(if (and (> (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent pt))
(< (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent ptn)))
(setq ptLstn (append ptLstn (list pti)))
)
)
)
(setq j (1+ j))
(if (> j 3) (setq m nil))
)
(setq i (1+ i))
)
(setvar "osmode" 0)
;(command "linetype" "s" "xx" "")
(command "color" 170 "")
(command "_.pline")
(mapcar 'command ptLstn)
(command (last ptLst) "")
(command "color" "bylayer" "")
;(command "linetype" "s" "bylayer" "")
(command "erase" ent "")
)

meflying

确实少了一个判断,把下面的改一下: (if (equal (vlax-curve-getStartPoint ent) pti 0.001)
(setq ptLstn (append ptLstn (list pti)))
) ----> (if (or (equal (vlax-curve-getStartPoint ent) pti 0.001)
(< (vlax-curve-getDistAtPoint ent pti)
(vlax-curve-getDistAtPoint ent ptn)
))
(setq ptLstn (append ptLstn (list pti)))
)

huayingjie

真是高啊，顺便问一下我买的vlisp命令参考书里有一些上面程序用到的vlisp命令没有，在那有下载的啊!

meflying

VLISP的参考帮助文件里都有,


你用过VLISP编辑器吗?2000以上CAD自带的,在命令行输入:VLISP就可以了,


在VLISP编辑器里按F1

huayingjie

我哪个vlisp帮助文件是英文的，看不太懂。

meflying

本站就有中文版下载,在CAD下载,你找找吧

huayingjie

谢谢，程序还有点小问题，有一个图发你信箱了，麻烦您了!

huayingjie

meflying，你给的程序运行好多次后，发现当有点在长方形的上下边时出现我发给你的图上的哪种情况。程序应该怎么修改，我实在看不太懂，求你再帮帮吧。

meflying

图??


OR点??