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

jjww123 · 发表于 2009-2-4 23:33:32

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

您需要登录才可以下载或查看，没有帐号？注册

x

Dim object As AcadSolid
ThisDrawing.SetVariable "fillmode", 1
Set object = ThisDrawing.ModelSpace.AddSolid(e点, f点, h点, g点)
object.color = 6

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

高手指点！

woaishuijia · 发表于 2009-2-5 11:14:02

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

jjww123 · 发表于 2009-2-5 11:39:04

那如何填充三维的面呢？

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

[ 本帖最后由 jjww123 于 2009-2-5 11:41 编辑 ]

woaishuijia · 发表于 2009-2-5 13:53:50

需要变换UCS

: J T9 i! v& J6 x* {* [- d) M9 z
Sub A()
; b! Q8 a0 W% g9 a' v5 ]( K( w
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
, E, M8 ^6 O: Q1 \( R; D0 _6 h
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double- u3 t0 J I9 U4 l7 F* M# c
With ThisDrawing$ M: a8 b8 R3 _$ k8 [
'下面4个点用于定义二维填充(solid)对象3 ~. }/ y, V8 ~, D) A7 p, n3 M
P1(0) = 0: P1(1) = 0: P1(2) = 0: [$ ]1 K- |! ~0 h o
P2(0) = 10: P2(1) = 0: P2(2) = 04 f% i5 I$ y' P" ~0 U( q9 N
P3(0) = 0: P3(1) = 0: P3(2) = 10
( o/ O. N: _; p9 k9 q
P4(0) = 10: P4(1) = 0: P4(2) = 10/ `4 [* |) l5 E7 M7 Z8 m( E
'下面3个点用于定义新的UCS& J- N {5 s+ {# H! a
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点 H& O4 b3 q1 ]% g* s( g7 A/ }0 k6 m
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
5 }; K m1 o( L7 T- n
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
* ~! I' B' y2 o
'新建UCS
3 m8 l; E- ` `! B8 t0 p
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA"); E. A2 }1 E. R$ \1 B/ D: F# O3 x
'新UCS置为当前1 T2 V+ O- }- Q: W, ]
.ActiveUCS = UCS
- t7 }0 u2 M' r0 w1 j! {- ~
'创建二维填充2 ?3 B' D5 f+ } L, P
.ModelSpace.AddSolid P1, P2, P3, P49 W& k& e% U& V' C5 Q8 D0 b8 d& y* g
End With" f$ u: J) x' Z, ]) t- y# k
End Sub, {9 Y5 \0 q5 h) [5 h

复制代码

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

+ f' K+ @1 l. w) E( p
Sub A()$ B) f3 q# x, g
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
+ Z/ ~: t( g/ x7 Y# m: [. n/ G+ W
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
# c8 N+ _; d0 l7 f- f" R
With ThisDrawing+ n K' p/ J( f" S3 `) H f
'下面4个点（相对于XZ平面）用于定义二维填充(solid)对象
2 i K: r3 X4 S, q$ ~! F* D
P1(0) = 0: P1(1) = 0: P1(2) = 01 A0 Q3 \( t4 S
P2(0) = 10: P2(1) = 0: P2(2) = 0
" o( ^5 z) P! B' g( E/ i
P3(0) = 0: P3(1) = 10: P3(2) = 0
0 E9 N. N$ Q. [; |+ i: i
P4(0) = 10: P4(1) = 10: P4(2) = 0
" y4 Z/ U' w5 W) o. q' h( S+ p) r
'下面3个点用于定义新的UCS
# |9 l z2 y& N# d8 U7 N, A
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
9 n% W; h' q6 |0 p8 L2 Q7 o; D) R- X
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向" t. b* U8 j ?# l8 T2 F
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向8 K J. w" g, K( v# V. g n6 m& v' m
'新建UCS
M, ]8 O# _5 ?2 f/ ~/ ^
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")5 |" V$ t$ ]+ S
'新UCS置为当前7 a- B0 s4 k. ?4 y- \" e
.ActiveUCS = UCS7 M1 A) t* o8 d" L
'创建二维填充(P1和P2在两个坐标系中没有变化，不必换算；P3和P4从当前UCS换算为WCS才可以，因为addsolid方法的四个点坐标必须是WCS)6 K' l- T- E: b! {7 }! {7 C f
.ModelSpace.AddSolid P1, P2, .Utility.TranslateCoordinates(P3, acUCS, acWorld, False), .Utility.TranslateCoordinates(P4, acUCS, acWorld, False)4 U. \8 X; S2 @( Y; J- J* m2 f
End With
3 W( P, N' M. a0 G
End Sub
' q, N( Q& V# D: s

复制代码

jjww123 · 发表于 2009-2-5 14:11:20

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

jjww123 · 发表于 2009-2-5 14:57:57

版主您好！请问为什么画出来以后无法显示颜色。。必须要选视图-视觉样式-真实以后才能显示填充以后的效果？

'下面3个点用于定义新的UCS
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方向

'新建UCS
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")

'新UCS置为当前
.ActiveUCS = UCS

Dim object As AcadSolid

Set object = ThisDrawing.ModelSpace.AddSolid(e点, f点, h点, g点)

object.color = 6

woaishuijia · 发表于 2009-2-5 16:38:26

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

' x! [2 J, h, @, o" T2 w/ y
Sub A()
2 P6 O8 A0 B" y6 R" Q
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double0 w& k) C# Q8 L" l+ i
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
Q$ N" c" K# ~0 V# V; k9 n
With ThisDrawing
( l8 f- V" l, V+ Y
'下面4个点用于定义二维填充(solid)对象/ c3 Q# g, z9 s2 J' T, }
P1(0) = 0: P1(1) = 0: P1(2) = 0" E5 f6 x' Z* [* f9 m& m- x
P2(0) = 10: P2(1) = 0: P2(2) = 0
" Y) O: B3 C) P5 c* Z
P3(0) = 0: P3(1) = 0: P3(2) = 107 r% }9 f3 n: T" T
P4(0) = 10: P4(1) = 0: P4(2) = 107 P1 h2 V e8 H! B% N, U
'下面3个点用于定义新的UCS+ k) ^3 U) e0 K
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点* [* B% ~! ?1 T5 Y
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
" H9 i5 @" ~3 }* W
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向* ?7 A3 X1 j# x4 R
'新建UCS
3 O/ ^% Q$ T. e2 p+ s
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
/ U1 ]8 h, y" d, I, Y3 U( T
'新UCS置为当前0 I" u4 N, ] [5 G
.ActiveUCS = UCS2 u, T, Y9 y9 a4 d' e1 x2 O
'创建二维填充: R8 _0 m9 ~9 u. a' u3 i* J
.ModelSpace.AddSolid P1, P2, P3, P4( ?1 X1 L1 a9 k/ U( _
'发送键盘命令，使视图对正当前UCS。注意plan后面有两个半角空格，相当于两次回车
/ y2 U- s6 V9 \, Q
SendCommand "plan "1 l- t6 x7 K Z# f) E& u
'修改系统变量（CAD默认该变量值就是1，如果没有修改过此变量，则此行可以不用）3 ?9 u0 o- u, B" h
.SetVariable "fillmode", 1* u `2 R. E- V0 I
End With' c5 b+ W, V c; c( @" p" Z
End Sub3 b- D+ W- c2 p: ^+ _$ R! H' ]: o

复制代码

jjww123 · 发表于 2009-2-5 17:09:42

感谢版主耐心的回答。。

结合我另外一贴的问题。。加入以下代码以后。。视图是变了。。但是加上你上面填充的代码之后就乱了。。。

如何在下面代码中添上楼上的填充代码。。并且正确显示呢？

Sub A()
Dim V As AcadView, D(2) As Double
With ThisDrawing
      '新建视图
      Set V = .Views.Add("AAA")
      '设置新视图的方向
      D(0) = -1: D(1) = -1: D(2) = 1
      V.Direction = D
      '活动视口设置为该视图
      .ActiveViewport.SetView V
      '重置活动视口
      .ActiveViewport = .ActiveViewport
End With
'缩放视图
ZoomAll
End Sub

ning84 · 发表于 2009-7-21 09:03:18

找了很长时间,总算找到这个例子.
关键点
      P4(0) = 10: P4(1) = 0: P4(2) = 10
      '下面3个点用于定义新的UCS
      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方向
      '新建UCS
      Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")

		自动登录	找回密码
密码			注册

通知

[已答复] VBA如何填充一个三维四边形？高手指点~

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

浏览过的版块