大家好!
这里的天气不太好,所以又是节目时间了。你能帮我摆脱这个吗?它应该标记块的高度,但当我试图将文本放在块的插入点上时,我会被卡住。我猜不太复杂。我猜错了。。。
错误状态为:“对象‘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
|