明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 4289|回复: 6

用SendCommand执行cad命令,获得生成的图元对象

[复制链接]
发表于 2017-10-21 19:05 | 显示全部楼层 |阅读模式
本帖最后由 zzyong00 于 2017-10-21 19:07 编辑

用SendCommand执行cad命令,获得生成的图元对象的方法一般是用ModelSpace的对象数量索引(ThisDrawing.ModelSpace.Count)来取得,
好像一般新生成的对象,在ModelSpace中的索引,都是排在最后(我没从官方文档中看到这个描述),取得方法:
Dim oEnt as AcadEntity
Set oEnt = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1)
如果执行一个命令,生成的对象比较多,哪么在执行cad命令前记录一下ThisDrawing.ModelSpace.Count在执行后再记录一下ThisDrawing.ModelSpace.Count ,就可以把取得所有生成的对象了.
但我觉得以上方法,在一些特定的情况下,可能会有问题,所以,我一般采用我自己的方法,现在介绍一下我自己的方法:利用documment的事件.
直接上代码:
  1. Option Explicit
  2. 'By zzyong00 原创
  3. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)




  4. 'AutoCAD的documment对象的事件类,专门为用sendcommand产生的对象使用
  5. Public WithEvents Document As AcadDocument


  6. Public colEntityHandle     As Collection                    '保存更改的对象的handle
  7. Public EvalCmd As String '设置正在执行的命令
  8. Private EvalStatus As Boolean '标志命令执行的情况,是否完成,已完成为true
  9. Private Sub Class_Initialize()
  10.     Set colEntityHandle = New Collection                    '保存更改的对象的handle
  11.     EvalStatus = False
  12. End Sub


  13. Private Sub Document_EndCommand(ByVal CommandName As String)
  14.     If LCase(CommandName) = LCase(EvalCmd) Then EvalStatus = True
  15. End Sub


  16. Private Sub Document_ObjectModified(ByVal Object As Object)                     '将图中更改的对象handle添加到集合中
  17.    
  18.     'Debug.Print "Modify:", TypeName(Object), Object.Handle
  19.     If Not TypeName(Object) = "IAcadModelSpace" Then colEntityHandle.Add Object.Handle
  20. End Sub
  21. Public Sub ClearEntityHandleCol()                           '每用完一次,都得清理一下,才能保证是每执行一个命令,集合保存的是最新改变的对象handle
  22.    
  23.     Dim i As Long
  24.    
  25.     For i = colEntityHandle.Count To 1 Step -1
  26.         colEntityHandle.Remove 1
  27.     Next
  28.    
  29. End Sub
  30. Public Function IsExistHandle(ByVal strH As String) As Boolean '判断一个handle是否存在真的对象
  31.     On Error GoTo err1
  32.     Dim objEnt As AcadObject
  33.     Set objEnt = Document.HandleToObject(strH)
  34.     IsExistHandle = True
  35.     Exit Function
  36. err1:
  37.     IsExistHandle = False
  38.     Err.Clear
  39. End Function


  40. Public Sub ClearInvalidHandle() '清除掉无效的句柄,对象已被删除
  41.     Dim j As Long
  42.     For j = colEntityHandle.Count To 1 Step -1
  43.         If Not IsExistHandle(colEntityHandle(j)) Then
  44.             colEntityHandle.Remove j
  45.         End If
  46.     Next j
  47. End Sub


  48. Public Sub WaitForEvalCmdComplete()
  49.     Do
  50.         Sleep 1
  51.         DoEvents
  52.     Loop Until EvalStatus = True
  53.     EvalStatus = False
  54. End Sub



