|
|
发表于 2010-7-12 10:24:00
|
显示全部楼层
终于搞出来了
贡献一下：
Public Function selectTextNum() As Double
On Error Resume Next
Dim ssetobj As AcadSelectionSet
Dim strText As String, dblText As Double
Dim blnHaveFoundText As Boolean, intCount As Integer
ThisDrawing.SelectionSets("getTextNum").Delete
Set ssetobj = ThisDrawing.SelectionSets.Add("getTextNum")
ThisDrawing.Utility.Prompt "请选择格式的实体！"
Dim pickedObjs As AcadEntity
'循环每个被选择的实体
blnHaveFoundText = False: intCount = 0
Do
ssetobj.SelectOnScreen
If checkkey(escape) = True Then GoTo Finish:
If Err Then Err.Clear
If ssetobj.count = 0 Then
If vbNo = MsgBox("没有选择实体，是否重新点选？", vbYesNo) Then selectTextNum = -1: Exit Function 'GoTo Finish '如果没有选择物体，结束程序
Else
For Each pickedObjs In ssetobj
' If TypeOf pickedObjs Is AcadPolyline Or TypeOf pickedObjs Is Acad3DPolyline Then
' Debug.Print pickedObjs.ObjectName
' If pickedObjs.ObjectName = "AcDbMText" Then
' pickedObjs.Highlight (True) ' = acRed '可将所有被选择实体将变为红色
' strText = pickedObjs.textString
' dblText = pickedObjs.Text
' selectTextNum = CDbl(strText) '得到每个实体对象的文本内容
' pickedObjs.Highlight (False) ' = acRed '可将所有被选择实体将变为红色
' End If
If pickedObjs.ObjectName = "AcDbText" Then
pickedObjs.Highlight (True) ' = acRed '可将所有被选择实体将变为红色
strText = pickedObjs.textString
selectTextNum = CDbl(strText) '得到每个实体对象的文本内容
pickedObjs.Highlight (False) ' = acRed '可将所有被选择实体将变为红色
ThisDrawing.Utility.Prompt "成功选取数值" & selectTextNum & ";" & vbCrLf
blnHaveFoundText = True
End If
Next
intCount = intCount + 1
If False = blnHaveFoundText Then
If intCount 格式的实体，是否重新点选？", vbYesNo + vbQuestion) Then selectTextNum = -1: Exit Function
Else
MsgBox "没有找到格式的实体，尝试超过3次，请手动输入！", vbInformation + vbCritical
selectTextNum = -1
Exit Function
End If
End If
End If
Loop While (False = blnHaveFoundText And intCount
|
|
置顶卡
