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

Lostvivi · 发表于 2007-5-1 00:36:00

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

Lostvivi · 发表于 2007-5-2 01:30:00

这个是我的代码，希望能有人帮帮忙啦
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