VBA自动提取CAD数字的单行和多行文字以及块参数和点图元插入点

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

For Each AcadObject In acadApp.ActiveDocument.ModelSpace

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

'图元是点时

If TypeName(AcadObject) = "IAcadPoint" Then

xyz = AcadObject.Coordinates

'图元不是点时

Else

xyz = AcadObject.InsertionPoint

End If

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

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

If IsNumeric(attribs(i00).TextString) Then

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

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

End If

Exit For

End If

Next i00

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

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

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

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

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

i = i + 1

ElseIf TypeName(AcadObject) = "IAcadMText" Then

If IsNumeric(AcadObject.TextString) Then

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

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

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

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

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

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

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

i = i + 1

End If

ElseIf TypeName(AcadObject) = "IAcadText" Then

If IsNumeric(AcadObject.TextString) Then

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

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

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

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

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

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

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

i = i + 1

End If

ElseIf TypeName(AcadObject) = "IAcadPoint" Then

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

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

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

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

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

i = i + 1

End If

End If

Next AcadObject

Cells(1, 6) = i

Cells(3, 1).Select

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

End Sub