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

, `+ H: p# F2 N: U5 i8 t/ S+ i C% m
Sub A()
5 I) n: y+ u+ G- A @9 r+ P
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
: I7 {! u( Y1 n& g& g& m5 ?. X: n
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double% g- \) E. J/ G# H5 P9 z
With ThisDrawing8 y2 E r+ y9 x9 R0 z. C
'下面4个点用于定义二维填充(solid)对象
8 V# h/ v2 g( K4 ]0 z/ T
P1(0) = 0: P1(1) = 0: P1(2) = 0
5 E( {8 h, k: s! ?- D7 t
P2(0) = 10: P2(1) = 0: P2(2) = 0+ l t2 ] ~, ~
P3(0) = 0: P3(1) = 0: P3(2) = 10, ~! h+ ~9 p% v4 p/ t
P4(0) = 10: P4(1) = 0: P4(2) = 103 f3 T5 G* Y5 V) Z B2 e" d3 J
'下面3个点用于定义新的UCS
4 G& }4 q+ p- P
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点. z3 @ N8 ^$ J, F: h5 A
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
" J5 T# u% v, V& O* J
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
K" }4 M8 O. t# J) x0 b6 c
'新建UCS/ q. j7 c, B. m8 z8 n% r$ t
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
( t) b8 v. x1 B* v: b5 ]
'新UCS置为当前
& @, H! e! {5 b( b
.ActiveUCS = UCS# V* f' F* T2 c) i, ~
'创建二维填充
' U8 O9 u0 s. W7 Y) y4 ?* A
.ModelSpace.AddSolid P1, P2, P3, P4
4 L P* b0 I, z+ H6 U' R9 G3 s6 e1 J
End With. J2 I8 }0 C! m& {8 C+ N. A
End Sub; A6 C7 A6 [' e, \) b+ G

复制代码

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

% X! ^; v) U2 C# u1 Z
Sub A(). q- F! B- B/ J, r
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double2 B& l+ O" m9 e
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
% s. e. j4 @& U1 Q$ m
With ThisDrawing
4 h ~) H2 _6 C! G3 E
'下面4个点（相对于XZ平面）用于定义二维填充(solid)对象! k* Q5 K; q' M" K9 [" B2 K
P1(0) = 0: P1(1) = 0: P1(2) = 0
( [' b! q6 w4 s& w) h
P2(0) = 10: P2(1) = 0: P2(2) = 0
2 `, N8 k7 \6 B! `" |
P3(0) = 0: P3(1) = 10: P3(2) = 0
8 s' M$ z$ i" q" Y5 O
P4(0) = 10: P4(1) = 10: P4(2) = 0+ H' C4 W! l/ F; T( Y
'下面3个点用于定义新的UCS
4 G2 n) q( N# P/ V! _- s) }
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
8 t) I3 R5 y1 t6 {1 @, Z
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
7 R9 Y2 _& o7 Z
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
. C( a& x+ C" F e$ W; S1 w# T
'新建UCS
8 E$ X# |3 S4 v* p* f/ t4 q5 T8 S
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
9 W( R1 ]% a# ]& \; g
'新UCS置为当前
2 a$ t7 A; a \5 j
.ActiveUCS = UCS
6 W5 ^ ^6 _4 J/ y7 M
'创建二维填充(P1和P2在两个坐标系中没有变化，不必换算；P3和P4从当前UCS换算为WCS才可以，因为addsolid方法的四个点坐标必须是WCS)7 y. w$ i# M) D$ V
.ModelSpace.AddSolid P1, P2, .Utility.TranslateCoordinates(P3, acUCS, acWorld, False), .Utility.TranslateCoordinates(P4, acUCS, acWorld, False)
+ y% T! M+ q" i* \2 j+ `
End With
4 h' R4 t: X5 E( S
End Sub- T5 {+ y1 O( P; t( h% ]' o

复制代码

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

/ X7 c' B5 {7 Q, J
Sub A()
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
4 C" g+ l# [, p* s9 o
Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
0 k: j$ G% W$ ^* M3 d+ ]$ `3 Z
With ThisDrawing
; e% R; F, T" `4 D" L# ^
'下面4个点用于定义二维填充(solid)对象
- i% ?8 m- s# b% G
P1(0) = 0: P1(1) = 0: P1(2) = 0# Y! `1 n1 S3 E+ T4 G
P2(0) = 10: P2(1) = 0: P2(2) = 0
- `3 y M6 D5 W% ^: k
P3(0) = 0: P3(1) = 0: P3(2) = 105 \' ^ y. h5 B7 F: D% q2 p- S
P4(0) = 10: P4(1) = 0: P4(2) = 10
) \* q6 i9 K: m+ C4 I8 w9 l
'下面3个点用于定义新的UCS# r" e! d. I9 `( H4 N% ?
Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点: E2 C1 f7 E- k; b0 \6 L4 C3 V: S
Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向8 b% I5 ]# v+ q# x9 s1 S
Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
9 r$ w. v/ Y: J. c' P# a% I& _
'新建UCS
' B9 v- b5 j) q7 ]* @% V
Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
4 W( ]: R# O$ R" g! t
'新UCS置为当前
) c- D- L! q" i) [, V4 O. S2 l8 J
.ActiveUCS = UCS' e/ m; Z/ g6 a8 E' D
'创建二维填充! G* ~: O' A1 G: M, G0 _. K$ `
.ModelSpace.AddSolid P1, P2, P3, P4
" l5 q3 [" {1 }7 `: i. K
'发送键盘命令，使视图对正当前UCS。注意plan后面有两个半角空格，相当于两次回车0 }& L9 n* Z- M' M9 M
SendCommand "plan "
5 m+ u, D/ O9 _+ B2 w
'修改系统变量（CAD默认该变量值就是1，如果没有修改过此变量，则此行可以不用）9 v" |3 J/ `! R8 \/ K9 t8 W8 f
.SetVariable "fillmode", 1( q$ J u. {$ M* i+ c3 C
End With P) Y& j$ U- Z/ d: `
End Sub; d ^# g. ~& T) W x* \

复制代码

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

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

浏览过的版块