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

jsxygshh · 发表于 2012-10-10 07:35

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

woaishuijia · 发表于 2012-10-10 12:07

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

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

jsxygshh · 发表于 2012-10-10 07:37

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

mikewolf2k · 发表于 2012-10-10 08:19

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

jsxygshh · 发表于 2012-10-10 08:53

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

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

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

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

jsxygshh · 发表于 2012-12-8 01:14

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

云牧帆 · 发表于 2013-1-23 15:05

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

斑竹跨界高手

陈亚娣 · 发表于 2013-3-28 23:40

顶一下!!!!!!

jyzas · 发表于 2013-8-15 20:30

支持

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源

本帖被以下淘专辑推荐:

相关帖子

本帖子中包含更多资源