已知屏上一点x坐标，求多段线的Y坐标（不产生射线）

WhoCanSay

已知屏上一点x坐标，求曲线的Y坐标（不产生射线）。时常有人想这么干，万能一点的方法是产生射线，然后用vla-IntersectWith法，有人说IntersectWith考虑情况很多，故比较慢。对于任何曲线，也许只有这么干。
下面的程序只考虑多段线，不产生射线，也许要快些，除了上帝知道外，可能你也知道，如果你测试一番的话。
;;[功能] 多段线与射线的交点(不产生射线)
;;(IntersLwpolylineRay (car(entsel)) (getpoint) (getpoint))
(defun IntersLwpolylineRay (e p1 p2 / CP EP FLAG MDERIV MP PARAM PT PTS R SP)
  (setq param (fix (vlax-curve-getEndParam e)))
  (setq sp (vlax-curve-getPointAtParam e param))
  (repeat param
    (setq param (1- param))
    (setq Ep (vlax-curve-getPointAtParam e param))
    (setq Mp (vlax-curve-getPointAtParam e (+ param 0.5))) ;中点
    (setq Mderiv (vlax-curve-getsecondderiv e (+ param 0.5))) ;中点法线
    (setq Flag (car (trans (mapcar '- Mp Ep) 0 (mapcar '- Ep sp))))
    (cond ((equal Flag 0)
           (setq pt (IntersPointRay sp Ep p1 p2));http://bbs.xdcad.net/thread-704374-1-1.html
           (cond (pt (setq pts (cons pt pts))))
          )
          ((minusp Flag)
           (setq cp (mapcar '- Mp Mderiv))
           (setq R (distance cp Mp))
           (setq pt (IntersArcRay p1 p2 cp R e));http://bbs.xdcad.net/thread-704375-1-1.html
           (cond (pt (setq pts (append pts pt))))           
          )
          (T
           (setq cp (mapcar '- Mp Mderiv))
           (setq R (distance cp Mp))
           (setq pt (IntersArcRay p1 p2 cp R e))
           (cond (pt (setq pts (append pts pt))))
          )
    )
    (setq sp Ep)
  )
  pts
)

newer

没有函数定义 INTERSARCRAY

newer

楼主，写个测试命令，然后截取个图更能说明问题。

WhoCanSay

newer 发表于 2016-6-1 13:34
楼主，写个测试命令，然后截取个图更能说明问题。

测试命令的呀(IntersLwpolylineRay (car(entsel)) (getpoint) (getpoint))

2. 
   
3. ;;[功能] 直线与圆的交点 By Highflybird
   
4. (defun IntersLineCircle        (p1 p2 cp r / p0 d n s)
   
5.   (setq        n  (mapcar '- p2 p1) ;_ 新投影面的法向量
   
6.         P1 (trans p1 0 n) ;_ P1坐标转换到新投影面n
   
7.         cp (trans cp 0 n) ;_ CP坐标转换到新投影面n
   
8.         p0 (list (car p1) (cadr p1) (caddr cp)) ;_ P0在新投影面坐标
   
9.   )
   
10.   (cond
    
11.     ((equal r (setq d (distance cp p0))) ;_ 直线和园相切
    
12.      (list (trans p0 n 0))
    
13.     )
    
14.     ((< d r) ;_ 相交
    
15.      (setq s (sqrt (- (* r r) (* d d))))
    
16.      (list
    
17.        (trans (list (car p1) (cadr p1) (- (caddr cp) s)) n 0) ;_ J1坐标
    
18.        (trans (list (car p1) (cadr p1) (+ (caddr cp) s)) n 0) ;_ J2坐标
    
19.      )
    
20.     )
    
21.   )
    
22. )
    
23. 
    
24. 
    
25. ;;[功能] 射线与线、圆、弧、多段线的交点
    
26. (defun C:w1 (/ CP E EN P1 P10 P11 P2 PT PYP R)
    
27.   (setq e (car (entsel)))
    
28.   (setq p1 (getpoint))
    
29.   (setq p2 (mapcar '+ p1 (list 0 10 0)))                    ;竖直射线
    
30.   (setq en (entget e))
    
31.   (setq Pyp (cdr (assoc 0 en)))
    
32.   (cond        ((equal Pyp "ARC")
    
33.          (setq cp (cdr (assoc 10 en)))
    
34.          (setq R (cdr (assoc 40 en)))
    
35.          (IntersArcRay p1 p2 cp r e)
    
36.         )
    
37.         ((equal Pyp "LINE")
    
38.          (setq p10 (cdr (assoc 10 en)))
    
39.          (setq p11 (cdr (assoc 11 en)))
    
40.          (setq p10 (IntersPointRay p10 p11 p1 p2))
    
41.          (cond (p10 (list p10)))
    
42.         )
    
43.         ((equal Pyp "CIRCLE")
    
44.          (setq cp (cdr (assoc 10 en)))
    
45.          (setq R (cdr (assoc 40 en)))
    
46.          (IntersPointRay p10 p11 p1 p2)
    
47.         )
    
48.         ((equal Pyp "LWPOLYLINE")
    
49.          (IntersLwpolylineRay e p1 p2)
    
50.         )
    
51.   )
    
52. )
    
53. 
    

<br /> ;;[功能] 直线与圆的交点 By Highflybird<br /> (defun IntersLineCircle        (p1 p2 cp r / p0 d n s)<br />   (setq        n  (mapcar '- p2 p1) ;_ 新投影面的法向量<br />         P1 (trans p1 0 n) ;_ P1坐标转换到新投影面n<br />         cp (trans cp 0 n) ;_ CP坐标转换到新投影面n<br />         p0 (list (car p1) (cadr p1) (caddr cp)) ;_ P0在新投影面坐标<br />   )<br />   (cond<br />     ((equal r (setq d (distance cp p0))) ;_ 直线和园相切<br />      (list (trans p0 n 0))<br />     )<br />     ((< d r) ;_ 相交<br />      (setq s (sqrt (- (* r r) (* d d))))<br />      (list<br />        (trans (list (car p1) (cadr p1) (- (caddr cp) s)) n 0) ;_ J1坐标<br />        (trans (list (car p1) (cadr p1) (+ (caddr cp) s)) n 0) ;_ J2坐标<br />      )<br />     )<br />   )<br /> )<br /> <br /> <br /> ;;[功能] 射线与线、圆、弧、多段线的交点<br /> (defun C:w1 (/ CP E EN P1 P10 P11 P2 PT PYP R)<br />   (setq e (car (entsel)))<br />   (setq p1 (getpoint))<br />   (setq p2 (mapcar '+ p1 (list 0 10 0)))                    ;竖直射线<br />   (setq en (entget e))<br />   (setq Pyp (cdr (assoc 0 en)))<br />   (cond        ((equal Pyp "ARC")<br />          (setq cp (cdr (assoc 10 en)))<br />          (setq R (cdr (assoc 40 en)))<br />          (IntersArcRay p1 p2 cp r e)<br />         )<br />         ((equal Pyp "LINE")<br />          (setq p10 (cdr (assoc 10 en)))<br />          (setq p11 (cdr (assoc 11 en)))<br />          (setq p10 (IntersPointRay p10 p11 p1 p2))<br />          (cond (p10 (list p10)))<br />         )<br />         ((equal Pyp "CIRCLE")<br />          (setq cp (cdr (assoc 10 en)))<br />          (setq R (cdr (assoc 40 en)))<br />          (IntersPointRay p10 p11 p1 p2)<br />         )<br />         ((equal Pyp "LWPOLYLINE")<br />          (IntersLwpolylineRay e p1 p2)<br />         )<br />   )<br /> )<br /> <br />

xvjiex

感谢分享已知屏上一点x坐标，求多段线的Y坐标（不产生射线）