CAD设计论坛

 找回密码
 立即注册
论坛新手常用操作帮助系统等待验证的用户请看获取社区币方法的说明新注册会员必读(必修)
查看: 1471|回复: 2

[求助] 高手请进来看看这段 VBA代码

[复制链接]
发表于 2007-6-3 19:35 | 显示全部楼层 |阅读模式
这段代码 我找到时 说明是可以将AUTOCAD中的属性块中的属性提取到Excel中
5 j( T# i" a  l& N6 m我用的是AUTOCAD2007 打开VBA复制进去 然后工具-引用,把Microsoft  Excel勾选上$ u9 M8 {* g+ Y# ?- ?
然后编译   光标停留在“mspace As Object”这句上
- t2 {, w/ v+ [1 n7 |1 }7 U- B编译报错  “成员已经存在于本对象模块派生出的对象模块中”
# w$ |; K! a/ u然后小弟查了很久 也不知道 对不对 把mspace改成了myspace
0 W6 v$ Q  C+ [& o& _+ d2 f再编译就没有报错 通过了
, e3 k" |; W$ Y% p1 Y! {但是运行宏的时候 又报错“运行时错误429,ActiveX部件不能创建对象”7 ~8 N) G( |; R$ `: z9 ]- ]; S
请各位帮忙看一下 或者 高手可以指点一下小弟8 n% Q; |. G7 g" g& l* M
感激万分
& I0 V. N4 n1 q2 j- m+ J9 q" v$ v( w6 \1 `7 X3 J8 R% D: {3 h9 P

; [+ T5 ^& \) }  B6 R+ fPublic acad As Object0 H% t5 h% Y: z- t) Y- I7 a. ?- W
Public mspace As Object7 t1 e& Y) E7 v
Public excel As Object, e, Q$ J. m3 E' o; S) Q# R
Public AcadRunning As Integer' Z3 @7 p4 e4 X, n$ X- G
Public excelSheet As Object
; r  x% V7 ?  n! zSub Extract()
; I& O9 T8 M" V, m" E" Z    Dim sheet As Object
$ q; w% n7 O' I1 X1 n0 t    Dim shapes As Object
& W1 k' y; R" |- y% P: h    Dim elem As Object
$ T; g. [+ N% ^/ G    Dim excel As Object
8 z4 K* Q: L3 ?3 q. F( T    Dim Max As Integer
  |- ^+ a2 E5 @- a+ ^9 D    Dim Min As Integer: `* ~, y, x- E, e* B
    Dim NoOfIndices As Integer# G: X. s7 O  z4 J- ]" `/ J
    Dim excelSheet As Object
  H' \. e: i  a7 P) E7 z0 q5 k6 i    Dim RowNum As Integer# t* X! v! C" b2 d' s( I7 Y) B
    Dim Array1 As Variant, Array2 As Variant. i. o4 L* ^9 x0 W% \
    Dim Count As Integer
6 M6 Q- p  n" O% `% W! N  C8 E  d. a# Q) c

; N& }; Y: e' J, P& ?5 F) V% j
- u6 I% Y5 W; w: v; }    Set excel = GetObject(, "Excel.Application")
, p+ o4 t6 B% nSet excelSheet = excel.Worksheets("sheet1")* O# y2 [$ N9 b" X- B
     Dim Sh As Object, rngStart As Range
