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

jjww123

Dim object As AcadSolid
ThisDrawing.SetVariable "fillmode", 1
( u$ ~+ F* d# P6 O: ]) DSet object = ThisDrawing.ModelSpace.AddSolid(e点, f点, h点, g点)
  C1 o3 s8 n+ p+ n" I1 |. O  pobject.color = 6
/ E  h; ]9 n" ]4 q' G2 @
5 j( ?: b1 Y  n! N7 C
点已经定义好了。。只要这4个点是二维的。。就可以填充。。。但是如果点定义为三维的就不行。。

高手指点！

woaishuijia

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

jjww123

那如何填充三维的面呢？
. q1 J. K. g, G1 k9 ]- i
我这4个点是在XZ面上的一个四边形。。。
) }# ^4 z$ G. T4 O1 D5 b
[ 本帖最后由 jjww123 于 2009-2-5 11:41 编辑 ]

woaishuijia

需要变换UCS
& K# T3 d8 g$ R' X: D9 M9 j( |5 s

1. 
   
2. Sub A()
   
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
   
5.     With ThisDrawing
   - `1 H3 q& k! q; R, i
6.         '下面4个点用于定义二维填充(solid)对象
   
7.         P1(0) = 0: P1(1) = 0: P1(2) = 0
   ' j& n7 P1 M: V% j
8.         P2(0) = 10: P2(1) = 0: P2(2) = 0
   
9.         P3(0) = 0: P3(1) = 0: P3(2) = 10
   
10.         P4(0) = 10: P4(1) = 0: P4(2) = 10
    0 o1 x! F) x9 f/ @. h5 J1 o
11.         '下面3个点用于定义新的UCS
    ! f; j- @1 a, D( h9 U* u
12.         Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
    ! N" x" Y: p* M0 T
13.         Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
    
14.         Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
    9 U! ?5 v' ~) z7 O9 f
15.         '新建UCS
    . O* S8 v5 A* V: @* I3 y6 P, x
16.         Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
    ( T( G7 x. y4 A1 ~
17.         '新UCS置为当前
    ! |* p) T; Q' y
18.         .ActiveUCS = UCS
    4 y% s; Q; s# h' V
19.         '创建二维填充
    
20.         .ModelSpace.AddSolid P1, P2, P3, P4
    
21.     End With
    
22. End Sub
    

复制代码

" e7 g  O# g! B5 h上面代码中定义二维填充对象的四个点都是世界坐标系WCS。如果这四个点是自定义的用户坐标系UCS上的点，还需要换算坐标，参见下面的代码

1. 
   ( I' x6 \7 p, z; O. l; p( A
2. Sub A()
   : [- }3 s7 v( s) H7 X
3.     Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
   4 {! A; ?6 @6 ]. M$ j
4.     Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
   ( [" g) x% ?$ u* s2 U
5.     With ThisDrawing
     g) t/ z9 q1 c- s, w) j
6.         '下面4个点（相对于XZ平面）用于定义二维填充(solid)对象
   
7.         P1(0) = 0: P1(1) = 0: P1(2) = 0
   
8.         P2(0) = 10: P2(1) = 0: P2(2) = 0
     w- n4 |+ }. N# o) |* y2 i
9.         P3(0) = 0: P3(1) = 10: P3(2) = 0
   
10.         P4(0) = 10: P4(1) = 10: P4(2) = 0
    + a/ C4 n1 h+ \$ m. B7 w
11.         '下面3个点用于定义新的UCS
    - K, @  E1 P. }7 P
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方向
    
15.         '新建UCS
    
16.         Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
    0 ?0 P/ K# m2 O" `" L
17.         '新UCS置为当前
    
18.         .ActiveUCS = UCS
    
19.         '创建二维填充(P1和P2在两个坐标系中没有变化，不必换算；P3和P4从当前UCS换算为WCS才可以，因为addsolid方法的四个点坐标必须是WCS)
    4 q! [; ?; V" \! \# |
20.         .ModelSpace.AddSolid P1, P2, .Utility.TranslateCoordinates(P3, acUCS, acWorld, False), .Utility.TranslateCoordinates(P4, acUCS, acWorld, False)
    # \! a' W7 I( x4 ~  M
21.     End With
    & K  n; T, A) @  q$ l- T* g4 L
