[LISP程序]：小小分享 找出两条线的虚拟焦点

walpax

我也提供一个
高手们如果觉得简单请参考就好

功能 找出两条线的虚拟焦点

(defun C:PL1 (/ E1 E2 P1 P2 P3 P4 P5 P6 AA BB CC H K R Y1 Y2 X1 X2 V1 V2)
  (setvar "OSMODE" 512)
  (setq E1 (ssname (ssget (getpoint "\nfirst entity : ")) 0))
  (setq E2 (ssname (ssget (getpoint "\nsecond entity :  ")) 0))
  (setvar "OSMODE" 0)
  (setq V2 0)
  (if (/= (cdr (assoc 0 (entget E1))) "LINE") (setq V2 (+ V2 2)))
  (if (/= (cdr (assoc 0 (entget E2))) "LINE") (setq V2 (+ V2 1)))
  (if (= V2 0) ;if line,line
      (progn
      (setq P1 (cdr (assoc 10 (entget E1)))) ;start point origenal
      (setq P2 (cdr (assoc 11 (entget E1)))) ;end point origenal
      (setq P3 (cdr (assoc 10 (entget E2)))) ;start point origenal
      (setq P4 (cdr (assoc 11 (entget E2)))) ;end point origenal
      (setq P5 (inters P1 P2 P3 P4 nil))
      (if (< (distance P1 P5) (distance P2 P5)) (setq PA5 P1) (setq PA5 P2))
      (if (< (distance P3 P5) (distance P4 P5)) (setq PB5 P3) (setq PB5 P4))
      ;(setq PA5 (cdr (assoc 10 (entget E3))))
      ;(setq PB5 (cdr (assoc 11 (entget E3))))
      (COMMAND "LINE" PA5 P5 PB5 "")
      )
  )
  (if (= V2 2) ;if arc/circle,line
      (progn   ;CHANGE TO V2=1 AND NEXT PROGRAM CAN DO IT
      (setq V1 E1)
      (setq E1 E2)
      (setq E2 V1)
      (setq V2 1)
      )
   )
  (if (= V2 1) ;if line,arc/circle
      (progn
      ; line equation : AA*X+BB*Y+CC=0
      (setq P1 (cdr (assoc 10 (entget E1)))) ;start point
      (setq P2 (cdr (assoc 11 (entget E1)))) ;end point
      (setq X1 (car P1))
      (setq Y1 (cadr P1))
      (setq X2 (car P2))
      (setq Y2 (cadr P2))
      (setq AA (- Y1 Y2))
      (setq BB (- X2 X1))
      (setq CC (- (* X1 Y2) (*  X2 Y1)))
      ; circle  equation : (X - H)^2 +  (Y - K)^2 = R^2
      (setq P3 (cdr (assoc 10 (entget E2)))) ;center point
      (setq R (cdr (assoc 40 (entget E2))))  ;radius
      (setq H (car P3))
      (setq K (cadr P3))
      (INTPOINT AA BB CC H K R)
      (setq P6 (getpoint "\nindicate near : "))
      (if (< (distance POINT1 P6) (distance POINT2 P6)) (setq P5 POINT1) (setq P5 POINT2))
      (if (< (distance P1 P5) (distance P2 P5)) (setq PA5 P1) (setq PA5 P2))
      (COMMAND "LINE" PA5 P5 "" )
      ;
      ;Because arc start point to end point must is ccw
      ;
      (setq TMPAG1 (cdr (assoc 50 (entget E2))))
      (setq TMPAG2 (cdr (assoc 51 (entget E2))))
      (setq TMP1 (polar P3 TMPAG1 R));START POINT
      (setq TMP2 (polar P3 TMPAG2 R));END POINT
      (if (< (distance TMP2 P5) (distance TMP1 P5)) (COMMAND "arc" "c" P3 TMP2 P5 "" ) (COMMAND "arc" "c" P3 P5 TMP1 "" ))
      )
  )
)


我是新手
写的不好
请大家见谅

cy956

2. 
   
3. ;;;VxGetInters - 返回两个物体的所有交点
   
4. ; -- Function VxGetInters
   
5. ; Arguments [Typ]:
   
6. ; Fst = First object [VLA-OBJECT]
   
7. ; Nxt = Second object [VLA-OBJECT]
   
8. ; Mde = Intersection mode [INT]
   
9. ; Constants:
   
10. ; - acExtendNone Does 不延伸
    
11. ; - acExtendThisEntity 延伸第一
    
12. ; - acExtendOtherEntity 延伸第二
    
13. ; - acExtendBoth 延伸两者
    
14. ; Return [Typ]:
    
15. ; > list of points '((1.0 1.0 0.0)... [LIST]
    
16. ; > Nil if no intersection found
    
17. ;
    
