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 n2 v8 \& Q; X8 L+ ~& _$ i8 ^# ]8 w
Sub A()
1 i/ o6 b! V4 Z0 h; ^0 {* ^# f
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
. M& K' d/ j! C' i0 F+ s: ~# Q5 U( L
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double# T$ N/ ]4 m9 o
With ThisDrawing+ ]9 S/ M T- \. y1 h
'下面4个点用于定义二维填充(solid)对象) j# g0 X, |6 o6 A+ }6 h
P1(0) = 0: P1(1) = 0: P1(2) = 0' }, A. M0 u! A! {
P2(0) = 10: P2(1) = 0: P2(2) = 0
/ E2 ?$ V+ x9 o* y4 ~
P3(0) = 0: P3(1) = 0: P3(2) = 10/ d3 J+ V2 S+ F
P4(0) = 10: P4(1) = 0: P4(2) = 10
; f A4 L3 X8 r5 B& k
'下面3个点用于定义新的UCS
0 K0 L6 U3 z. J3 o
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
& r! a4 M% U+ |0 ^4 d6 \" Y
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
) R. K. S8 [; a- m" h7 ?* w- m
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
+ b9 l9 ^+ u7 x, Y' q7 p
'新建UCS0 _8 L' v `1 E2 R& T5 [
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
' Y2 B- d, V( k( w! `' {! y5 k
'新UCS置为当前& }4 @' R# R; B: _3 m- e. x$ s
.ActiveUCS = UCS; Q) L0 j+ P% t9 `
'创建二维填充. s, |% _/ f4 S
.ModelSpace.AddSolid P1, P2, P3, P4- o$ E- }7 s: Z9 c6 ?( y3 l
End With
$ @7 P0 ]* p. l: k) a) f! }2 z
End Sub/ B" |3 U8 h* k8 T7 w

复制代码

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

1 U; t0 b- Z4 p0 y6 n
Sub A()( L2 L9 _ u4 B, w
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
: ]: k B6 G% N4 F1 j* H! A7 g' `
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double8 H6 ]1 M2 ^, x0 F7 ]
With ThisDrawing
) |+ I+ D! Q3 T4 P H- y
'下面4个点（相对于XZ平面）用于定义二维填充(solid)对象, Q ]% G. |/ |3 } [1 v* B
P1(0) = 0: P1(1) = 0: P1(2) = 0. H: v& N2 c! R; f& Z. s3 w
P2(0) = 10: P2(1) = 0: P2(2) = 0
4 _/ A+ k Z( U) S
P3(0) = 0: P3(1) = 10: P3(2) = 0$ F w% ]8 X. u- K: G
P4(0) = 10: P4(1) = 10: P4(2) = 09 C4 J9 L% p) j K
'下面3个点用于定义新的UCS5 l* P1 D* D0 X
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点! q$ L* G+ J! F( L. H# y6 f* E
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向/ R+ o) n% O* d0 `, a
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向/ x! o% X5 @- u* a' o0 A6 ~ y3 r
'新建UCS
0 h/ K+ t1 ?6 {% S* K; ~
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")! ?$ |: N. M9 d' N8 | i4 t$ m
'新UCS置为当前
" q4 S7 L! s4 v5 N- H
.ActiveUCS = UCS
% D% ^. r3 c* B5 _) B
'创建二维填充(P1和P2在两个坐标系中没有变化，不必换算；P3和P4从当前UCS换算为WCS才可以，因为addsolid方法的四个点坐标必须是WCS); a6 X6 Y, L4 o% T1 y( b! \
.ModelSpace.AddSolid P1, P2, .Utility.TranslateCoordinates(P3, acUCS, acWorld, False), .Utility.TranslateCoordinates(P4, acUCS, acWorld, False)
: e3 d. D- v5 O1 l( y1 H
End With( b7 m$ F6 D K1 W4 p% \
End Sub1 x2 y5 h% O' v+ b Z0 X

复制代码

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

) k# |) W- ^" X5 }% {
Sub A()
. }7 R1 S( C8 _( {3 I1 z) |
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
7 _% D0 @ J4 |# d4 w5 J3 a; i
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
' _( ~% t( M* m; P& A
With ThisDrawing# S' [: h% c5 W4 G" D% I: ^
'下面4个点用于定义二维填充(solid)对象
0 g" E/ Y* ^: i6 j2 @$ g5 T0 v
P1(0) = 0: P1(1) = 0: P1(2) = 03 K p! _1 D6 b( _: y& S G
P2(0) = 10: P2(1) = 0: P2(2) = 0
, P" ]# f% T. a$ O) \4 G" _( u
P3(0) = 0: P3(1) = 0: P3(2) = 10
- X( g8 U+ h! K7 V: V3 a
P4(0) = 10: P4(1) = 0: P4(2) = 10
! S2 `7 m% u4 _4 A ]
'下面3个点用于定义新的UCS# N6 z9 p$ q2 @$ _1 S2 b' q
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点 h- E: v. l5 _# ?
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
7 @$ k! y. H, ^, H$ C- L- ?1 R
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
4 o+ Y! T- Z. ]& y
'新建UCS9 g4 S% _( {' ] g& ?) Q! ]
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")# a$ j' A: F0 V) x7 c
'新UCS置为当前 T6 {9 h9 { h0 k
.ActiveUCS = UCS
* ^# l! s7 P5 R) w( h6 m* p+ F9 u
'创建二维填充4 X0 _) b6 N; y, R. h1 R$ v9 j8 ?( Y' [
.ModelSpace.AddSolid P1, P2, P3, P4+ {. n. T: m6 _( @6 j
'发送键盘命令，使视图对正当前UCS。注意plan后面有两个半角空格，相当于两次回车* ?, \7 C" s ]/ \
SendCommand "plan ": R; M' V7 F- f9 s, S
'修改系统变量（CAD默认该变量值就是1，如果没有修改过此变量，则此行可以不用）
; a+ G ^$ z5 I7 v
.SetVariable "fillmode", 1
. V* k6 y# w D* F% y0 i u
End With/ x9 v2 ]9 e i T+ x% Z; \
End Sub
5 A3 Z( m8 s) c# F9 j- m

复制代码

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

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

浏览过的版块