22. End Sub
    , `5 p: Z! d+ h( b; D

复制代码

jjww123

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

jjww123

版主您好！请问为什么画出来以后无法显示颜色。。必须要选视图-视觉样式-真实  以后才能显示填充以后的效果？
! E6 M4 v8 U8 A- x
; g* R7 Y+ M5 G- C& X1 E+ |* Q/ k) D
& P, K' {( C* t2 ]/ |& l5 z4 y '下面3个点用于定义新的UCS
6 S- i5 P. a; M6 U' {    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方向
: E9 {* ^4 E+ M, f( @" s# ^
, N0 q; Z! r7 @9 h    '新建UCS
    Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
3 }- S1 I0 F- Z0 l   
    '新UCS置为当前
' K) ^& @6 b. \" a) [+ T    .ActiveUCS = UCS
   
- D% S; a5 J& Q; g/ |   
    Dim object As AcadSolid
   
    Set object = ThisDrawing.ModelSpace.AddSolid(e点, f点, h点, g点)
   
" L! T6 q5 z2 K0 n; D0 @% ~  S    object.color = 6

woaishuijia

“FILLMODE”系统变量设置为1并且视图方向正对着二维实体时才能看到填充。
( w  _2 E: U4 r1 {0 ^! v* l% j可以在上面的代码中再添加两行，如下
; i+ p& R6 Y" {; C) R% c7 c

1. 
   % y9 l  X. A0 K1 s9 }/ o
2. Sub A()
   6 Q  v+ O+ v( D# ]/ |/ I
3.     Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
   4 S" U3 B4 u" C; J$ h
4.     Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
   " A3 D+ h  j$ F; }3 u$ @8 m; U. w- o
5.     With ThisDrawing
   ) k8 b' i4 v, K  J; l- s  z' c, k
6.         '下面4个点用于定义二维填充(solid)对象
   
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
   , A5 J# q- f7 B) x& e% ~1 C' N
10.         P4(0) = 10: P4(1) = 0: P4(2) = 10
    0 N% l; n( W2 K* i8 ~6 k% G- t
11.         '下面3个点用于定义新的UCS
    9 g0 a6 T% ?3 p+ l
12.         Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
    , R; b! C" F  l) d* Q" ^2 K; B$ Y
13.         Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
    , D! s& A& N( W
14.         Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
    
15.         '新建UCS
    
16.         Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
    
17.         '新UCS置为当前
    : ]# u! k- f  U# c- p8 K! A
18.         .ActiveUCS = UCS
    " X; U. S( e' {  H3 x$ \- i, e: z" Z
19.         '创建二维填充
    ' I6 G& H3 W! ]8 t/ X0 _9 C& Z7 Z. A
20.         .ModelSpace.AddSolid P1, P2, P3, P4
    + F, K1 `- u; }
21.         '发送键盘命令，使视图对正当前UCS。注意plan后面有两个半角空格，相当于两次回车
    * @  b# o2 w5 G; V8 l
22.         SendCommand "plan  "
    4 m/ Y( a. g( U. m- x0 ?
23.         '修改系统变量（CAD默认该变量值就是1，如果没有修改过此变量，则此行可以不用）
    6 Z8 j$ @0 i( W' p- \7 q
24.         .SetVariable "fillmode", 1
    
25.     End With
    & H/ H9 J8 q' a8 K: Q1 B
26. End Sub
    

复制代码

jjww123

感谢版主耐心的回答。。
* a- [! w! k% Y" }
! F0 y( r6 s7 M, n结合我另外一贴的问题。。加入以下代码以后。。视图是变了。。但是加上你上面填充的代码之后就乱了。。。

如何在下面代码中添上楼上的填充代码。。并且正确显示呢？
0 K& q8 H6 q. L/ |& Y- |
- }5 L& H2 G4 r

/ n' a: L1 O* t1 wSub A()
, s' P4 ]/ Z# b) E: _3 \, K8 p    Dim V As AcadView, D(2) As Double
    With ThisDrawing
+ Y- i& G1 U* |; _" E" u        '新建视图
        Set V = .Views.Add("AAA")
2 [& q5 ^( X. A# A: _/ m        '设置新视图的方向
        D(0) = -1: D(1) = -1: D(2) = 1
' W7 @  k) j9 G# h. X, D( T        V.Direction = D
        '活动视口设置为该视图
        .ActiveViewport.SetView V
        '重置活动视口
        .ActiveViewport = .ActiveViewport
    End With
    '缩放视图
    ZoomAll
End Sub

ning84

找了很长时间,总算找到这个例子.
, d8 y( ]8 a# [( o' \: X6 Y7 F: v* K关键点
  O. _) P3 a6 w        P4(0) = 10: P4(1) = 0: P4(2) = 10
7 a. ]! V& }5 V+ n/ `* d, a2 d        '下面3个点用于定义新的UCS
        Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
' t7 W  n) h- ?. i0 w        Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
        Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
) H" N# m, w! P6 i9 z        '新建UCS
        Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")