生成文本对象时出错
大家好！这里的天气不太好，所以又是节目时间了。你能帮我摆脱这个吗？它应该标记块的高度，但当我试图将文本放在块的插入点上时，我会被卡住。我猜不太复杂。我猜错了。。。
错误状态为：“对象‘IAcadModelSpace’的方法‘Add3DMesh’失败。”
Sub BlockHeight()
Dim aEnt As AcadEntity
Dim aBlock As AcadBlockReference
Dim aText As AcadText
Dim sText As String
Dim NewLayer As AcadLayer
Dim retValue As Variant
Dim retCoord(0 To 2) As Double
Dim attrib As Variant
Dim sset As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim InsertionPoint As Variant
FilterType(0) = 8
FilterData(0) = "OCT_KDT"
On error GoTo Delete
Set sset = ThisDrawing.SelectionSets.Add("sset")
sset.Select acSelectionSetAll, , , FilterType, FilterData
On error goto Errorhandling
For Each aEnt In sset
If TypeOf aEnt Is AcadBlockReference Then
Set aBlock = aEnt
retValue = aBlock.GetAttributes
For Each attrib In retValue
If attrib.TagString = "LAYER" Then
sText = attrib.TextString
End If
Next attrib
If sText Like "N_WRI*" Then
Set NewLayer = ThisDrawing.Layers.Add("N_LOW")
sText = aBlock.InsertionPoint(2)
InsertionPoint = aBlock.InsertionPoint
Set aText = ThisDrawing.ModelSpace.AddText(sText, InsertionPoint, 0)
aText.Layer = "N_LOW"
aText.StyleName = "OCTOPUS"
aText.Height = 0.5
aText.Rotation = 0
NewLayer.Color = acYellow
End If
End If
Next aEnt
sset.Delete
Exit Sub
Delete:
ThisDrawing.SelectionSets.Item("sset").Delete
Resume
Errorhandling:
ThisDrawing.SelectionSets.Item("sset").Delete
End Sub
页:
[1]