[求助]很长时间没碰程序，帮忙看下。

小妹丁

xyp1964发表于2010-5-12 13:24:0051773(defun c:tt ()  (prompt \"\选取投影圆: \")  (if (and (setq ss (ssget '((0 . \"CIRCLE\"))))    (setq s1 (car (entsel \"\n选择投影中心线第1条边线: \"))

选取投影圆:
选择对象: 指定对角点: 找到 4 个
选择对象:
选择投影中心线第1条边线:
选择投影中心线第2条边线: ; 错误: no function definition: VLAX-CURVE-GETCLOSESTPOINTTO

小妹丁

(VL-LOAD-COM)

看上去好像捕捉点，还要补全。

liu_kunlun

(command "line" "non" p1 "non" p2 "")

小妹丁

liu_kunlun发表于2010-5-12 16:48:00(command \"line\" \"non\" p1 \"non\" p2 \"\")

还是有点问题：

liu_kunlun

在xyp1964基础上完善一下：

(defun c:tt ( / ss ea pa1 pa2 aga eb pb1 pb2 agb i e pt p1 p2)
  (prompt "\选取投影圆: ")
  (if (and (setq ss (ssget '((0 . "CIRCLE"))))
           (setq ea (car (entsel "\n选择投影中心线第1条边线: ")))   
    (= "LINE" (cdr (assoc 0 (setq ea (entget ea)))))
    (setq pa1 (cdr (assoc 10 ea))
          pa2 (cdr (assoc 11 ea))
   aga (angle pa1 pa2)
    ) 
           (setq eb (car (entsel "\n选择投影中心线第2条边线: ")))
    (= "LINE" (cdr (assoc 0 (setq eb (entget eb)))))
    (setq pb1 (cdr (assoc 10 eb))
          pb2 (cdr (assoc 11 eb))
   agb (angle pb1 pb2)
    )
      )
      (progn
         (setq i -1)
         (while (setq e (ssname ss (setq i (1+ i))))
            (setq pt (cdr (assoc 10 (entget e)))
                  p1 (inters pa1 pa2 pt (polar pt (+ aga (/ pi 2.)) 1.) nil)
                  p2 (inters pb1 pb2 pt (polar pt (+ agb (/ pi 2.)) 1.) nil)
            )
            (command "line" "non" (polar p1 (angle p2 p1) 3.) "non" (polar p2 (angle p1 p2) 3.) "")
         )
     )
  )
  (princ)
)

小妹丁

你改的很好了，谢谢。

现在这个程序，只在处理同心圆上，还有不足，可以应对绝大多数的情况。

小妹丁

此时，如果用equal来排除同心圆，该如何写？

zml84

小妹丁发表于2010-5-15 0:16:00此时，如果用equal来排除同心圆，该如何写？

分步骤来，不要急于绘制。

3. ;;继续完善如下：
4. (defun c:tt (/ ss ea pa1 pa2 aga eb pb1 pb2 agb i e pt p1 p2)
5.   (princ "\选取投影圆: ")
6.   (if (and (setq ss (ssget '((0 . "CIRCLE"))))
7.     ;;
8.     (setq en (car (entsel "\n选择第1条边线: ")))
9.     (setq ent (entget en))
10.     (setq pt10 (cdr (assoc 10 ent)))
11.     (setq pt11 (cdr (assoc 11 ent)))
12.     (setq ang1 (+(angle pt10 pt11)(* 0.5 pi)))
13.     ;;
14.     (setq en (car (entsel "\n选择第2条边线: ")))
15.     (setq ent (entget en))   
16.     (setq pt20 (cdr (assoc 10 ent)))
17.     (setq pt21 (cdr (assoc 11 ent)))
18.     (setq ang2 (+ (angle pt20 pt21)(* 0.5 pi)))
19.       )
20.     (progn
21.       ;;
22.       (setq lst_pt '()
23.      i 0
24.       )
25.       (repeat (sslength ss)
26. (setq en (ssname ss i)
27.        ent (entget en)
28.        )
29. (setq pt (cdr (assoc 10 ent)))
30. (if (member pt lst_pt)
31.    ()
32.    (setq lst_pt (cons pt lst_pt))
33. )
34. (setq i (1+ i))
35.       )
36.       ;;绘制
37.       (foreach pt lst_pt
38. (setq
39.    pt1 (inters pt10 pt11 pt (polar pt ang1 10) nil)
40.    pt2 (inters pt20 pt21 pt (polar pt ang2 10) nil)
41. )
42. (command "line"
43.    "non"
44.    (polar pt1 (angle pt2 pt1) 3)
45.    "non"
46.    (polar pt2 (angle pt1 pt2) 3)
47.    ""
48. )
49.       )
50.     )
51.   )
52.   (princ)
53. )

;;继续完善如下： (defun c:tt (/ ss ea pa1 pa2 aga eb pb1 pb2 agb i e pt p1 p2)   (princ "\选取投影圆: ")   (if (and (setq ss (ssget '((0 . "CIRCLE"))))     ;;     (setq en (car (entsel "\n选择第1条边线: ")))     (setq ent (entget en))     (setq pt10 (cdr (assoc 10 ent)))     (setq pt11 (cdr (assoc 11 ent)))     (setq ang1 (+(angle pt10 pt11)(* 0.5 pi)))     ;;     (setq en (car (entsel "\n选择第2条边线: ")))     (setq ent (entget en))        (setq pt20 (cdr (assoc 10 ent)))     (setq pt21 (cdr (assoc 11 ent)))     (setq ang2 (+ (angle pt20 pt21)(* 0.5 pi)))       )     (progn       ;;       (setq lst_pt '()      i 0       )       (repeat (sslength ss) (setq en (ssname ss i)        ent (entget en)        ) (setq pt (cdr (assoc 10 ent))) (if (member pt lst_pt)    ()    (setq lst_pt (cons pt lst_pt)) ) (setq i (1+ i))       )       ;;绘制       (foreach pt lst_pt (setq    pt1 (inters pt10 pt11 pt (polar pt ang1 10) nil)    pt2 (inters pt20 pt21 pt (polar pt ang2 10) nil) ) (command "line"    "non"    (polar pt1 (angle pt2 pt1) 3)    "non"    (polar pt2 (angle pt1 pt2) 3)    "" )       )     )   )   (princ) )