VBA提取AutoCAD2021块参照多行文字单行文字和点图元插入点与内容

Sub 按钮2_Click()

Dim acadApp As AcadApplication, na As String, xyz As Variant

Dim i0 As Long, name As String

Dim i As Long

On Error Resume Next

Set acadApp = GetObject(, "AutoCad.Application") '若AutoCAD 已运行则获得它的对象实例

If Err Then '若没有安装 AutoCADh

Err.Clear

Set acadApp = CreateObject("AutoCad.Application")

If Err Then '若没有安装 AutoCAD

MsgBox "系统未安装AutoCAD,请安装AutoCAD"

End If

End If

acadApp.Visible = True

ZoomExtents

na = acadApp.ActiveDocument.FullName

'清空

i = 0

Do While Not Cells(3 + i, 1) = ""

For i1 = 0 To 7

Cells(3 + i, i1 + 1) = ""

Next i1

i = i + 1

Loop

Cells(1, 6) = 0

'找空

i = 0

Do While Not Cells(3 + i, 1) = ""

i = i + 1

Loop

Cells(1, 5).NumberFormatLocal = "@"

name = Cells(1, 5)

Cells(1, 5) = name

Dim Msg, Style, Title, Help, Ctxt, Response, MyString

Msg = "点提取类型？从Coordinates数组提取，点是！ 从InsertionPoint数组提取就点否！" '定义消息文本

Style = vbYesNo + vbCritical + vbDefaultButton2 '定义对话框样式

Title = "点提取类型确定！" '定义标题文本

Help = "Demo.hlp" '定义帮助文件

Ctxt = 1000 '定义帮助主题编号

Response = MsgBox(Msg, Style, Title, Help, Ctxt)

If Response = vbYes Then '用户按下“是”按钮

MyString = "Yes" '进行某些操作

Else '用户按下“否”按钮

MyString = "No" '进行某些操作

End If

For Each AcadObject In acadApp.ActiveDocument.ModelSpace

If AcadObject.Layer = Cells(1, 5) Then

'Coordinates

If MyString = "Yes" Then

xyz = AcadObject.Coordinates

End If

'InsertionPoint

If MyString = "No" Then

xyz = AcadObject.InsertionPoint

End If

Cells(3 + i, 1) = AcadObject.Layer

Cells(3 + i, 2) = xyz(0)

Cells(3 + i, 3) = xyz(1)

Cells(3 + i, 4) = xyz(2)

'单行和多行文字控件的内容

If TypeName(AcadObject) = "IAcadBlockReference" Then

Dim objBlockRef As AcadBlockReference

Set objBlockRef = AcadObject

Dim attribs As Variant

attribs = objBlockRef.GetAttributes

Dim i00 As Integer

For i00 = LBound(attribs) To UBound(attribs)

If attribs(i00).TagString = "height" Then

Cells(3 + i, 5) = attribs(i00).TextString

Cells(3 + i, 6) = Cells(3 + i, 5) - Cells(3 + i, 4)

Cells(3 + i, 7) = "块参照"

Exit For

End If

Next i00

ElseIf TypeName(AcadObject) = "IAcadMText" Then

Cells(3 + i, 5) = AcadObject.TextString

Cells(3 + i, 6) = Cells(3 + i, 5) - Cells(3 + i, 4)

Cells(3 + i, 7) = "多行文字"

ElseIf TypeName(AcadObject) = "IAcadText" Then

Cells(3 + i, 5) = AcadObject.TextString

Cells(3 + i, 6) = Cells(3 + i, 5) - Cells(3 + i, 4)

Cells(3 + i, 7) = "单行文字"

ElseIf TypeName(AcadObject) = "IAcadPoint" Then

Cells(3 + i, 7) = "点"

End If

i = i + 1

End If

Next AcadObject

Cells(1, 6) = i

MsgBox "取数完毕,共: " & i & " 个图元,当前CAD为：" & na

Cells(3, 1).Select

End Sub