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

( `3 H4 |3 S8 U) ]! @2 M7 ^
Sub A()
% p! K, h8 p6 o. I2 }6 A
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
/ J1 g1 V9 ]4 ?8 `6 D$ M. W; X
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double) l8 ]; N5 _! O* _
With ThisDrawing
" \* U9 Y$ \0 G" C* m% z
'下面4个点用于定义二维填充(solid)对象2 G" ~2 \( E9 }+ @
P1(0) = 0: P1(1) = 0: P1(2) = 0
$ N4 a6 v& n0 O# W H l) G( {
P2(0) = 10: P2(1) = 0: P2(2) = 0
4 R& n9 p8 n1 ?' v8 H4 H: X. m8 }
P3(0) = 0: P3(1) = 0: P3(2) = 10
" }0 p" X/ C# V; G
P4(0) = 10: P4(1) = 0: P4(2) = 10: P5 ~4 L' Q* v W. @- @; ^
'下面3个点用于定义新的UCS2 X O1 f! H+ s, t" ?* l; J6 O
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点 J# k. X! e( j( _: }% ]. S
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
- e' ]: w' j3 v6 d' \, O9 v: N
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
8 N2 r5 A4 v! t* b) J( |
'新建UCS6 E# r3 u0 f( d9 C+ M) _
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA"); [* s. H2 w+ `2 j0 N. [! c' W& T
'新UCS置为当前: s. Z g' {, l S6 a
.ActiveUCS = UCS: C$ D& m" b. c
'创建二维填充' T0 _$ j% ~+ ]6 P/ i1 j
.ModelSpace.AddSolid P1, P2, P3, P4) ]* w2 y7 Z5 L0 P
End With
( }9 r0 S8 P* y+ X5 Y
End Sub! a+ p6 `5 Z' A0 C/ m' r; F

复制代码

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

- p3 u8 V' H/ v: e
Sub A()
1 E9 g, [" z9 {& ~% X1 O3 X$ ]* l+ s: v
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double: Q' Q4 _% B6 B4 j+ S' \
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double; R' n' Q, a7 t! J
With ThisDrawing% W& |0 V9 E0 c- z6 x
'下面4个点（相对于XZ平面）用于定义二维填充(solid)对象
6 w! v$ B' J z1 k7 x
P1(0) = 0: P1(1) = 0: P1(2) = 0: Z8 X/ }4 m6 C$ E
P2(0) = 10: P2(1) = 0: P2(2) = 0
4 `/ d6 N& e( v0 C" Z s
P3(0) = 0: P3(1) = 10: P3(2) = 0
2 W% `& x2 Q+ i- f8 U0 h% [
P4(0) = 10: P4(1) = 10: P4(2) = 0
) s1 {) o$ J0 ~1 N9 b' R$ E
'下面3个点用于定义新的UCS- H/ N7 B3 N$ ^
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点- g2 ]8 ]+ k8 E& f1 p& V" I1 p
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向- {2 t9 T) a' A1 f" Z
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向! h- Y: X% m; S w s% N2 r: E
'新建UCS' H! |0 g* T. L$ b- j/ j
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")% `: f3 E+ t4 _) y: d
'新UCS置为当前8 q4 Q( N2 v& j( `% w) @# v
.ActiveUCS = UCS k. e5 d. h, K6 U, `- F2 o
'创建二维填充(P1和P2在两个坐标系中没有变化，不必换算；P3和P4从当前UCS换算为WCS才可以，因为addsolid方法的四个点坐标必须是WCS)
9 p; g4 S. N2 R3 N, f4 }3 ?
.ModelSpace.AddSolid P1, P2, .Utility.TranslateCoordinates(P3, acUCS, acWorld, False), .Utility.TranslateCoordinates(P4, acUCS, acWorld, False)
1 ?8 T3 a) i$ [( A0 ]( K
End With
+ m- i5 r4 O c# l- f% v) A
End Sub) q0 Z, G+ g8 V( A5 L7 x& a. }) x* a

复制代码

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并且视图方向正对着二维实体时才能看到填充。
可以在上面的代码中再添加两行，如下

8 [; _, O9 M; O. V& K* o+ R* b
Sub A()3 T+ ]0 q: }+ R/ O
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double, @2 W5 c/ `6 m" l+ X& P
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
* Y- M% K. s+ d8 i2 @+ h* O
With ThisDrawing
) x |" E7 k+ o& Y8 g
'下面4个点用于定义二维填充(solid)对象
# k8 y9 F2 v8 e; \7 f6 d) U& `5 h
P1(0) = 0: P1(1) = 0: P1(2) = 0
' j& `) T) U8 i0 L4 I9 y+ E
P2(0) = 10: P2(1) = 0: P2(2) = 09 Z* Q0 V( k& P
P3(0) = 0: P3(1) = 0: P3(2) = 10
* |9 L! W6 i( C9 |
P4(0) = 10: P4(1) = 0: P4(2) = 10) `% {! d$ {6 y+ [8 d
'下面3个点用于定义新的UCS) @9 w' |7 b% t$ C
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
, q5 v1 Z" N$ B. a( }- ]+ ~0 Z) j
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向# x9 ?; O) s/ P; k. W; {7 E
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向) }5 M% V/ ~- `8 o' }, S
'新建UCS
$ j5 D! N& z% L" S" E& B5 w8 w8 p
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")$ \1 }5 s: D$ E8 F
'新UCS置为当前0 N) F5 Z% D" j' E$ D" L- P# C& |7 M
.ActiveUCS = UCS# e) ^' l2 @9 e' r! d
'创建二维填充
- u A" Y* y8 W5 X* A9 X! @
.ModelSpace.AddSolid P1, P2, P3, P4" N5 a8 x5 n/ {& k
'发送键盘命令，使视图对正当前UCS。注意plan后面有两个半角空格，相当于两次回车
/ J; \5 @* b( d( k: o
SendCommand "plan "" [/ y3 t/ U/ ?, U
'修改系统变量（CAD默认该变量值就是1，如果没有修改过此变量，则此行可以不用）
( h* Z: A; a' n0 i2 {
.SetVariable "fillmode", 16 \# C% ?. h! E) k" W
End With% Q* y5 }* `* q
End Sub
Z% }0 G+ r: H/ ~

复制代码

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如何填充一个三维四边形？高手指点~

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

浏览过的版块