如何用VBA标注一个三维长方体尺寸？

jjww123

请版主举一个例子。。。给我参考下。。

' i+ h  X/ R6 d非常感谢！

jjww123

继续求助。。。请版主就下面的代码。。帮我标注下这个长方体

- r% x7 z( {( W" Z" n! K0 s# \, fcenter1(0) = 1: center1(1) = 1: center1(2) = 1
length = 2: width = 2: height = 4
Set boxobj1 = ThisDrawing.ModelSpace.AddBox(center1, length, width, height)

) N- G- i& y" M麻烦帮帮忙~~谢谢！

woaishuijia

1. 
   ' s5 C8 D+ w0 E) N  X" T2 C
2. Dim Center1(2) As Double, Length As Double, Width As Double, Height As Double, Boxobj1 As Acad3DSolid
   
3. Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, Ucs As AcadUCS
   
4. With ThisDrawing
   
5.     Center1(0) = 1: Center1(1) = 1: Center1(2) = 1
   ; A2 v# I4 Z' T  x8 B
6.     Length = 2: Width = 2: Height = 4
   
7.     Set Boxobj1 = .ModelSpace.AddBox(Center1, Length, Width, Height)
   
8.    
   # {# B% t$ Y& U+ R8 ]2 T2 P5 G
9.     P1(0) = Center1(0): P1(1) = Center1(1): P1(2) = Center1(2) + Height / 2 '新UCS原点
     m+ B/ q; j5 M, T8 g4 c. V
10.     P2(0) = P1(0) + 1: P2(1) = P1(1): P2(2) = P1(2) '新UCS的X方向,与WCS的X方向相同
    
11.     P3(0) = P1(0): P3(1) = P1(1) + 1: P3(2) = P1(2) '新UCS的Y方向,与WCS的Y方向相同
    6 c  I0 {+ Y1 V6 ]; R1 S+ a
12.     Set Ucs = .UserCoordinateSystems.Add(P1, P2, P3, "U") '新建UCS
    + M8 X* b- a( _( e+ ]
13.     .ActiveUCS = Ucs  '新UCS置为当前
    $ r5 \2 H7 @# N, F$ i
14.    
    
15.     SendCommand "dimlinear  0," & -Width / 2 & " 0," & -Width / 2 - 1 & " "
    
16.     SendCommand "dimlinear  " & -Length / 2 & ",0 " & -Length / 2 - 1 & ",0 "
    ! `$ K2 d8 w0 n
17. 
    
18.     P1(0) = Center1(0): P1(1) = Center1(1) - Width / 2: P1(2) = Center1(2) '新UCS原点
    2 o, H8 |5 M. b# s) l5 U7 H
19.     P2(0) = P1(0) + 1: P2(1) = P1(1): P2(2) = P1(2) '新UCS的X方向,与WCS的X方向相同
    9 M9 `4 E7 t, Z) m" F
20.     P3(0) = P1(0): P3(1) = P1(1): P3(2) = P1(2) + 1 '新UCS的Y方向,与WCS的Z方向相同
    
21.     Set Ucs = .UserCoordinateSystems.Add(P1, P2, P3, "U") '新建UCS
    / P: n$ D) t3 O/ b; m
22.     .ActiveUCS = Ucs  '新UCS置为当前
    8 ~- g3 l/ E8 Z+ f! v6 k
23.    
    2 E6 x; k; t- E+ D5 Z& @
24.     SendCommand "dimlinear  " & -Length / 2 & ",0 " & -Length / 2 - 1 & ",0 "
    
25.    
    
26.     SendCommand "ucs w " '恢复WCS
    
27. End With
    

复制代码