[求助]请高手修改

CTC

2. ;;;问题：请高手帮忙修改下程序，判断2个开始点在一端
   
3. ;;;by cable2004  
   
4. (defun c:tt ( / 1-pt1 1-pt2 2-pt1 2-pt2 ang1 ang2 da db dc dd de earea earea1 ent1-1 ent1-2 ent1-2-l ent1-lst ent2-lst ent-ss h h1 m n  pab pac pba pca  pt0 pt1 pt2 pt3 ptab ptba s s1 ssent1 ssent2)
   
5.   (vl-load-com)
   
6.   (setq osmode_bak (getvar "osmode"))
   
7.   (setvar "osmode" 0)
   
8.   (setvar "cmdecho" 0)
   
9.   (print "\n请选取线：")
   
10.   (setq ent-ss (ssget))
    
11.   (setq ssent1 (ssname ent-ss 0))
    
12.   (setq ssent2 (ssname ent-ss 1))
    
13.   (setq m (getint "\n请输入段数<32>："))
    
14.   (if (null m)
    
15.     (setq m 32)
    
16.   )
    
17.   (setq pt0 (getpoint "\n请指定位置："))
    
18.   (setq ent1-lst (m-fd-lst ssent1 m))
    
19.   (setq ent2-lst (m-fd-lst ssent2 m))
    
20.   (setq ent1-1 (car ent1-lst))
    
21.   (setq ent1-2 (car ent2-lst))
    
22.   (setq ent1-2-l (distance ent1-1 ent1-2))
    
23.   (setq pt1 (polar pt0 (* 0.5 pi) ent1-2-l))
    
24.   (setq n 1)
    
25.   (repeat m
    
26.     (setq 1-pt1 (car ent1-lst))
    
27.     (setq 1-pt2 (cadr ent1-lst))
    
28.     (setq 2-pt1 (car ent2-lst))
    
29.     (setq 2-pt2 (cadr ent2-lst))
    
30.     (setq da (distance 1-pt1 2-pt1))   ; 边1
    
31.     (setq db (distance 1-pt1 1-pt2))   ; 边2
    
32.     (setq dc (distance 2-pt1 1-pt2))   ; 对角线
    
33.     (setq dd (distance 2-pt1 2-pt2))   ; 边3
    
34.     (setq de (distance 1-pt2 2-pt2))   ; 边3
    
35. 
    
36.     (setq ang1 (angle pt0 pt1))
    
37.     (setq s (/ (+ da db dc) 2))                           ; 求s＝(da+db+dc)/2
    
38.     (setq earea (sqrt (* s (- s da) (- s db) (- s dc)))) ; 求面积area=s*(s-d ; a)*(s-db)*(s-dc)^0.5
    
39.     (setq h (/ (* 2 earea) da))                           ; 求三角形高 h=2*area/da
    
40.     (setq pab (sqrt (- (* dc dc) (* h h))))              ; 求高将底边分成的两部分的长度
    
41.     (setq pba (sqrt (- (* db db) (* h h))))
    
42.     (cond
    
43.       ((and
    
44.    (< pab pba)
    
45.    (> pba da)
    
46.        )
    
47.   (setq ptab (polar pt0 (* -1 ang1) pab))
    
48.   (setq pt2 (polar ptab (- ang1 (* 0.5 pi)) h))
    
49.       )
    
50.       ((and
    
51.    (> pab da)
    
52.    (> pab pba)
    
53.        )
    
54.   (setq ptab (polar pt0 ang1 pab))
    
55.   (setq pt2 (polar ptab (- ang1 (* 0.5 pi)) h))
    
56.       )
    
57.       ((and
    
58.    (<= pab da)
    
59.    (<= pba da)
    
60.        )
    
61.   (setq ptab (polar pt0 ang1 pab))
    
62.   (setq pt2 (polar ptab (- ang1 (* 0.5 pi)) h))
    
63.       )
    
64.     )
    
65.     (setq ang2 (angle pt0 pt2))
    
66. 
    
67.     (setq s1 (/ (+ de dc dd) 2))
    
68.     (setq earea1 (sqrt (* s1 (- s1 dc) (- s1 de) (- s1 dd))))
    
69.     (setq h1 (/ (* 2 earea1) dc))
    
70.     (setq pac (sqrt (- (* dd dd) (* h1 h1))))
    
71.     (setq pca (sqrt (- (* de de) (* h1 h1))))
    
72. 
    
73.     (cond
    
74.       ((and
    
75.    (< pac pca)
    
76.    (> pca dc)
    
77.        )
    
78.   (setq ptba (polar pt0 (* -1 ang2) pac))
    
79.   (setq pt3 (polar ptba (- ang2 (* 0.5 pi)) h1))
    
80.       )
    
81.       ((and
    
82.    (> pac dc)
    
83.    (> pac pca)
    
84.        )
    
85.   (setq ptba (polar pt0 ang2 pac))
    
86.   (setq pt3 (polar ptba (- ang2 (* 0.5 pi)) h1))
    
87.       )
    
88.       ((and
    
89.    (<= pac dc)
    
90.    (<= pca dc)
    
91.        )
    
92.   (setq ptba (polar pt0 ang2 pac))
    
93.   (setq pt3 (polar ptba (- ang2 (* 0.5 pi)) h1))
    
94.       )
    
95.     )
    
96.     (m-3dface 1-pt1 1-pt2 2-pt1 2-pt1)
    
97.     (m-3dface 2-pt1 1-pt2 2-pt2 2-pt2)
    
98.     (m-3dface pt0 pt1 pt2 pt2)
    
99.     (m-3dface pt0 pt2 pt3 pt3)
    
100.     (setq ent1-lst (cdr ent1-lst))
     
101.     (setq ent2-lst (cdr ent2-lst))
     
102.     (setq pt1 pt2)
     
103.     (setq pt0 pt3)
     
104.     (setq n (+ 1 n))
     
105. 
     
106.   )
     
107.   (princ)
     
108.   (setvar "osmode" osmode_bak)
     
109.   (alert "检查正反片")
     
110. 
     
111. )
     
