[求助]如何在VB环境下获取AutoCAD的Text（文本对象），请教各位啦

Lostvivi

我现在需要完成一个应用程序，其中一个步骤是从AutoCAD中获取数据，开发工具是VB

这个步骤要实现：当我点击CAD图形中的Text（实际上是图斑的编号，都是数字）的时候，自动获取它并放到一个VB文本框中。最近一周一直在学习ActiveX方面的知识，但是自己没有这方面的书籍，网上的东西零零碎碎地，AutoCAD的developer help也看得头大，现在比较急用，希望能有人帮忙写这段代码或者给点参考代码也好。这里先感谢了

Lostvivi

这个是我的代码，希望能有人帮帮忙啦
Dim sset As Object
Dim utilobj As Object
Dim pnt
Dim temppoint(0 To 2) As Double
Dim pointl
Dim strsqltext As String

'错误陷阱
On Error GoTo error_show
enablecommandbuttons (False)
'状态栏提示信息
lblstatus.Caption = "在AUTOCAD窗口中选择一个对象"
'激活AUTOCAD程序窗口
Set utilobj = objacad.ActiveDocument.Utility
'在AUTOCAD命令窗口显示信息
pnt = utilobj.GetPoint(, "在图形窗口中选择一个对象:")
temppoint(0) = pnt(0)
temppoint(1) = pnt(1)
temppoint(2) = pnt(2)
pointl = utilobj.TranslateCoordinates(temppoint, 0, 1, 0)
point(0) = pointl(0)
point(1) = pointl(2)
point(2) = pointl(2)
lblstatus.Caption = ""

'出错处理
On Error Resume Next
'如果存在
If Not IsNull(objdoc.sesectionsets.Item("ss1")) Then
   Set sset = objdoc.SelectionSets.Item("ss1")
   sset.Delete
End If


Set sset = objdoc.SelectionSets.add("ss1")


'出错处理
   On Error GoTo error_show
   Call sset.SelectAtPoint(point)
   
   '检查是否选择了一个对象
If sset.Count = 1 Then
   If StrComp(sset(0).EntityName, "acdbblockreferrence", 1) = 0 Then
   
   '链接到数据库
     strHandle1 = sset(0).Handle
     strsqltext = "seleCt * from sheet1 where handle='" & Trim(strHandle1) & "'"
     Data1.RecordSource = strsqltext
     Data1.Refresh
     
     '数据库中有相关信息
     If checkallfilled Then
     cmdeditrecord.Enabled = True          '按钮状态###################
     cmddeleterecord.Enabled = True
     
     '没有相关信息
     Else
        MsgBox "记录不存在，请添加相关信息"
        cmdaddrecord.Enabled = True
        clearsql
        
    End If
Else
'没有选择对象
    If sset.Count = 0 Then
      Form1.ide
      MsgBox "未选中图块"
    End If
End If
Exit Sub

'错误陷阱
error_show
   MsgBox Err.Description
   Exit Sub
End Sub

   

Private Sub cmdstart_Click()
' 运行AUTOCAD
    startautocad
   '设定按钮状态##############
   cmdstart.Enabled = False
   'cmdclearsql.Enabled = True
   cmdshowrecord.Enabled = True
   cmdlink.Enabled = True
   cmdhighlight.Enabled = True
   
 End Sub
Private Sub startautocad()
'设定文件名目录变量
  Dim dwgname As String
 
  '错误陷阱
  On Error Resume Next
 
  '设定AUTOCAD对象
       Set objacad = GetObject(, "autocad.application")
       If Err Then
       '打开autocad程序
          
          Set objacad = CreateObject("autocad.application")
          Err.Clear
        End If
        
        
        If Right(App.Path, 1) = "\" Then
           dwgname = App.Path & "虹口02.dwg"
        Else
           dwgname = App.Path & "\虹口02.dwg"
        End If
        
        
        Set objdoc = objacad.ActiveDocument
        
        
        sysvarname = "osmode"
        sysvardata = objdoc.GetVariable(sysvarname)
        osMode = CInt(sysvardata)
        objdoc.SetVariable sysvarname, 0
        sysvarname = "sdi"
        sysvardata = objdoc.GetVariable(sysvarname)
        sdimode = CInt(sysvardata)
        objdoc.SetVariable sysvarname, 1
        
        If objdoc.FullName <> dwgname Then
            objdoc.Open dwgname
        End If
        objacad.Visible = True
        
End Sub








Private Sub txtUse_click()
    MsgBox "this box cannot be edited"
End Sub


Private Function checkallfilled() As Boolean
      Dim chkstr As String
      checkallfilled = False
      chkstr = Trim(txtLSH.Text & txtName.Text & txtPzwh.Text & txtPzwh2.Text & txtDate.Text & txtPzwh3.Text & txtPosition.Text)
      If (chkstr <> "") Then
             checkallfilled = True
      End If
      End Function

'获取文件句柄
Private Function gethandle() As String

     Dim utilobj As Object
     Dim pnt
     Dim temppoint(0 To 2) As Double
     Dim point(0 To 2) As Double
     Dim pointl
     Dim sset As Object
     
     '出错处理
     On Error GoTo error_gethandle
     Set utilobj = objacad.ActiveDocument.Utility
     pnt = utilobj.GetPoint(, "选择一个CAD对象连接记录:")
     
     
  
     temppoint(0) = pnt(0)
     temppoint(1) = pnt(1)
     temppoint(2) = pnt(2)
     pointl = utilobj.TranslateCoordinates(temppoint, 0, 1, 0)
     point(0) = pointl(0)
     point(1) = pointl(1)
     point(2) = pointl(2)
     lblstatus.Caption = ""
     
     
     '获取选择集对象
     Set sset = objacad.ActiveDocument.SelectionSets.add("ss1")
     Call sset.SelectAtPoint(point)
     If sset.Count = 1 Then
            If StrComp(sset(0).EntityName, "acdbblockreference", 1) = 0 Then
              gethandle = sset(0).Handle
              Else
                MsgBox "没有图块被选中"
                gethandle = ""
                End If
     Else
           If sset.Count = 0 Then
           Form1.Hide
           MsgBox "没有图块被选中"
           Form1.Show
           End If
           If sset.Count > 1 Then
           MsgBox "选中图块超过一个"
           End If
           gethandle = ""
    End If
    Exit Function
   

mccad

选择单个对象要以使用GetEntity方法，而判断选中对象是否为文本可以使用ObjectName属性来判断是否为“AcDbText”，获取文本的内容可以使用TextString属性。

Lostvivi

谢谢您的提示，我用您的方法试试看