（完成）[编程申请]：面域(region)变成面（3dface）

lengliqun

求一个有难度的CAD程序，能将4个顶点或3个顶点的面域(region)变成由对应4个顶点或3个顶点的面（3dface）

其4个或3个顶点在同一个水平面内。

yunfengning

好程序，我找了许久了，大家来顶啊！

eachy

2. 
   
3. (defun c:Rt3F (/ ss sl e ne el eel ptl ms *acad*)
   
4.   (setq        ms (vla-get-modelspace
   
5.              (setq *acad* (vla-get-activedocument (vlax-get-acad-object)))
   
6.            )
   
7.   )
   
8.   (if (setq ss (ssget '((0 . "region"))))
   
9.     (progn
   
10.       (vla-startundomark *acad*)
    
11.       (setq sl (sslength ss))
    
12.       (while (> sl 0)
    
13.         (setq e (vlax-ename->vla-object (ssname ss (setq sl (1- sl)))))
    
14.         (setq el (vla-explode e))
    
15.         (if
    
16.           (<= (length (setq eel (safearray-value (variant-value el))))
    
17.               4
    
18.           )
    
19.            (progn
    
20.              (setq ptl (mapcar '(lambda        (x)
    
21.                                   (vlax-curve-getstartpoint x)
    
22.                                 )
    
23.                                eel
    
24.                        )
    
25.              )
    
26.              (if (= (length ptl) 4)
    
27.                (vla-add3dface
    
28.                  ms
    
29.                  (vlax-3d-point (car ptl))
    
30.                  (vlax-3d-point (cadr ptl))
    
31.                  (vlax-3d-point (last ptl))
    
32.                  (vlax-3d-point (caddr ptl))
    
33.                )
    
34.                (vla-add3dface
    
35.                  ms
    
36.                  (vlax-3d-point (car ptl))
    
37.                  (vlax-3d-point (cadr ptl))
    
38.                  (vlax-3d-point (last ptl))
    
39.                  (vlax-3d-point (car ptl))
    
40.                )
    
41.              )
    
42.              (vla-delete e)
    
43.            )
    
44.         )
    
45.         (mapcar 'vla-delete eel)
    
46.       )
    
47.       (vla-endundomark *acad*)
    
48.     )
    
49.   )
    
50.   (princ)
    
51. )

<br /> (defun c:Rt3F (/ ss sl e ne el eel ptl ms *acad*)<br />   (setq        ms (vla-get-modelspace<br />              (setq *acad* (vla-get-activedocument (vlax-get-acad-object)))<br />            )<br />   )<br />   (if (setq ss (ssget '((0 . "region"))))<br />     (progn<br />       (vla-startundomark *acad*)<br />       (setq sl (sslength ss))<br />       (while (> sl 0)<br />         (setq e (vlax-ename->vla-object (ssname ss (setq sl (1- sl)))))<br />         (setq el (vla-explode e))<br />         (if<br />           (<= (length (setq eel (safearray-value (variant-value el))))<br />               4<br />           )<br />            (progn<br />              (setq ptl (mapcar '(lambda        (x)<br />                                   (vlax-curve-getstartpoint x)<br />                                 )<br />                                eel<br />                        )<br />              )<br />              (if (= (length ptl) 4)<br />                (vla-add3dface<br />                  ms<br />                  (vlax-3d-point (car ptl))<br />                  (vlax-3d-point (cadr ptl))<br />                  (vlax-3d-point (last ptl))<br />                  (vlax-3d-point (caddr ptl))<br />                )<br />                (vla-add3dface<br />                  ms<br />                  (vlax-3d-point (car ptl))<br />                  (vlax-3d-point (cadr ptl))<br />                  (vlax-3d-point (last ptl))<br />                  (vlax-3d-point (car ptl))<br />                )<br />              )<br />              (vla-delete e)<br />            )<br />         )<br />         (mapcar 'vla-delete eel)<br />       )<br />       (vla-endundomark *acad*)<br />     )<br />   )<br />   (princ)<br /> )

bsq

请问转为3dface后是不是按同一顺序绘制的？

lengliqun

谢谢斑竹，CAD2002测试，对含三个或四个顶点的封闭PL线形成的面域可用没问题，否则四个顶点面域可能形成三个顶点的面。请下载附件测试。请改进，再谢。

eachy

命令: Rt3F

lengliqun

CAD2002测试能用，谢谢。

周大

cad2006呢？

sujia

不用炸开也可以提取点坐标,