112. 
     
113. 
     
114. (defun m-fd-lst (ent1 nn / ent1-sta ent1-end ent1-l ent1-pt ent1-ptlst)
     
115.   (setq i 0)
     
116.   (setq ent1-sta  (vlax-curve-getStartParam (vlax-ename->vla-object ent1) ))
     
117.   (setq ent1-end  (vlax-curve-getEndParam   (vlax-ename->vla-object ent1) ))
     
118.   (setq ent1-l (/ (m-curvelength ent1) nn))
     
119.   (repeat (+ nn 1)
     
120.     (setq ent1-pt (vlax-curve-getpointatdist ent1 (* i ent1-l)))
     
121.     (setq i (+ 1 i))
     
122.     (setq ent1-ptlst (cons ent1-pt ent1-ptlst))
     
123.   )
     
124.   (setq ent1-ptlst (reverse ent1-ptlst))
     
125. )
     
126. (defun m-curvelength (ent / obj)
     
127.   (setq obj (vlax-ename->vla-object ent))
     
128.   (setq len (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)))
     
129.   len
     
130. )
     
131. 
     
132. (defun m-3dface (p1 p2 p3 p4)
     
133.   (entmakex (list (cons 0 "3DFACE") (cons 10 p1) (cons 11 p2) (cons 12 p3)
     
134.       (cons 13 p4)
     
135.       )
     
136.   )
     
137. )
     

