[求助] VB提取当前所打开的CAD文件的块属性

zm8391473

Sub XS()
Dim RowNum As Integer
Dim Header As Boolean
Dim elem As AcadEntity
Dim Array1 As Variant
Dim Count As Integer
Dim acadApp As AcadApplication
Dim acadDoc As AcadDocument
Dim MSP As AcadEntity
Dim WenZi As String
On Error Resume Next
RowNum = 1
Header = False
For Each elem In ThisDrawing.ModelSpace
With elem
If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
If .HasAttributes Then
Array1 = .GetAttributes
RowNum = RowNum + 1
    For Count = LBound(Array1) To UBound(Array1)
    WenZi = WenZi + Array1(Count).TextString + "\/"
    Next Count
    WenZi = WenZi + Chr$(13) + Chr$(10)
Header = True
End If
End If
End With
Next elem
   FileName = "C:\XS.XS"
   FileNum = 1
   Open FileName For Output As FileNum
   Print #FileNum, WenZi
   Close #FileNum
End Sub

这段程序可以将CAD图形中的块属性值提取出来，但是只能在CAD里边做为宏执行，那位大侠能帮帮帮忙移植到VB里边，用VB程序提取当前打开的CAD图形块信息，

感激不尽，谢谢了

zhejiang000

Sub XS()
    Dim RowNum As Integer
    Dim Header As Boolean
    Dim elem As Object  'AcadEntity
    Dim Array1 As Variant
    Dim Count As Integer
   
    Dim acadApp As Object  'AcadApplication
    Dim acadDoc As Object  'AcadDocument
    Dim MSP As Object  'AcadEntity
    Dim WenZi As String
    On Error Resume Next
   
    '---------------------------------------------------

    '新增部分
    Set acadApp = GetObject(, "AutoCAD.Application")
    If Err Then
        Err.Clear
        Set acadApp = CreateObject("AutoCAD.Application")
        If Err Then
            MsgBox Err.Description
            End
            Exit Sub
        End If
    End If
    acadApp.Visible = True
    Set acadDoc = acadApp.ActiveDocument
    '-----------------------------------------------------
   
    RowNum = 1
    Header = False
    For Each elem In acadDoc.ModelSpace 'ThisDrawing.ModelSpace
        With elem
        If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
        If .HasAttributes Then
        Array1 = .GetAttributes
        RowNum = RowNum + 1
            For Count = LBound(Array1) To UBound(Array1)
            WenZi = WenZi + Array1(Count).TextString + "\/"
            Next Count
            WenZi = WenZi + Chr$(13) + Chr$(10)
        Header = True
        End If
        End If
        End With
    Next elem
       FileName = "C:\XS.XS"
       FileNum = 1
       Open FileName For Output As FileNum
       Print #FileNum, WenZi
       Close #FileNum
End Sub