上面代码是我的clsDocumentEvent.cls类,其利用Document_ObjectModified获取修改或生成的对象,Document_EndCommand确认命令执行结束.
以下,测试一下extend和boundary命令:

  1. Option Explicit
  2. 'By zzyong00 原创


  3. Private Sub MyExtend(objPL1 As AcadObject, objPL2 As AcadObject) '延长命令
  4.     'objPL1 延长的目标
  5.     'objPL2 要延长的线
  6.     Dim objDoc As AcadDocument
  7.     Set objDoc = ThisDrawing
  8.     Dim objCls      As New clsDocumentEvent
  9.     If objPL1.ObjectName = "AcDbPolyline" And objPL2.ObjectName = "AcDbPolyline" Then
  10.         Set objCls.Document = objDoc
  11.         objCls.EvalCmd = "extend"


  12.         objDoc.SendCommand "_extend" & vbCr & "(handent """ & objPL1.Handle & """)" & vbCr & vbCr & "(handent """ & objPL2.Handle & """)" & vbCr & vbCr  '不同autocad版本,命令格式可能稍有不同


  13.         objCls.WaitForEvalCmdComplete
  14.         objCls.ClearInvalidHandle
  15.     End If
  16.     Dim i As Long, objEnt As AcadEntity, objNewPl As AcadLWPolyline
  17.     Dim objColor As AcadAcCmColor
  18.     Set objColor = objCad.GetInterfaceObject("AutoCAD.AcCmColor." & Left$(objCad.Version, 2))
  19.     objColor.ColorIndex = acBlue
  20.     If objCls.colEntityHandle.Count >= 1 Then
  21.         For i = 1 To objCls.colEntityHandle.Count
  22.             Set objEnt = objDoc.HandleToObject(objCls.colEntityHandle.Item(i))
  23.             If objEnt.ObjectName = "AcDbPolyline" Then


  24.                 Set objNewPl = objEnt   '在这儿,我们获取到了执行命令后变化的对象
  25.                 '                    Debug.Print objNewPl.Length
  26.                 objNewPl.TrueColor = objColor    '把它颜色改成蓝色
  27.             End If
  28.         Next i
  29.     End If


  30.     Set objCls.Document = Nothing
  31.     objCls.ClearEntityHandleCol
  32. End Sub


  33. Private Sub MyBoundary(Pt1 As Variant, strObjHdl As String)
  34.     '---------------------------
  35.     '    If VarType(pt1) <> vbEmpty Then
  36.     '    If UBound(pt1) >= 1 Then
  37.     '        strCmd = "-boundary" & vbCr & "a" & vbCr & "o" & vbCr & "p" & vbCr & "i" & vbCr & "y" & vbCr & "b" & vbCr & "n" & _
  38.         '        vbCr & strObjHdl & vbCr & vbCr & pt1(0) & "," & pt1(1) & vbCr & vbCr
  39.     '        'strObjHdl="(handent """ & objB.Handle & """)" & vbCr & "(handent """ & objPL.Handle & """)" & vbCr
  40.     '    End If
  41.     '
  42.     '    Debug.Print strCmd
  43.     '    ThisDrawing.SendCommand strCmd
  44.     '-----------------------
  45.     '以前版本


  46.     Static lcount As Long


  47.     Dim strCmd    As String


  48.     If lcount = 0 Then
  49.         If VarType(Pt1) <> vbEmpty Then
  50.             If UBound(Pt1) >= 1 Then
  51.                 '                strCmd = "-boundary" & vbCr & "a" & vbCr & "o" & vbCr & "p" & vbCr & _
  52.                     '                vbCr & pt1(0) & "," & pt1(1) & vbCr & vbCr
  53.                 strCmd = "-boundary" & vbCr & "a" & vbCr & "o" & vbCr & "p" & vbCr & "i" & vbCr & "y" & vbCr & "b" & vbCr & "n" & _
  54.                          vbCr & strObjHdl & vbCr & vbCr & Pt1(0) & "," & Pt1(1) & vbCr & vbCr
  55.                 'strObjHdl="(handent """ & objB.Handle & """)" & vbCr & "(handent """ & objPL.Handle & """)" & vbCr
  56.             End If


  57.             'Debug.Print strCmd
  58.             ThisDrawing.SendCommand strCmd
  59.             lcount = 1
  60.         End If


  61.     Else


  62.         If VarType(Pt1) <> vbEmpty Then
  63.             If UBound(Pt1) >= 1 Then
  64.                 strCmd = "-boundary" & vbCr & "a" & vbCr & "b" & vbCr & "n" & vbCr & strObjHdl & vbCr & vbCr & Pt1(0) & "," & Pt1(1) & vbCr & vbCr
  65.             End If


  66.             'Debug.Print strCmd
  67.             ThisDrawing.SendCommand strCmd
  68.         End If
  69.     End If


  70. End Sub


  71. Private Sub Boundary() '测试Boundary用
  72.     On Error GoTo err1


  73.     Dim pt  As Variant
  74.     Dim objDoc As AcadDocument
  75.     Set objDoc = ThisDrawing
  76.     pt = objDoc.Utility.GetPoint(, "请指定封闭区间内一点:")


  77.     Dim objCls      As New clsDocumentEvent
  78.     Set objCls.Document = objDoc '关联Document对象和clsDocumentEvent对象
  79.     objCls.EvalCmd = "-boundary"  '传递要用sendcommand执行的cad命令
  80.     MyBoundary pt, ""             'sendcommand 执行cad命令
  81.     objCls.WaitForEvalCmdComplete  '等待cad命令执行完
  82.     objCls.ClearInvalidHandle      '清除某些命令的临时产物,有些cad命令在执行过程中,会产生临时的cad对象,最后系统又会把它们删掉,所以要剔除这样的对象句柄
  83.     '从objCls.colEntityHandle集合中提取执行cad命令生成的对象.
  84.     Dim objEnt As AcadEntity, i As Long, objNewPl() As AcadLWPolyline, lngPl_count As Long
  85.     If objCls.colEntityHandle.Count >= 1 Then
  86.         lngPl_count = 0
  87.         For i = 1 To objCls.colEntityHandle.Count


  88.             Set objEnt = objDoc.HandleToObject(objCls.colEntityHandle.Item(i))
  89.             If objEnt.ObjectName = "AcDbPolyline" Then
  90.                 ReDim objNewPl(lngPl_count)
  91.                 Set objNewPl(lngPl_count) = objEnt
  92.                 'Debug.Print objNewPl(lngPl_count).Coordinate(0)(0), objNewPl( _
  93.                     lngPl_count).Coordinate(0)(1)
  94.                 lngPl_count = lngPl_count + 1
  95.             End If


  96.         Next i
  97.     End If
  98.     Set objCls = Nothing
  99.     Dim objColor As AcadAcCmColor
  100.     Set objColor = objCad.GetInterfaceObject("AutoCAD.AcCmColor." & Left$(objCad.Version, 2))
  101.     objColor.ColorIndex = acGreen


  102.     If lngPl_count >= 1 Then
  103.         For i = 0 To UBound(objNewPl)
  104.             objNewPl(i).TrueColor = objColor
  105.             MsgBox "封闭区域面积为:" & objNewPl(i).Area
  106.         Next i
  107.     End If
  108.     Exit Sub
  109. err1:
  110.     Debug.Print Err.Description
  111. End Sub


  112. Private Sub Command1_Click()
  113.     AppActivate objCad.Caption
  114.     Dim objPL1 As AcadLWPolyline, objPL2 As AcadLWPolyline
  115.     Dim blnESC As Boolean
  116.     SelectPl objPL1, blnESC
  117.     If blnESC Then Exit Sub
  118.     SelectPl objPL2, blnESC
  119.     If blnESC Then Exit Sub


  120.     MyExtend objPL1, objPL2


  121. End Sub


  122. Private Sub Command2_Click()
  123.     AppActivate objCad.Caption


  124.     Boundary
  125. End Sub


  126. Private Sub Form_Load()
  127.     ConnectAutoCAD
  128. End Sub


  129. Private Sub SelectPl(returnObj As AcadLWPolyline, blnESC As Boolean)
  130.     Dim basePnt As Variant
  131.     On Error Resume Next


  132. RETRY:
  133.     ThisDrawing.Utility.GetEntity returnObj, basePnt, "请选择pl线:"
  134.     ' Debug.Print Err.Number, Err.Description


  135.     If Err.Number = -2147352567 Then
  136.         blnESC = True
  137.         Exit Sub
  138.     End If


  139.     If Err <> 0 Then
  140.         Err.Clear
  141.         GoTo RETRY
  142.     Else
  143.         returnObj.Highlight True
  144.     End If
  145. End Sub



最后,把完整vb6工程上传:

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

不喜欢用SendCommand  发表于 2022-7-26 09:27
发表于 2017-10-21 22:17 | 显示全部楼层
虽然不咋喜欢用SendCommand 但为大神点赞
发表于 2017-10-23 08:59 | 显示全部楼层
回帖是一种美德!感谢楼主的无私分享 谢谢
发表于 2018-7-5 14:40 | 显示全部楼层
请教版主,写了一个VBA的命令是想通过VBA调用CAD的的arraypath沿路径阵列的命令。在VBA编辑器下运行时,一切正常;但是用CAD的VBARUN,运行test过程的时候,在第二次“SendCommand”就出现“运行时错误执行环境无效”,请帮忙诊断一下问题的原因

点评

你的问题没有代表性,在我电脑里一切正常,所以,很难分析出原因  发表于 2018-7-6 11:59
发表于 2018-7-5 14:41 | 显示全部楼层
本帖最后由 wit0708 于 2018-7-5 14:42 编辑

Public Sub test()

   Dim I
   Dim n
   Dim po(1 To 3) '阵列长度
   n = 3
    po(1) = 1
    po(2) = 2
    po(3) = 3
  

Dim p1 As Variant
p1 = ThisDrawing.Utility.GetPoint(, "选择基点位置:") '点选基底位置坐标
Dim path1 As AcadEntity
Dim pnt As Variant
ThisDrawing.Utility.GetEntity path1, pnt, "选择路径:" '沿此路径阵列
'绘制一条直线,与基点相关
Dim line1 As AcadLine
Dim line4 As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
startPoint(0) = p1(0): startPoint(1) = p1(1) - 1.6: startPoint(2) = p1(2)
endPoint(0) = p1(0): endPoint(1) = p1(1) + 1.6: endPoint(2) = p1(2)

Set line1 = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)


Dim strr(12)
strr(0) = "_arraypath"
strr(1) = GetDoubleEntTable(line1, pnt)
strr(3) = GetDoubleEntTable(path1, pnt)
strr(4) = "as"
strr(5) = "N"
strr(6) = "I"
strr(8) = 2
strr(9) = "A"
strr(10) = "Y"
strr(11) = "x"


strr(7) = po(1)

ThisDrawing.SendCommand Join(strr, vbCr)

strr(7) = po(2)

ThisDrawing.SendCommand Join(strr, vbCr) '运行到此处出错

End Sub

'转换双元表的函数
Public Function GetDoubleEntTable(entobj As AcadEntity, pnt As Variant) As String
Dim entHandle As String
entHandle = entobj.Handle
GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & ")(list " & Str(pnt(0)) & Str(pnt(1)) & Str(pnt(2)) & "))"
End Function
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-28 23:45 , Processed in 0.326285 second(s), 24 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表