[讨论][求助]vba利用鼠标获取text里面的数值。

meritw

各位达人，在VBA中如何利用鼠标获取text里面的数值？

zuehuo

没人 回答 呀

 

雪山飞狐_lzh

问题描述的太简单，没看懂

meritw

终于搞出来了

贡献一下：

 

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 "请选择<Text>格式的实体！"
   
    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 < 3 Then
                    If vbNo = MsgBox("没有找到<Text>格式的实体，是否重新点选？", vbYesNo + vbQuestion) Then selectTextNum = -1: Exit Function
                Else
                    MsgBox "没有找到<Text>格式的实体，尝试超过3次，请手动输入！", vbInformation + vbCritical
                    selectTextNum = -1
                    Exit Function
                End If
            End If
        End If
    Loop While (False = blnHaveFoundText And intCount < 3)
    ssetobj.Clear:  ssetobj.Delete
    Exit Function
Finish:
  ssetobj.Delete
  selectTextNum = -1
End Function

guanxiancad2006

checkkey(escape)？