如果在执行程序（挪圆）前，将直线Z坐标归0？

xskfq

(defun c:ny(/ center circle index lineobj point point_01 point_02 pointlist sscircle ssline syh temp varvalue)
(vl-load-com)
(setvar "cmdecho" 0)
(princ "\n请选取要处理的直线对象")
(setq ssLine (ssget '((0 . "LINE"))))
(if (/= ssLine nil)
  (progn (setq syh 0)
   (vl-cmdf ".zoom" "e")
   (repeat (sslength ssLine)
    (setq LineObj (vlax-ename->vla-object (ssname ssLine syh)))
    (setq Point_01 (vlax-get LineObj 'StartPoint))
    (setq Point_02 (vlax-get LineObj 'EndPoint))
    (setq ssCircle (ssget "f" (list Point_01 Point_02) '((0 . "CIRCLE"))))
    (if (/= ssCircle nil)
     (progn (setq index 0)
      (repeat (sslength ssCircle)
       (setq Circle (vlax-ename->vla-object (ssname ssCircle index)))
       (setq Center (vlax-get Circle 'Center))
       (setq VarValue (vlax-variant-value (vlax-invoke-method LineObj 'IntersectWith Circle acExtendNone)))
       (setq PointList (vl-catch-all-apply 'vlax-safearray->list (list VarValue)))
       (if (not (vl-catch-all-error-p PointList))
        (cond ((= (length PointList) 3)
          (if (< (distance Center Point_01)(distance Center Point_02))
           (vl-catch-all-apply 'vlax-put (list Circle 'Center Point_01))
           (vl-catch-all-apply 'vlax-put (list Circle 'Center Point_02))
          )
         )
         ((= (length PointList) 6)
          (progn (setq Point (list (* (+ (nth 0 PointList)(nth 3 PointList)) 0.5)(* (+ (nth 1 PointList)(nth 4 PointList)) 0.5) (caddr Center)))
           (vl-catch-all-apply 'vlax-put (list Circle 'Center Point))
          )
         )
        )
       )
       (setq index (+ index 1))
      )
     )
    )
    (setq syh (+ syh 1))
   )
   (vl-cmdf ".zoom" "p")
   (alert "完成！")
  )
)
(princ)
)

这是原程序，如何在执行前将直线的Z坐标归0？谁能修改一下添加此功能，谢谢！！

llsheng_73

1. (defun c:ny(/ center circle index lineobj point point_01 point_02 radius ssline syh)
   
2.   (vl-load-com)
   
3.   (setvar "cmdecho" 0)
   
4.   (princ "\n请选取要处理的直线对象")
   
5.   (if(setq ssLine (ssget '((0 . "LINE"))))
   
6.     (progn (setq syh 0)
   
7.       (vl-cmdf ".zoom" "e")
   
8.       (repeat (sslength ssLine)
   
9. (entmod(setq LineObj(ssname ssLine syh)syh(1+ syh)
   
10.        point(entget LineObj)
    
11.        LineObj(vlax-ename->vla-object LineObj)
    
12.        Point_01(cdr(assoc 10 point))
    
13.        Point_01(list(car Point_01)(cadr Point_01)0)
    
14.        Point_02(cdr(assoc 11 point))
    
15.        Point_02(list(car Point_02)(cadr Point_02)0)
    
16.        point(subst(cons 10 Point_01)(assoc 10 point)point)
    
17.        point(subst(cons 11 Point_02)(assoc 11 point)point)))
    
18. (if(setq ssCircle(ssget"F"(list Point_01 Point_02)'((0 . "CIRCLE"))))
    
19.    (progn (setq index 0)
    
20.      (repeat (sslength ssCircle)
    
21.        (entmod(setq Circle (entget(ssname ssCircle index))index(1+ index)
    
22.       radius(cdr(assoc 40 Circle))
    
23.       Center(vlax-curve-getClosestPointTo LineObj (cdr(assoc 10 Circle)) t)
    
24.       center(if(<(distance Point_01 Center)radius)Point_01
    
25.        (if(<(distance Point_02 Center)radius)Point_02 Center))
    
26.       circle(subst(cons 10 Center)(assoc 10 Circle)Circle)))))))
    
27.     (vl-cmdf ".zoom" "p")
    
28.     (alert "完成！")
    
29.     ))
    
30.   (princ)
    
31.   )

(defun c:ny(/ center circle index lineobj point point_01 point_02 radius ssline syh)<br />   (vl-load-com)<br />   (setvar "cmdecho" 0)<br />   (princ "\n请选取要处理的直线对象")<br />   (if(setq ssLine (ssget '((0 . "LINE"))))<br />     (progn (setq syh 0)<br />       (vl-cmdf ".zoom" "e")<br />       (repeat (sslength ssLine)<br /> (entmod(setq LineObj(ssname ssLine syh)syh(1+ syh)<br />        point(entget LineObj)<br />        LineObj(vlax-ename->vla-object LineObj)<br />        Point_01(cdr(assoc 10 point))<br />        Point_01(list(car Point_01)(cadr Point_01)0)<br />        Point_02(cdr(assoc 11 point))<br />        Point_02(list(car Point_02)(cadr Point_02)0)<br />        point(subst(cons 10 Point_01)(assoc 10 point)point)<br />        point(subst(cons 11 Point_02)(assoc 11 point)point)))<br /> (if(setq ssCircle(ssget"F"(list Point_01 Point_02)'((0 . "CIRCLE"))))<br />    (progn (setq index 0)<br />      (repeat (sslength ssCircle)<br />        (entmod(setq Circle (entget(ssname ssCircle index))index(1+ index)<br />       radius(cdr(assoc 40 Circle))<br />       Center(vlax-curve-getClosestPointTo LineObj (cdr(assoc 10 Circle)) t)<br />       center(if(<(distance Point_01 Center)radius)Point_01<br />        (if(<(distance Point_02 Center)radius)Point_02 Center))<br />       circle(subst(cons 10 Center)(assoc 10 Circle)Circle)))))))<br />     (vl-cmdf ".zoom" "p")<br />     (alert "完成！")<br />     ))<br />   (princ)<br />   )

xyp1964

2. (defun c:tt ()
   
3.   (defun dxf (code s1) (cdr (assoc code (entget s1))))
   
4.   (defun 3d2d (pt) (mapcar '+ '(0 0) pt))
   
5.   (princ "\n请选取要处理的直线对象: ")
   
6.   (setq i -1)
   
7.   (if (setq ss (ssget '((0 . "line"))))
   
8.     (while (setq s1 (ssname ss (setq i (1+ i))))
   
9.       (setq p1        (dxf 10 s1)
   
10.             p2        (dxf 11 s1)
    
11.             rad        (angle p1 p2)
    
12.             j        -1
    
13.       )
    
14.       (if (setq ss1 (ssget "f" (list p1 p2) '((0 . "circle"))))
    
15.         (while (setq s2 (ssname ss1 (setq j (1+ j))))
    
16.           (setq        p0  (dxf 10 s2)
    
17.                 p01 (3d2d p0)
    
18.                 p02 (polar p01 (+ rad (* pi 0.5)) 1)
    
19.                 pt  (inters (3d2d p1) (3d2d p2) p01 p02 nil)
    
20.                 pt  (list (car pt) (cadr pt) (caddr p0))
    
21.           )
    
22.           (command "move" s2 "" "non" p0 "non" pt)
    
23.         )
    
24.       )
    
25.     )
    
26.   )
    
27.   (princ)
    
28. )

(defun c:tt ()<br />   (defun dxf (code s1) (cdr (assoc code (entget s1))))<br />   (defun 3d2d (pt) (mapcar '+ '(0 0) pt))<br />   (princ "\n请选取要处理的直线对象: ")<br />   (setq i -1)<br />   (if (setq ss (ssget '((0 . "line"))))<br />     (while (setq s1 (ssname ss (setq i (1+ i))))<br />       (setq p1        (dxf 10 s1)<br />             p2        (dxf 11 s1)<br />             rad        (angle p1 p2)<br />             j        -1<br />       )<br />       (if (setq ss1 (ssget "f" (list p1 p2) '((0 . "circle"))))<br />         (while (setq s2 (ssname ss1 (setq j (1+ j))))<br />           (setq        p0  (dxf 10 s2)<br />                 p01 (3d2d p0)<br />                 p02 (polar p01 (+ rad (* pi 0.5)) 1)<br />                 pt  (inters (3d2d p1) (3d2d p2) p01 p02 nil)<br />                 pt  (list (car pt) (cadr pt) (caddr p0))<br />           )<br />           (command "move" s2 "" "non" p0 "non" pt)<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )

xyp1964

2. 
   
3. (defun c:tt ()
   
4.   (defun dxf (code s1) (cdr (assoc code (entget s1))))
   
5.   (defun 3d2d (pt) (mapcar '+ '(0 0) pt))
   
6.   (defun move (s1 p1 p2)
   
7.     (command "move" s1 "" "non" p1 "non" p2)
   
8.   )
   
9.   (princ "\n请选取要处理的直线对象: ")
   
10.   (setq i -1)
    
11.   (if (setq ss (ssget '((0 . "line"))))
    
12.     (while (setq s1 (ssname ss (setq i (1+ i))))
    
13.       (setq p1 (dxf 10 s1)
    
14.             p2 (dxf 11 s1)
    
15.             p1a (3d2d p1)
    
16.             p2a (3d2d p2)
    
17.             rad (angle p1 p2)
    
18.             j        -1
    
19.       )
    
20.       (move s1 p1 p1a)
    
21.       (if (setq ss1 (ssget "f" (list p1 p2) '((0 . "circle"))))
    
22.         (while (setq s2 (ssname ss1 (setq j (1+ j))))
    
23.           (setq p0  (dxf 10 s2)
    
24.                 p01 (3d2d p0)
    
25.                 p02 (polar p01 (+ rad (* pi 0.5)) 1)
    
26.                 pt  (inters p1a p2a p01 p02 nil)
    
27.                 ;;pt  (list (car pt) (cadr pt) (caddr p0))
    
28.                 rr  (dxf 40 s2)
    
29.                 p3  (cond ((<= (distance p01 p1a) rr) p1a)
    
30.                           ((<= (distance p01 p2a) rr) p2a)
    
31.                           (t pt)
    
32.                     )
    
33.           )
    
34.           (move s2 p0 p3)
    
35.         )
    
36.       )
    
37.     )
    
38.   )
    
39.   (princ)
    
40. )
    

<br /> (defun c:tt ()<br />   (defun dxf (code s1) (cdr (assoc code (entget s1))))<br />   (defun 3d2d (pt) (mapcar '+ '(0 0) pt))<br />   (defun move (s1 p1 p2)<br />     (command "move" s1 "" "non" p1 "non" p2)<br />   )<br />   (princ "\n请选取要处理的直线对象: ")<br />   (setq i -1)<br />   (if (setq ss (ssget '((0 . "line"))))<br />     (while (setq s1 (ssname ss (setq i (1+ i))))<br />       (setq p1 (dxf 10 s1)<br />             p2 (dxf 11 s1)<br />             p1a (3d2d p1)<br />             p2a (3d2d p2)<br />             rad (angle p1 p2)<br />             j        -1<br />       )<br />       (move s1 p1 p1a)<br />       (if (setq ss1 (ssget "f" (list p1 p2) '((0 . "circle"))))<br />         (while (setq s2 (ssname ss1 (setq j (1+ j))))<br />           (setq p0  (dxf 10 s2)<br />                 p01 (3d2d p0)<br />                 p02 (polar p01 (+ rad (* pi 0.5)) 1)<br />                 pt  (inters p1a p2a p01 p02 nil)<br />                 ;;pt  (list (car pt) (cadr pt) (caddr p0))<br />                 rr  (dxf 40 s2)<br />                 p3  (cond ((<= (distance p01 p1a) rr) p1a)<br />                           ((<= (distance p01 p2a) rr) p2a)<br />                           (t pt)<br />                     )<br />           )<br />           (move s2 p0 p3)<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />

xskfq

xyp1964 发表于 2013-12-19 22:29

有两个问题：
1.直线Z坐标仍然没归零。
2.圆内有端点必须把圆心挪在端点上，园内没端点的才挪在直线上（这个已解决）

自贡黄明儒

1. ;;;************************Z坐标归0
   
2. (defun h-gc1 (/ SS)
   
3.   (command "._ucs" "_W")                ;世界坐标系
   
4.   (setq ss (ssget))
   
5.   ;;Z坐标归零,主要是地形线的影响，所以这一个很重要
   
6.   (if ss
   
7.     (vl-cmdf ".MOVE"         ss             ""                 "0,0,0"
   
8.              "0,0,1000e99"             ".MOVE"         "P"
   
9.              ""                 "0,0,1000e99"                 "0,0,0"
   
10.             )
    
11.   )
    
12.   (princ)
    
13. )
    
14. ;;;************************Z坐标归0;;;************************Z坐标归

;;;************************Z坐标归0<br /> (defun h-gc1 (/ SS)<br />   (command "._ucs" "_W")                ;世界坐标系<br />   (setq ss (ssget))<br />   ;;Z坐标归零,主要是地形线的影响，所以这一个很重要<br />   (if ss<br />     (vl-cmdf ".MOVE"         ss             ""                 "0,0,0"<br />              "0,0,1000e99"             ".MOVE"         "P"<br />              ""                 "0,0,1000e99"                 "0,0,0"<br />             )<br />   )<br />   (princ)<br /> )<br /> ;;;************************Z坐标归0;;;************************Z坐标归

xskfq

xyp1964 发表于 2013-12-19 22:29

麻烦高手再改进一下，达到效果如图,第一种才是想要的

xskfq

xyp1964 发表于 2013-12-19 22:29

果然好用！！谢谢了