VBA如何填充一个三维四边形？高手指点~

jjww123

Dim object As AcadSolid
ThisDrawing.SetVariable "fillmode", 1
# R4 m  @5 h4 ?9 qSet object = ThisDrawing.ModelSpace.AddSolid(e点, f点, h点, g点)
object.color = 6
* q  a: P0 d) |: H, n

点已经定义好了。。只要这4个点是二维的。。就可以填充。。。但是如果点定义为三维的就不行。。

高手指点！

woaishuijia

solid（二维填充）对象本来就是二维的

jjww123

那如何填充三维的面呢？

我这4个点是在XZ面上的一个四边形。。。

; ]$ r7 e5 ]5 A; j( A4 H[ 本帖最后由 jjww123 于 2009-2-5 11:41 编辑 ]

woaishuijia

需要变换UCS

1. 
   ) R7 R- U9 `" `0 D* z9 Q+ ?" K% a
2. Sub A()
   & p& {5 b3 t2 W( t. v/ c; ~
3.     Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
   6 g) z, Z5 L3 q  M3 ?7 [) Z' d/ K
4.     Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
   
5.     With ThisDrawing
   0 L) z* l% G; N7 [9 X1 Y
6.         '下面4个点用于定义二维填充(solid)对象
   ( @& V  ]3 j. Y6 g
7.         P1(0) = 0: P1(1) = 0: P1(2) = 0
   
8.         P2(0) = 10: P2(1) = 0: P2(2) = 0
   
9.         P3(0) = 0: P3(1) = 0: P3(2) = 10
   1 Y! [  l7 Y" [4 [7 E
10.         P4(0) = 10: P4(1) = 0: P4(2) = 10
    
11.         '下面3个点用于定义新的UCS
    
12.         Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
    
13.         Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
    
14.         Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
    ( P9 t* u* X/ r, m5 e. B4 N
15.         '新建UCS
    
16.         Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
      d( Q* F  n- C" o/ j- [! c
17.         '新UCS置为当前
    
18.         .ActiveUCS = UCS
    8 b) _+ n  ~  }# r! o$ ]* g2 b7 F
19.         '创建二维填充
    
20.         .ModelSpace.AddSolid P1, P2, P3, P4
    2 u6 P$ R5 q8 P! b
21.     End With
    5 U* }# \1 S5 d; ]& q
22. End Sub
    / a$ n% n' S& @1 b  n/ R' Y

复制代码

# j" G9 T% h) }* x1 n$ c( a
. V# ?0 k& z7 W& r. ~上面代码中定义二维填充对象的四个点都是世界坐标系WCS。如果这四个点是自定义的用户坐标系UCS上的点，还需要换算坐标，参见下面的代码
2 G5 X$ r4 O' v( f

1. 
   5 e! S7 h, J2 t# i6 M
2. Sub A()
   * h- e- T, L$ x8 y. l' s
3.     Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
   
4.     Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
   ! z; g3 @9 j( g- y2 m
5.     With ThisDrawing
   * g+ v5 o) H5 [% Q
6.         '下面4个点（相对于XZ平面）用于定义二维填充(solid)对象
   
7.         P1(0) = 0: P1(1) = 0: P1(2) = 0
   / m% `: |" I3 {$ H7 F, b; @: R
8.         P2(0) = 10: P2(1) = 0: P2(2) = 0
   
9.         P3(0) = 0: P3(1) = 10: P3(2) = 0
   
10.         P4(0) = 10: P4(1) = 10: P4(2) = 0
    7 |8 q% Q) E# `* ]9 Q! \
11.         '下面3个点用于定义新的UCS
    8 b8 n2 b  K; H8 T% _
12.         Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
    
13.         Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
    ! I, U, c- _4 l# P& [, c
14.         Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
    
15.         '新建UCS
    % W" i; C$ h# |4 U( u$ C
16.         Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
    
17.         '新UCS置为当前
    
18.         .ActiveUCS = UCS
    , l( Z# m) N4 ^  O# z& Z7 E3 b7 n2 z
19.         '创建二维填充(P1和P2在两个坐标系中没有变化，不必换算；P3和P4从当前UCS换算为WCS才可以，因为addsolid方法的四个点坐标必须是WCS)
    ( a1 i0 k$ |1 z
20.         .ModelSpace.AddSolid P1, P2, .Utility.TranslateCoordinates(P3, acUCS, acWorld, False), .Utility.TranslateCoordinates(P4, acUCS, acWorld, False)
    & f6 k  X6 A9 V5 F: R+ J
21.     End With
    
22. End Sub
    ) I3 N2 D! |* K8 b" A

复制代码

jjww123

哇。。太感谢了！太谢谢了！我慢慢看。。。。先回帖！

jjww123

版主您好！请问为什么画出来以后无法显示颜色。。必须要选视图-视觉样式-真实  以后才能显示填充以后的效果？
/ H6 `; b. S! B1 @$ V7 x! l

1 k: V$ J  N3 u3 H  A5 q/ o* Q '下面3个点用于定义新的UCS
9 w# V; C4 G+ D( z( R) B    Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
    Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
    Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向

+ d0 Y, z. ]6 V0 `! v    '新建UCS
    Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
   
. Z( \4 X# b9 l' A+ y# H    '新UCS置为当前
    .ActiveUCS = UCS
   
   
7 S% w7 s: K, t4 t    Dim object As AcadSolid
! C8 w% Q6 Z2 W( ~3 q! R   
6 l: r* H8 V& q% c! L$ p& ^    Set object = ThisDrawing.ModelSpace.AddSolid(e点, f点, h点, g点)
   
    object.color = 6

woaishuijia

“FILLMODE”系统变量设置为1并且视图方向正对着二维实体时才能看到填充。
可以在上面的代码中再添加两行，如下

1. 
   . h8 o* X  `6 _9 V7 F$ {# I
2. Sub A()
   . y- `/ w" v4 M( w. [; ]
3.     Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
   1 i  B! f+ E7 g7 n4 q
4.     Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
   4 X4 f, R- l1 q  w
5.     With ThisDrawing
   
6.         '下面4个点用于定义二维填充(solid)对象
   
7.         P1(0) = 0: P1(1) = 0: P1(2) = 0
     o0 V) ~7 ~+ I
8.         P2(0) = 10: P2(1) = 0: P2(2) = 0
   ' Z& u+ M' b3 h) l1 Q4 H5 K! V6 i
9.         P3(0) = 0: P3(1) = 0: P3(2) = 10
   
10.         P4(0) = 10: P4(1) = 0: P4(2) = 10
    
11.         '下面3个点用于定义新的UCS
    0 s# x4 D+ t* C: v/ B9 J. D) V8 p* y- ^3 ^3 a
12.         Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
    , C* A  K3 v, q. n0 _# c
13.         Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
    % f; o6 C! t+ e" O8 i) ]
14.         Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
    , v. d- A5 F3 p7 q: K% m0 [
15.         '新建UCS
    # @5 v  O' d; o6 v
16.         Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
    / Z5 p5 a* ]$ M$ N1 \* }# `9 k2 x& e
17.         '新UCS置为当前
    : j; X9 A4 [: w! A7 N
18.         .ActiveUCS = UCS
    
19.         '创建二维填充
    
20.         .ModelSpace.AddSolid P1, P2, P3, P4
    , W( `  o$ f) f
21.         '发送键盘命令，使视图对正当前UCS。注意plan后面有两个半角空格，相当于两次回车
    0 i) H$ E2 l' C3 N  M" \
22.         SendCommand "plan  "
    
23.         '修改系统变量（CAD默认该变量值就是1，如果没有修改过此变量，则此行可以不用）
    ' Y. m4 i+ u. N6 L2 y$ C
24.         .SetVariable "fillmode", 1
    
25.     End With
    
26. End Sub
    1 O; V; }% V/ a2 ?

复制代码

jjww123

感谢版主耐心的回答。。
0 j4 M( a6 f" U% G6 z
1 ]. R- I- }" s; X" U: K6 G结合我另外一贴的问题。。加入以下代码以后。。视图是变了。。但是加上你上面填充的代码之后就乱了。。。
$ s& f, Z+ X- ]
3 `" U9 C! L  |; _$ m如何在下面代码中添上楼上的填充代码。。并且正确显示呢？

* ?0 z- H9 Y, }
7 ~2 h* U: T- @& s' X/ ^
Sub A()
    Dim V As AcadView, D(2) As Double
$ `% p$ D( t7 @3 c$ e    With ThisDrawing
        '新建视图
! E0 Y' l  ~; ?        Set V = .Views.Add("AAA")
        '设置新视图的方向
        D(0) = -1: D(1) = -1: D(2) = 1
& w9 Y% E6 C  r5 `, D0 M* ]        V.Direction = D
: @! @$ v/ d, {3 \& Y) `5 z        '活动视口设置为该视图
        .ActiveViewport.SetView V
        '重置活动视口
) C) D8 k+ S+ S  |        .ActiveViewport = .ActiveViewport
    End With
    '缩放视图
    ZoomAll
End Sub

ning84

找了很长时间,总算找到这个例子.
; z& c) c) U9 x2 z关键点
! \4 {% ^! d; J$ I1 w) M        P4(0) = 10: P4(1) = 0: P4(2) = 10
2 m0 q1 Q! p5 D' i# T" d7 i# [        '下面3个点用于定义新的UCS
2 n0 `8 ]( Y' @: Y' C5 n        Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
        Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
0 U3 r" x: L0 O! \' T% G        Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
        '新建UCS
        Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")