;;;问题：请高手帮忙修改下程序，判断2个开始点在一端<br /> ;;;by cable2004  <br /> (defun c:tt ( / 1-pt1 1-pt2 2-pt1 2-pt2 ang1 ang2 da db dc dd de earea earea1 ent1-1 ent1-2 ent1-2-l ent1-lst ent2-lst ent-ss h h1 m n  pab pac pba pca  pt0 pt1 pt2 pt3 ptab ptba s s1 ssent1 ssent2)<br />   (vl-load-com)<br />   (setq osmode_bak (getvar "osmode"))<br />   (setvar "osmode" 0)<br />   (setvar "cmdecho" 0)<br />   (print "\n请选取线：")<br />   (setq ent-ss (ssget))<br />   (setq ssent1 (ssname ent-ss 0))<br />   (setq ssent2 (ssname ent-ss 1))<br />   (setq m (getint "\n请输入段数<32>："))<br />   (if (null m)<br />     (setq m 32)<br />   )<br />   (setq pt0 (getpoint "\n请指定位置："))<br />   (setq ent1-lst (m-fd-lst ssent1 m))<br />   (setq ent2-lst (m-fd-lst ssent2 m))<br />   (setq ent1-1 (car ent1-lst))<br />   (setq ent1-2 (car ent2-lst))<br />   (setq ent1-2-l (distance ent1-1 ent1-2))<br />   (setq pt1 (polar pt0 (* 0.5 pi) ent1-2-l))<br />   (setq n 1)<br />   (repeat m<br />     (setq 1-pt1 (car ent1-lst))<br />     (setq 1-pt2 (cadr ent1-lst))<br />     (setq 2-pt1 (car ent2-lst))<br />     (setq 2-pt2 (cadr ent2-lst))<br />     (setq da (distance 1-pt1 2-pt1))   ; 边1<br />     (setq db (distance 1-pt1 1-pt2))   ; 边2<br />     (setq dc (distance 2-pt1 1-pt2))   ; 对角线<br />     (setq dd (distance 2-pt1 2-pt2))   ; 边3<br />     (setq de (distance 1-pt2 2-pt2))   ; 边3<br /> <br />     (setq ang1 (angle pt0 pt1))<br />     (setq s (/ (+ da db dc) 2))                           ; 求s＝(da+db+dc)/2<br />     (setq earea (sqrt (* s (- s da) (- s db) (- s dc)))) ; 求面积area=s*(s-d ; a)*(s-db)*(s-dc)^0.5<br />     (setq h (/ (* 2 earea) da))                           ; 求三角形高 h=2*area/da<br />     (setq pab (sqrt (- (* dc dc) (* h h))))              ; 求高将底边分成的两部分的长度<br />     (setq pba (sqrt (- (* db db) (* h h))))<br />     (cond<br />       ((and<br />    (< pab pba)<br />    (> pba da)<br />        )<br />   (setq ptab (polar pt0 (* -1 ang1) pab))<br />   (setq pt2 (polar ptab (- ang1 (* 0.5 pi)) h))<br />       )<br />       ((and<br />    (> pab da)<br />    (> pab pba)<br />        )<br />   (setq ptab (polar pt0 ang1 pab))<br />   (setq pt2 (polar ptab (- ang1 (* 0.5 pi)) h))<br />       )<br />       ((and<br />    (<= pab da)<br />    (<= pba da)<br />        )<br />   (setq ptab (polar pt0 ang1 pab))<br />   (setq pt2 (polar ptab (- ang1 (* 0.5 pi)) h))<br />       )<br />     )<br />     (setq ang2 (angle pt0 pt2))<br /> <br />     (setq s1 (/ (+ de dc dd) 2))<br />     (setq earea1 (sqrt (* s1 (- s1 dc) (- s1 de) (- s1 dd))))<br />     (setq h1 (/ (* 2 earea1) dc))<br />     (setq pac (sqrt (- (* dd dd) (* h1 h1))))<br />     (setq pca (sqrt (- (* de de) (* h1 h1))))<br /> <br />     (cond<br />       ((and<br />    (< pac pca)<br />    (> pca dc)<br />        )<br />   (setq ptba (polar pt0 (* -1 ang2) pac))<br />   (setq pt3 (polar ptba (- ang2 (* 0.5 pi)) h1))<br />       )<br />       ((and<br />    (> pac dc)<br />    (> pac pca)<br />        )<br />   (setq ptba (polar pt0 ang2 pac))<br />   (setq pt3 (polar ptba (- ang2 (* 0.5 pi)) h1))<br />       )<br />       ((and<br />    (<= pac dc)<br />    (<= pca dc)<br />        )<br />   (setq ptba (polar pt0 ang2 pac))<br />   (setq pt3 (polar ptba (- ang2 (* 0.5 pi)) h1))<br />       )<br />     )<br />     (m-3dface 1-pt1 1-pt2 2-pt1 2-pt1)<br />     (m-3dface 2-pt1 1-pt2 2-pt2 2-pt2)<br />     (m-3dface pt0 pt1 pt2 pt2)<br />     (m-3dface pt0 pt2 pt3 pt3)<br />     (setq ent1-lst (cdr ent1-lst))<br />     (setq ent2-lst (cdr ent2-lst))<br />     (setq pt1 pt2)<br />     (setq pt0 pt3)<br />     (setq n (+ 1 n))<br /> <br />   )<br />   (princ)<br />   (setvar "osmode" osmode_bak)<br />   (alert "检查正反片")<br /> <br /> )<br /> <br /> <br /> (defun m-fd-lst (ent1 nn / ent1-sta ent1-end ent1-l ent1-pt ent1-ptlst)<br />   (setq i 0)<br />   (setq ent1-sta  (vlax-curve-getStartParam (vlax-ename->vla-object ent1) ))<br />   (setq ent1-end  (vlax-curve-getEndParam   (vlax-ename->vla-object ent1) ))<br />   (setq ent1-l (/ (m-curvelength ent1) nn))<br />   (repeat (+ nn 1)<br />     (setq ent1-pt (vlax-curve-getpointatdist ent1 (* i ent1-l)))<br />     (setq i (+ 1 i))<br />     (setq ent1-ptlst (cons ent1-pt ent1-ptlst))<br />   )<br />   (setq ent1-ptlst (reverse ent1-ptlst))<br /> )<br /> (defun m-curvelength (ent / obj)<br />   (setq obj (vlax-ename->vla-object ent))<br />   (setq len (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)))<br />   len<br /> )<br /> <br /> (defun m-3dface (p1 p2 p3 p4)<br />   (entmakex (list (cons 0 "3DFACE") (cons 10 p1) (cons 11 p2) (cons 12 p3)<br />       (cons 13 p4)<br />       )<br />   )<br /> )<br />

