vb如何提取“块参考”属性中的“A”对应值到EXCEL

jsxygshh

请各位高手不吝赐教：
如何用VB提取“块参考”属性中的“A”对应值到EXCEL，先谢谢了！

woaishuijia

2.     Dim myAcadApp As AutoCAD.AcadApplication, SS As AcadSelectionSet, FT(0) As Integer, FD(0) As Variant
   
3.     Dim BF As AcadBlockReference, AF As AcadAttributeReference, V1 As Variant, V2 As Variant
   
4.     On Error Resume Next
   
5.     Set myAcadApp = GetObject(, "Autocad.Application")
   
6.     If Err <> 0 Then
   
7.         Err.Clear
   
8.         Set myAcadApp = CreateObject("Autocad.Application")
   
9.         If Err Then
   
10.             MsgBox Err.Number & ":" & Err.Description
    
11.             Exit Sub
    
12.         End If
    
13.     End If
    
14.     With myAcadApp
    
15.         .WindowState = acMax
    
16.         .Visible = True
    
17.         AppActivate "AUTOCAD"
    
18.         With .ActiveDocument
    
19.             Set SS = .SelectionSets.Add("SS")
    
20.             FT(0) = 0
    
21.             FD(0) = "INSERT"
    
22.             SS.SelectOnScreen FT, FD
    
23.             For Each BF In SS
    
24.                 V1 = BF.GetAttributes
    
25.                 For Each V2 In V1
    
26.                     Set AF = V2
    
27.                     If AF.TagString = "A" Then
    
28.                         '此处把 AF.TextString 属性填入EXCEL单元格
    
29.                     End If
    
30.                 Next
    
31.             Next
    
32.             SS.Delete
    
33.         End With
    
34.     End With

    Dim myAcadApp As AutoCAD.AcadApplication, SS As AcadSelectionSet, FT(0) As Integer, FD(0) As Variant<br />     Dim BF As AcadBlockReference, AF As AcadAttributeReference, V1 As Variant, V2 As Variant<br />     On Error Resume Next<br />     Set myAcadApp = GetObject(, "Autocad.Application")<br />     If Err <> 0 Then<br />         Err.Clear<br />         Set myAcadApp = CreateObject("Autocad.Application")<br />         If Err Then<br />             MsgBox Err.Number & ":" & Err.Description<br />             Exit Sub<br />         End If<br />     End If<br />     With myAcadApp<br />         .WindowState = acMax<br />         .Visible = True<br />         AppActivate "AUTOCAD"<br />         With .ActiveDocument<br />             Set SS = .SelectionSets.Add("SS")<br />             FT(0) = 0<br />             FD(0) = "INSERT"<br />             SS.SelectOnScreen FT, FD<br />             For Each BF In SS<br />                 V1 = BF.GetAttributes<br />                 For Each V2 In V1<br />                     Set AF = V2<br />                     If AF.TagString = "A" Then<br />                         '此处把 AF.TextString 属性填入EXCEL单元格<br />                     End If<br />                 Next<br />             Next<br />             SS.Delete<br />         End With<br />     End With

jsxygshh

补充一下：一次可以选一个或多个块，分别输出到EXCEL

mikewolf2k

大体分两步吧。1.读取块属性。2输出文本到excel。楼主可搜寻这两方面的帖子学习。祝顺利。

jsxygshh

mikewolf2k 发表于 2012-10-10 08:19
大体分两步吧。1.读取块属性。2输出文本到excel。楼主可搜寻这两方面的帖子学习。祝顺利。

第一步纠结两天了都没有成功，请帮助解决一下，十分感谢

sscylh

2. Sub aa()
   
3. Dim bobj As AcadBlockReference
   
4. Dim a
   
5. Dim arr()
   
6. Dim ss As AcadSelectionSet
   
7. Dim filtertype(0 To 0) As Integer
   
8. Dim filterdata(0 To 0) As Variant
   
9. Dim xls As Excel.Application
   
10. Set xls = New Excel.Application
    
11. Set ss = ThisDrawing.SelectionSets.Add(CStr(Rnd))
    
12. filtertype(0) = 0
    
13. filterdata(0) = "insert"
    
14. ss.SelectOnScreen filtertype, filterdata
    
15. For Each bobj In ss
    
16. i = i + 1
    
17. ReDim Preserve arr(1 To i)
    
18. a = bobj.GetAttributes
    
19. arr(i) = a(0).TextString
    
20. Next
    
21. With xls.Workbooks.Add
    
22.    .Sheets(1).[a1].Resize(i, 1) = xls.Transpose(arr)
    
23.    .SaveAs "d:/123.xls"
    
24.    .Close
    
25. End With
    
26. xls.Quit
    
27. End Sub

Sub aa()<br /> Dim bobj As AcadBlockReference<br /> Dim a<br /> Dim arr()<br /> Dim ss As AcadSelectionSet<br /> Dim filtertype(0 To 0) As Integer<br /> Dim filterdata(0 To 0) As Variant<br /> Dim xls As Excel.Application<br /> Set xls = New Excel.Application<br /> Set ss = ThisDrawing.SelectionSets.Add(CStr(Rnd))<br /> filtertype(0) = 0<br /> filterdata(0) = "insert"<br /> ss.SelectOnScreen filtertype, filterdata<br /> For Each bobj In ss<br /> i = i + 1<br /> ReDim Preserve arr(1 To i)<br /> a = bobj.GetAttributes<br /> arr(i) = a(0).TextString<br /> Next<br /> With xls.Workbooks.Add<br />    .Sheets(1).[a1].Resize(i, 1) = xls.Transpose(arr)<br />    .SaveAs "d:/123.xls"<br />    .Close<br /> End With<br /> xls.Quit<br /> End Sub

jsxygshh

谢谢二位老师的指点，调试成功了，谢谢！

云牧帆

sscylh 发表于 2012-10-10 12:10

斑竹跨界高手

陈亚娣

顶一下!!!!!!

jyzas

支持