块属性到文本错误
我尝试在块对象的同一点添加文本对象。但它在下面的红线处给出了一个错误。
错误代码为；
运行时错误“5”：
过程调用或参数无效
Sub Block_Attributes_to_Text()
Dim obj As AcadBlockReference
Dim oText As AcadText
Dim inspt As Variant
Dim AttList As Variant
Dim metin As String
Dim poz As String
Dim adet As String
Dim cap As String
Dim ara As String
Dim boy As String
Dim MidPoint(0 To 2)
Dim NewColorObject As AcadAcCmColor
Dim acı As Double
ThisDrawing.Utility.GetEntity obj, inspt, "Select Block:"
If obj.ObjectName = "AcDbBlockReference" Then
If obj.HasAttributes Then
AttList = obj.GetAttributes
For i = LBound(AttList) To UBound(AttList)
Select Case AttList(i).TagString
Case Is = "POZ1"
poz = AttList(i).TextString
Case Is = "DAD"
adet = AttList(i).TextString
Case Is = "CAP"
cap = AttList(i).TextString
Case Is = "ARA"
ara = AttList(i).TextString
Case Is = "BOY1"
boy = AttList(i).TextString
End Select
Next i
End If
Else
MsgBox "You did not select a block."
End If
metin = poz & "+" & adet & "»" & cap & "/" & ara & " L=" & boy
MidPoint(0) = obj.InsertionPoint(0)
MidPoint(1) = obj.InsertionPoint(1)
MidPoint(2) = 0
Set oText = ThisDrawing.ModelSpace.AddText(metin, MidPoint, 5)
Set NewColorObject = obj.TrueColor
NewColorObject.ColorMethod = acColorMethodByACI
NewColorObject.ColorIndex = 2
oText.TrueColor = NewColorObject
acı = obj.Rotation
oText.Rotate MidPoint, acı
oText.Update
acı = Empty
Set NewColorObject = Nothing
Erase MidPoint
boy = vbNullString
ara = vbNullString
cap = vbNullString
adet = vbNullString
poz = vbNullString
metin = vbNullString
AttList = Empty
inspt = Empty
oText = Nothing
obj = Nothing
End Sub
只需将中点声明为双精度
Dim MidPoint(0 To 2) As Double
此外，虽然与您遇到的问题无关，但您还必须更改底部的最后两行，在开头添加“set”关键字
Set oText = Nothing
Set obj = Nothing
页:
[1]