能不能用VBA把下面2个图帮我做一下

ghostcheng

请哪为高人 能不能把下面2个图帮我做一下可以吗？

ghostcheng

要求是用VBA  编码 做的    我先谢谢了。

woaishuijia

第一个图

1. 
   
2. Sub A()
   7 B% {0 v0 f# [" Y7 f$ s! j
3.     Dim PL(0) As AcadLWPolyline, Ps(17) As Double, R As Variant, P(2) As Double, D(2) As Double
   
4.     With ThisDrawing
   
5.    
   
6.         '转换到世界坐标系WCS
   
7.         SendCommand "ucs w "
   % r( Q2 F/ a- o% Q
8.         
     i* m5 D/ [" ]) p- J8 x) X  E+ y
9.         '定义优化多段线的顶点坐标
   ! [( h1 c/ T$ m
10.         Ps(0) = 30: Ps(1) = 0
    
11.         Ps(2) = 100: Ps(3) = 0
    
12.         Ps(4) = 100: Ps(5) = 25
    9 |  N- e, L( x1 t) K: v6 k0 e
13.         Ps(6) = 95: Ps(7) = 30
    
14.         Ps(8) = 65: Ps(9) = 30
    
15.         Ps(10) = 60: Ps(11) = 35
    ' I/ h: e% E5 i! q" P& `
16.         Ps(12) = 60: Ps(13) = 95
    
17.         Ps(14) = 55: Ps(15) = 100
    
18.         Ps(16) = 30: Ps(17) = 100
    
19.         
    " j: P3 f- e2 v/ J! ~
20.         '创建优化多段线
    ) i/ l, R# g( c4 e5 n  c4 Q
21.         Set PL(0) = .ModelSpace.AddLightWeightPolyline(Ps)
    ! h# D* m; e1 E9 ]: V7 q
22.         
    
23.         '多段线闭合
    9 [+ _! m* B/ J
24.         PL(0).Closed = True
    ' @/ B" [* U1 W6 M" C3 L
25.         
    
26.         '多段线第3、4顶点间部分改为90度圆弧
      a5 T) J' h- e, K( ?1 Y6 S8 m7 ]
27.         PL(0).SetBulge 2, Tan(.Utility.AngleToReal(22.5, acDegrees))
    ( s9 X$ A8 a: W( d7 V( ?/ B
28.         
    7 g4 f7 K& b: y$ g6 J, B' H- X
29.         '多段线第5、6顶点间部分改为90度凹进圆弧
    
30.         PL(0).SetBulge 4, -Tan(.Utility.AngleToReal(22.5, acDegrees))
    . ]( ^' ~7 n. Q1 M4 \: ~& ~' m2 y" \
31.         
    3 o: M; E! p# K3 \5 _9 X) {
32.         '多段线第7、8顶点间部分改为90度圆弧
    . l: N  h) U* Q6 V$ I2 n& r/ }
33.         PL(0).SetBulge 6, Tan(.Utility.AngleToReal(22.5, acDegrees))
    
34.         
    7 k& x5 ^, p% E
35.         '用多段线做面域
    ; u9 l/ b' t3 ^- ]# b$ T
36.         R = .ModelSpace.AddRegion(PL)
    ' |  T- B8 _7 K1 j  k4 y
37.         
    
38.         '定义旋转轴起点
    . ], z8 m( _3 a: Q3 b
39.         P(0) = 0: P(1) = 0: P(2) = 0
    
40.         
    3 z1 {) h- d4 ^9 J
41.         '定义旋转轴方向
    
42.         D(0) = 0: D(1) = 1: D(2) = 0
    
43.         
    & S$ Z& i6 E" ^* m& t2 {7 s: c1 Z# O
44.         '旋转360度建模
    & O! \  T, U/ S3 e' l8 Z) T( e
45.         .ModelSpace.AddRevolvedSolid R(0), P, D, .Utility.AngleToReal(180, acDegrees) * 2
    
46.     End With
    6 b* ^0 Y, @  d! q7 G, d  i
47. End Sub
    

复制代码

[ 本帖最后由 woaishuijia 于 2009-2-7 20:49 编辑 ]

woaishuijia

第二个图

1. 
   0 e8 A0 V" y; Z5 |( V: z+ u
2. Sub A()
   
3.     Dim PL(0) As AcadLWPolyline, Ps(11) As Double, C(0) As AcadCircle, P(2) As Double
   + {/ u% X. q$ F7 K$ C! k
4.     Dim R1 As Variant, R2 As AcadRegion
   
5.     Dim S1 As Acad3DSolid, S2 As Acad3DSolid
   ' L$ \: {/ y8 Y; Q' k9 @
6.     Dim UCS As AcadUCS, Xp(2) As Double, Yp(2) As Double
   
7.     With ThisDrawing
   6 G! j9 ^& T- _5 P. a
8.    
   7 ?/ \4 t% K, H. o/ \2 V' A2 W
9.         '转换到世界坐标系WCS
   
10.         SendCommand "ucs w "
    / {1 q5 l: c) y+ n2 P. Z, \0 b
11.         
    5 ]7 D! r  |% Q- u/ t/ Q
12.         '定义优化多段线的顶点坐标
    
13.         Ps(0) = -7: Ps(1) = -12
    
14.         Ps(2) = 7: Ps(3) = -12
    7 i* d- R) o1 |  X! B; ^
15.         Ps(4) = 12: Ps(5) = -7
    ! S) y' V4 S6 ~
16.         Ps(6) = 12: Ps(7) = 0
    
17.         Ps(8) = -12: Ps(9) = 0
    
18.         Ps(10) = -12: Ps(11) = -7
    
19.         
    2 `$ W' m* B6 x7 h% U4 f& U
20.         '创建优化多段线
    2 T; ~& p5 y) d
21.         Set PL(0) = .ModelSpace.AddLightWeightPolyline(Ps)
    5 X9 J6 B9 [# N9 b# Q) {2 e
22.         
    # e) s" c' v" ?" k* o) b
23.         '多段线闭合
    
24.         PL(0).Closed = True
    
25.         
    
26.         '多段线第2、3顶点间部分改为90度圆弧
    
27.         PL(0).SetBulge 1, .Utility.AngleToReal(22.5, acDegrees)
    
28.         
    0 K3 a+ S8 `" n; T' L* C2 `) [. H
29.         '多段线第4、5顶点间部分改为180度圆弧
    
30.         PL(0).SetBulge 3, 1
    
31.                
    0 U  p" Y& o4 Z7 J# C
32.         '多段线第6、1顶点间部分改为90度圆弧
    ! T# F) {, d) w7 s3 H
33.         PL(0).SetBulge 5, .Utility.AngleToReal(22.5, acDegrees)
    2 y1 Y/ Q: n6 {" I. T9 D
34.         
    
35.         '用多段线做面域
    - [$ h0 w0 R6 c( g/ E) e
36.         R1 = .ModelSpace.AddRegion(PL)
    
37.         
    ( Z) V* @1 R/ }  O
38.         '把面域赋值给R2，便于下步使用
    
39.         Set R2 = R1(0)
    $ H' z! p, l' t& V2 F- V
40.         
    ; n/ M4 w$ I9 O, m5 E# N8 B. X1 G. C
41.         '以原点为圆心，半径10画圆
    , i: g$ w7 |  @1 r+ i
42.         Set C(0) = .ModelSpace.AddCircle(P, 10)
    
43.         
    ( K; v8 M. L/ _5 Q. K
44.         '用圆做面域
    * E& l7 |* x  k  N. J# n
45.         R1 = .ModelSpace.AddRegion(C)
    & W5 m8 p% ?7 p4 Z' O' H- L' S; V+ E
46.         
    5 B  P4 Y+ Z8 Y( y1 ^; F7 V
47.         '多段线做成的面域与圆做成的面域差集
    
48.         R2.Boolean acSubtraction, R1(0)
    
49.         
    ; J# K  s5 g1 P( b4 ~4 r
50.         '把面域拉伸为三维实体S1，高度50
    
51.         Set S1 = .ModelSpace.AddExtrudedSolid(R2, 50, 0)
    
52.         
    
53.         '新建UCS，原世界坐标系WCS的XZ平面为新UCS“AAA”的XY平面，原点不变
    
54.         Xp(0) = 1: Xp(1) = 0: Xp(2) = 0
    
55.         Yp(0) = 0: Yp(1) = 0: Yp(2) = 1
    4 x) `9 N, W9 L6 X2 O$ Z2 _" x( ?. }3 B
56.         Set UCS = .UserCoordinateSystems.Add(P, Xp, Yp, "AAA")
    
57.         
    ( {- `/ n6 f- a2 s+ O0 p) V
58.         '把UCS“AAA”置为当前
    4 P/ S: Y* U2 {5 n: l
59.         .ActiveUCS = UCS
    
60.         
    
61.         '以世界坐标系(0,12,10)为圆心，半径2画圆
    
62.         P(0) = 0: P(1) = 12: P(2) = 10
    7 M  Z2 J3 X; a! }
63.         Set C(0) = .ModelSpace.AddCircle(P, 2)
    4 A4 R- ~) Z% F% j8 w" ^
64.         
    
65.         '把该圆做成面域
    $ c* ]- N( g% f# e
66.         R1 = .ModelSpace.AddRegion(C)
    
67.         
    6 H' K0 f% j; u
68.         '拉伸该面域为三维实体S2，高度24
    " k# y5 E2 C8 W5 m! w, \! Q  w! m
69.         Set S2 = .ModelSpace.AddExtrudedSolid(R1(0), 24, 0)
    # O- ^- o9 C+ d! w- {- ^
70.         
    - x% R" V$ }" {1 A3 [
71.         'S1与S2差集，新实体为S1
    
72.         S1.Boolean acSubtraction, S2
    6 ~$ X* g& d0 b( p+ x
73.         
    
74.         '以世界坐标系(0,12,40)为圆心，半径2画圆
    
75.         P(0) = 0: P(1) = 12: P(2) = 40
    & t- x1 P+ f/ U: ^" `
76.         Set C(0) = .ModelSpace.AddCircle(P, 2)
    
77.         
    # ]: Y! c0 I* P' l, D
78.         '把该圆做成面域
    
79.         R1 = .ModelSpace.AddRegion(C)
    
80.         
    
81.         '拉伸该面域为三维实体S2，高度24
    
82.         Set S2 = .ModelSpace.AddExtrudedSolid(R1(0), 24, 0)
    7 L$ @# H( W. a; p) i: @
83.         
    
84.         '差集
    ) Q( B0 }7 E! ~* b* M* H: E/ z+ l
85.         S1.Boolean acSubtraction, S2
    3 Q% j6 \0 q2 Z8 M  B1 T9 c; l7 h" c
86.     End With
    8 S2 u0 Z5 }0 D9 J( e& ]4 B
87. End Sub
    * m. U! @5 N  @

复制代码