3 _5 `; J0 K3 ]! }5 `! u7 X     If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
9 I  d2 w4 g! f) A: g     Set Sh1 = ExcelSheet1
+ X4 |  f& A4 h3 F0 b6 GSet rngStart = Sh1.Range("A1")
3 g; a5 R3 x" r! J$ n0 c5 l    With rngStart.Rows(1)& t5 J' g( @3 i! _  X1 j5 ~0 Q
End With
! \/ ^: ~- U1 l( Y( E) a) d* @    Set acad = Nothing1 {; [: b. a' @& @5 f: m
    On Error Resume Next
6 p$ X% ]" p/ q4 U. V* E    Set acad = GetObject(, "AutoCAD.Application")
# N' \. z/ Y7 \# B/ ^    If Err <> 0 Then
9 S3 K' i% p4 J4 `. G    Set acad = CreateObject("AutoCAD.Application")) O% z) ]( h4 H9 v- y
    MsgBox "请打开 AutoCAD 图形文件!"
6 \. s5 `3 T, K" y, F- N, c7 q    Exit Sub
, m' \# j& I/ r    End If2 ^/ f' M/ x( `, Y& T  [
9 r7 N2 i5 i! f* d/ E  E' b# X
    Set doc = acad.ActiveDocument
, n, Z! E1 Z* r. i1 m0 {2 a    Set mspace = doc.ModelSpace. `7 r' P* D( u$ I
    RowNum = 10 J- H8 _/ @( D/ U% a
    Dim Header As Boolean
8 q* C# a# a: J3 `    Header = False
1 g1 T- B: o2 \1 o    For Each elem In mspace
' \. O- K1 J% s! i6 c/ M/ d      With elem
! e  _+ k0 u1 @! T6 J: H        If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then7 ]. ?" M/ _$ e9 O) w
           If .HasAttributes Then
" L' d  _, w+ N/ ~              Array1 = .GetAttributes9 t! p6 S0 w8 A! a1 m; t! _
              Array2 = .GetConstantAttributes0 ^% n) C9 ^; s+ U3 g, {
            For Count = LBound(Array1) To UBound(Array1)- K- l0 p5 d- z; M/ O
               If Header = False Then- @+ X& o3 S' i/ y
                 If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
3 r2 w/ H+ `9 [; Q* v9 R  E                  excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
$ n6 `! c2 B2 T( C, J                 End If
! t+ o- x9 I. X7 b' r! H3 y               End If
  R4 M/ T$ `$ c) B- q8 }( |            Next Count
/ J3 l. l# e6 [            - _# d% Y$ a# i+ M4 c5 c! F
            For Count = LBound(Array2) To UBound(Array2)
6 l. `- g5 c& J4 Q               If Header = False Then; |. `/ R, F& p) P% f. c  p
                 If StrComp(Array2(Count).EntityName, "AcDbAttributeDefinition", 1) = 0 Then
; C/ k+ I* E1 r3 v" X                  excelSheet.Cells(RowNum, UBound(Array1) + 1 + Count + 1).Value = Array2(Count).TagString
$ R3 f  m& H9 g# f# a                 End If
1 \1 n0 l% S! g( l- N/ j2 u               End If& r! a- l0 }8 h6 ^/ G
            Next Count/ C/ t4 x! W: G2 m2 ]( H" M; I" k
            3 o" q3 h& M3 e. }, @+ ?
              RowNum = RowNum + 1
- b  i! z$ _8 B            For Count = LBound(Array1) To UBound(Array1)% M0 [6 O7 {, ?# `3 d8 E, b, K& L: x
               excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
9 T0 u, \5 A* R& D  `& }' J            Next Count
. A# y4 u+ ^8 t# M% C2 s0 S  B1 `9 {+ {            % w* [* v' D, t1 @% ~
            For Count = LBound(Array2) To UBound(Array2)3 y9 ~6 D% C1 z$ \( h8 u" o
               excelSheet.Cells(RowNum, UBound(Array1) + 1 + Count + 1).Value = Array2(Count).TextString
2 ~) p% m( k# p. y, R% G( ]            Next Count+ N) v: q: @/ g: i/ `. I
            
8 i+ p/ C  v) c            Header = True
9 \+ `9 [# Z$ s0 A            End If
1 g+ n" N8 Z7 M. C% D/ @; D8 ?! ^8 h          End If1 [3 L4 Z1 G6 H0 u4 i4 p( J7 M
      End With
  |8 u% R# n+ b& R" R4 h) e8 T    Next elem
# D1 z. K) d* U9 b/ |& ]. H1 o" J    NumberOfAttributes = RowNum - 1) S, N4 k" O! b. M3 X7 q; k
    If NumberOfAttributes > 0 Then
5 z$ k2 R4 \  g4 P) g      Worksheets("属性取出").Range("A1").Sort _; }+ f' i  |( s; B9 w
      key1:=Worksheets("属性取出").Columns("A"), _. |  f. n+ q8 p0 k
      Header:=xlGuess4 p0 i9 a) Y7 `6 M3 p
    Else
" v7 t6 T2 Y& }. B4 G      MsgBox "无法提出图形文件中的属性或此图形文件中无任何属性!"
) n+ r' G8 h1 F+ L    End If5 V7 x9 \  a" @4 z
    6 J# T1 G# k3 S- c; D( I/ P' a* r& Y" q
    Set currentcell = Range("A2")& Z+ [8 }$ J. p2 d' ~
    Do While Not IsEmpty(currentcell)
  a7 B8 G6 v% F0 x        Set nextCell = currentcell.Offset(1, 0)
" u; S, [6 S7 Z  A+ f/ x# \        If nextCell.Value = currentcell.Value Then
0 V8 u! x) H5 c# a" o2 Q! V            Set TCell = currentcell.Offset(1, 3)
+ T) u1 D! ~' I7 k! H: c& }( E            TCell.Value = TCell.Value + 1
) g( |! W. [+ A" m            currentcell.EntireRow.Delete
' }6 P  @) V/ J2 }        End If. V5 k9 K! I6 J/ {
        Set currentcell = nextCell
0 B; g; S& U  s    Loop
* X5 K8 J  f& H$ C) \6 M1 F, u! f+ R# D1 i8 t
    ( \4 {( ~0 g5 p& C9 \
    Set acad = Nothing
$ g4 p/ ]; C7 U5 cEnd Sub
发表于 2007-6-3 21:28 | 显示全部楼层
发表于 2007-6-4 20:46 | 显示全部楼层
这个真的难说的- v6 _, E8 D: b$ S: L- e
想当年用EXCEL宏的时候也经常出错# A1 U, m9 U- O$ c( s4 X* z/ o+ k, M
自己慢慢的去调试
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

关于|免责|隐私|版权|广告|联系|手机版|CAD设计论坛

GMT+8, 2025-2-19 06:13

CAD设计论坛,为工程师增加动力。

© 2005-2025 askcad.com. All rights reserved.

快速回复 返回顶部 返回列表