18. (defun VxGetInters (Fst Nxt Mde / IntLst PntLst);;;实体交点
    
19.   (setq IntLst (vlax-invoke Fst "IntersectWith" Nxt Mde))
    
20.   (cond
    
21.     (IntLst
    
22.       (repeat (/ (length IntLst) 3)
    
23.         (setq PntLst
    
24.                 (cons
    
25.                   (list(car IntLst)(cadr IntLst)(caddr IntLst))
    
26.                   PntLst
    
27.                 )
    
28.               IntLst (cdddr IntLst))
    
29.       )
    
30.       (reverse PntLst)
    
31.     )
    
32.     (T nil)
    
33.   )
    
34. )
    

<br /> ;;;VxGetInters - 返回两个物体的所有交点<br /> ; -- Function VxGetInters<br /> ; Arguments [Typ]:<br /> ; Fst = First object [VLA-OBJECT]<br /> ; Nxt = Second object [VLA-OBJECT]<br /> ; Mde = Intersection mode [INT]<br /> ; Constants:<br /> ; - acExtendNone Does 不延伸<br /> ; - acExtendThisEntity 延伸第一<br /> ; - acExtendOtherEntity 延伸第二<br /> ; - acExtendBoth 延伸两者<br /> ; Return [Typ]:<br /> ; > list of points '((1.0 1.0 0.0)... [LIST]<br /> ; > Nil if no intersection found<br /> ;<br /> (defun VxGetInters (Fst Nxt Mde / IntLst PntLst);;;实体交点<br />   (setq IntLst (vlax-invoke Fst "IntersectWith" Nxt Mde))<br />   (cond<br />     (IntLst<br />       (repeat (/ (length IntLst) 3)<br />         (setq PntLst<br />                 (cons<br />                   (list(car IntLst)(cadr IntLst)(caddr IntLst))<br />                   PntLst<br />                 )<br />               IntLst (cdddr IntLst))<br />       )<br />       (reverse PntLst)<br />     )<br />     (T nil)<br />   )<br /> )<br />

舞步

不明白什么作用！

walpax

希望附件的说明能让您更清楚用法

也谢谢您的回应

cy956

你可以这样调用:

2. 
   
3. (defun get_inters(e1 e2 mod / fir sec ipp);;;;获得实体e1 e2 的交点1
   
4. ;;;  acExtendNone                ;;;  acExtendThisEntity
   
5. ;;;  acExtendOtherEntity        ;;;  acExtendBoth
   
6.   (setq fir (vlax-ename->vla-object e1)
   
7.         sec (vlax-ename->vla-object e2)
   
8.         ipp (VxGetInters fir sec mod))
   
9. )
   
10. 
    
11. (setq e1(car (entsel "\n选线一:"))
    
12.        e2(car (entsel "\n选线二:"))
    
13.       pt(get_inters e1 e2 "acExtendNone")
    
14. )
    

<br /> (defun get_inters(e1 e2 mod / fir sec ipp);;;;获得实体e1 e2 的交点1<br /> ;;;  acExtendNone                ;;;  acExtendThisEntity<br /> ;;;  acExtendOtherEntity        ;;;  acExtendBoth<br />   (setq fir (vlax-ename->vla-object e1)<br />         sec (vlax-ename->vla-object e2)<br />         ipp (VxGetInters fir sec mod))<br /> )<br /> <br /> (setq e1(car (entsel "\n选线一:"))<br />        e2(car (entsel "\n选线二:"))<br />       pt(get_inters e1 e2 "acExtendNone")<br /> )<br />

得到的是两线的不延伸情况下的交叉点，其他还有
;;;  acExtendThisEntity延伸第一线
;;;  acExtendOtherEntity延伸第二线       
;;;  acExtendBoth延伸两线
的三种交点方式。

cjrun

哦！我看不懂了

UVWXYZ

不太明白

梦断江南

cadr200x 中打开对象追踪 ，在绘图操作命令前，鼠标移动到要求交点的线段端点，再移动到虚交点附近，可以自动捕捉交点，这时鼠标再按下，可以从交点处执行命令

正航

谢谢。我正想编这个程序，现在可省事了。

双木一心

谢谢！不错哦

chenhang1203

还是用第8 贴 方便

zllaury

如何下载你们编的程序？我看不明白，请指教。

ZXK68

最初由 walpax 发布
[B]希望附件的说明能让您更清楚用法

也谢谢您的回应 [/B]

　　多此一举，有“对象追踪”不用。用什么程序。

lsjjm

最初由 ZXK68 发布
[B]
　　多此一举，有“对象追踪”不用。用什么程序。 [/B]

不能这么说. 前面“对象追踪”只是手动, 大量重复的工作还得使用编程.

ghyszs

lisp呢？
弄出来
大家下载阿
腰部还要再复制
自己做
嘿嘿
懒把我