该贴已经同步到 CTC的微博

CTC

图都上传不 了，不知为什么，都没有超出2M。。

langjs

试试
(defun c:tt (/ 1-pt1 1-pt2 2-pt1 2-pt2 ang1 ang2 da db dc dd de earea earea1 ent1-1 ent1-2 ent1-2-l ent1-l ent1-lst ent1-pt ent2-lst
        ent-ss h h1 i l m n osmode_bak pab pac pba pca pt0 pt1 pt2 pt3 ptab ptba s s1 ssent1 ssent2
     )
  (vl-load-com)
  (setq osmode_bak (getvar "osmode"))
  (setvar "osmode" 0)
  (setvar "cmdecho" 0)
  (princ "\n请选取线：")
  (setq ent-ss (ssget))
  (setq ssent1 (ssname ent-ss 0))
  (setq ssent2 (ssname ent-ss 1))
  (setq m (getint "\n请输入段数<32>："))
  (if (null m)
    (setq m 32)
  )
  (setq pt0 (getpoint "\n请指定位置："))
  (setq ent1-lst (m-fd-lst ssent1 m))
  (setq ent2-lst (m-fd-lst ssent2 m))
  (setq pt1 (vlax-curve-getpointatdist ssent1 0))
  (setq pt2 (vlax-curve-getpointatdist ssent2 0))
  (setq pt3 (vlax-curve-getpointatdist ssent2 (m-curvelength ssent2)))
  (if (> (distance pt1 pt2) (distance pt1 pt3))
    (progn
      (setq i 0
     ent2-lst '()
      )
      (setq l (m-curvelength ssent2))
      (setq ent1-l (/ l m))
      (repeat (+ m 1)
(setq ent1-pt (vlax-curve-getpointatdist ssent2 (- l (* i ent1-l))))
(setq i (+ 1 i))
(setq ent2-lst (cons ent1-pt ent2-lst))
      )
      (setq ent2-lst (reverse ent2-lst))
    )
  )
  (setq ent1-1 (car ent1-lst))
  (setq ent1-2 (car ent2-lst))
  (setq ent1-2-l (distance ent1-1 ent1-2))
  (setq pt1 (polar pt0 (* 0.5 pi) ent1-2-l))
  (setq n 1)
  (repeat m
    (setq 1-pt1 (car ent1-lst))
    (setq 1-pt2 (cadr ent1-lst))
    (setq 2-pt1 (car ent2-lst))
    (setq 2-pt2 (cadr ent2-lst))
    (setq da (distance 1-pt1 2-pt1))   ; 边1
    (setq db (distance 1-pt1 1-pt2))   ; 边2
    (setq dc (distance 2-pt1 1-pt2))   ; 对角线
    (setq dd (distance 2-pt1 2-pt2))   ; 边3
    (setq de (distance 1-pt2 2-pt2))   ; 边3
    (setq ang1 (angle pt0 pt1))
    (setq s (/ (+ da db dc) 2))        ; 求s＝(da+db+dc)/2
    (setq earea (sqrt (* s (- s da) (- s db) (- s dc)))) ; 求面积area=s*(s-d ; a)*(s-db)*(s-dc)^0.5
    (setq h (/ (* 2 earea) da))        ; 求三角形高 h=2*area/da
    (setq pab (sqrt (- (* dc dc) (* h h)))) ; 求高将底边分成的两部分的长度
    (if (equal (* db db) (* h h) 0.00001)
      (setq pba 0)
      (setq pba (sqrt (- (* db db) (* h h))))
    )
    (cond
      ((and
  (< pab pba)
  (> pba da)
       )
(setq ptab (polar pt0 (* -1 ang1) pab))
(setq pt2 (polar ptab (- ang1 (* 0.5 pi)) h))
      )
      ((and
  (> pab da)
  (> pab pba)
       )
(setq ptab (polar pt0 ang1 pab))
(setq pt2 (polar ptab (- ang1 (* 0.5 pi)) h))
      )
      ((and
  (<= pab da)
  (<= pba da)
       )
(setq ptab (polar pt0 ang1 pab))
(setq pt2 (polar ptab (- ang1 (* 0.5 pi)) h))
      )
    )
    (setq ang2 (angle pt0 pt2))
    (setq s1 (/ (+ de dc dd) 2))
    (setq earea1 (sqrt (* s1 (- s1 dc) (- s1 de) (- s1 dd))))
    (setq h1 (/ (* 2 earea1) dc))
    (setq pac (sqrt (- (* dd dd) (* h1 h1))))
    (setq pca (sqrt (- (* de de) (* h1 h1))))
    (cond
      ((and
  (< pac pca)
  (> pca dc)
       )
(setq ptba (polar pt0 (* -1 ang2) pac))
(setq pt3 (polar ptba (- ang2 (* 0.5 pi)) h1))
      )
      ((and
  (> pac dc)
  (> pac pca)
       )
(setq ptba (polar pt0 ang2 pac))
(setq pt3 (polar ptba (- ang2 (* 0.5 pi)) h1))
      )
      ((and
  (<= pac dc)
  (<= pca dc)
       )
(setq ptba (polar pt0 ang2 pac))
(setq pt3 (polar ptba (- ang2 (* 0.5 pi)) h1))
      )
    )
    (m-3dface 1-pt1 1-pt2 2-pt1 2-pt1)
    (m-3dface 2-pt1 1-pt2 2-pt2 2-pt2)
    (m-3dface pt0 pt1 pt2 pt2)
    (m-3dface pt0 pt2 pt3 pt3)
    (setq ent1-lst (cdr ent1-lst))
    (setq ent2-lst (cdr ent2-lst))
    (setq pt1 pt2)
    (setq pt0 pt3)
    (setq n (+ 1 n))
  )
  (setvar "osmode" osmode_bak)
  (alert "检查正反片")
  (princ)
)
(defun m-fd-lst (ent1 nn / ent1-end ent1-l ent1-pt ent1-ptlst ent1-sta)
  (setq i 0)
  (setq ent1-sta (vlax-curve-getstartparam (vlax-ename->vla-object ent1)))
  (setq ent1-end (vlax-curve-getendparam (vlax-ename->vla-object ent1)))
  (setq ent1-l (/ (m-curvelength ent1) nn))
  (repeat (+ nn 1)
    (setq ent1-pt (vlax-curve-getpointatdist ent1 (* i ent1-l)))
    (setq i (+ 1 i))
    (setq ent1-ptlst (cons ent1-pt ent1-ptlst))
  )
  (setq ent1-ptlst (reverse ent1-ptlst))
)
(defun m-curvelength (ent / obj)
  (setq obj (vlax-ename->vla-object ent))
  (setq len (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)))
  len
)
(defun m-3dface (p1 p2 p3 p4)
  (entmakex (list (cons 0 "3DFACE") (cons 10 p1) (cons 11 p2) (cons 12 p3) (cons 13 p4)))
)

CTC

langjs 发表于 2012-3-24 23:55
试试
(defun c:tt (/ 1-pt1 1-pt2 2-pt1 2-pt2 ang1 ang2 da db dc dd de earea earea1 ent1-1 ent1-2 ent ...

这个情况又不行了。。，
请输入段数<32>：
请指定位置：Error: 没有为参数定义函数: -1.49214e-013

langjs

CTC 发表于 2012-3-25 00:22
这个情况又不行了。。，
请输入段数：
请指定位置：Error: 没有为参数定义函数: -1.49214e-013

运行你提供的源程序这种情况就有错误

langjs

langjs 发表于 2012-3-25 00:47
运行你提供的源程序这种情况就有错误

重新试试，修改了一下

CTC

langjs 发表于 2012-3-25 09:50
重新试试，修改了一下

好厉害，可以了，改天再给你加分。。。。。谢谢啦。推荐langjs你做 版主。。。

cable2004

如果出项找z方向，上下交错的呢？

yoyoho

不错!学习了!

注册

好复杂的东西