用SendCommand执行cad命令，获得生成的图元对象
本帖最后由 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的事件．
直接上代码：
Option Explicit
'By zzyong00 原创
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'autocad的documment对象的事件类，专门为用sendcommand产生的对象使用
Public WithEvents Document As AcadDocument
Public colEntityHandle As Collection '保存更改的对象的handle
Public EvalCmd As String '设置正在执行的命令
Private EvalStatus As Boolean '标志命令执行的情况，是否完成，已完成为true
Private Sub Class_Initialize()
Set colEntityHandle = New Collection '保存更改的对象的handle
EvalStatus = False
End Sub
Private Sub Document_EndCommand(ByVal CommandName As String)
If LCase(CommandName) = LCase(EvalCmd) Then EvalStatus = True
End Sub
Private Sub Document_ObjectModified(ByVal Object As Object) '将图中更改的对象handle添加到集合中
'Debug.Print "Modify:", TypeName(Object), Object.Handle
If Not TypeName(Object) = "IAcadModelSpace" Then colEntityHandle.Add Object.Handle
End Sub
Public Sub ClearEntityHandleCol() '每用完一次，都得清理一下，才能保证是每执行一个命令，集合保存的是最新改变的对象handle
Dim i As Long
For i = colEntityHandle.Count To 1 Step -1
colEntityHandle.Remove 1
Next
End Sub
Public Function IsExistHandle(ByVal strH As String) As Boolean '判断一个handle是否存在真的对象
On Error GoTo err1
Dim objEnt As AcadObject
Set objEnt = Document.HandleToObject(strH)
IsExistHandle = True
Exit Function
err1:
IsExistHandle = False
Err.Clear
End Function
Public Sub ClearInvalidHandle() '清除掉无效的句柄，对象已被删除
Dim j As Long
For j = colEntityHandle.Count To 1 Step -1
If Not IsExistHandle(colEntityHandle(j)) Then
colEntityHandle.Remove j
End If
Next j
End Sub
Public Sub WaitForEvalCmdComplete()
Do
Sleep 1
DoEvents
Loop Until EvalStatus = True
EvalStatus = False
End Sub
上面代码是我的clsDocumentEvent.cls类，其利用Document_ObjectModified获取修改或生成的对象，Document_EndCommand确认命令执行结束．
以下，测试一下extend和boundary命令：
Option Explicit
'By zzyong00 原创
Private Sub MyExtend(objPL1 As AcadObject, objPL2 As AcadObject) '延长命令
'objPL1 延长的目标
'objPL2 要延长的线
Dim objDoc As AcadDocument
Set objDoc = ThisDrawing
Dim objCls As New clsDocumentEvent
If objPL1.ObjectName = "AcDbPolyline" And objPL2.ObjectName = "AcDbPolyline" Then
Set objCls.Document = objDoc
objCls.EvalCmd = "extend"
objDoc.SendCommand "_extend" & vbCr & "(handent """ & objPL1.Handle & """)" & vbCr & vbCr & "(handent """ & objPL2.Handle & """)" & vbCr & vbCr'不同autocad版本，命令格式可能稍有不同
objCls.WaitForEvalCmdComplete
objCls.ClearInvalidHandle
End If
Dim i As Long, objEnt As AcadEntity, objNewPl As AcadLWPolyline
Dim objColor As AcadAcCmColor
Set objColor = objCad.GetInterfaceObject("AutoCAD.AcCmColor." & Left$(objCad.Version, 2))
objColor.ColorIndex = acBlue
If objCls.colEntityHandle.Count >= 1 Then
For i = 1 To objCls.colEntityHandle.Count
Set objEnt = objDoc.HandleToObject(objCls.colEntityHandle.Item(i))
If objEnt.ObjectName = "AcDbPolyline" Then
Set objNewPl = objEnt '在这儿，我们获取到了执行命令后变化的对象
' Debug.Print objNewPl.Length
objNewPl.TrueColor = objColor '把它颜色改成蓝色
End If
Next i
End If
Set objCls.Document = Nothing
objCls.ClearEntityHandleCol
End Sub
Private Sub MyBoundary(Pt1 As Variant, strObjHdl As String)
'---------------------------
' If VarType(pt1) <> vbEmpty Then
' If UBound(pt1) >= 1 Then
' strCmd = "-boundary" & vbCr & "a" & vbCr & "o" & vbCr & "p" & vbCr & "i" & vbCr & "y" & vbCr & "b" & vbCr & "n" & _
' vbCr & strObjHdl & vbCr & vbCr & pt1(0) & "," & pt1(1) & vbCr & vbCr
' 'strObjHdl="(handent """ & objB.Handle & """)" & vbCr & "(handent """ & objPL.Handle & """)" & vbCr
' End If
'
' Debug.Print strCmd
' ThisDrawing.SendCommand strCmd
'-----------------------
'以前版本
Static lcount As Long
Dim strCmd As String
If lcount = 0 Then
If VarType(Pt1) <> vbEmpty Then
If UBound(Pt1) >= 1 Then
' strCmd = "-boundary" & vbCr & "a" & vbCr & "o" & vbCr & "p" & vbCr & _
' vbCr & pt1(0) & "," & pt1(1) & vbCr & vbCr
strCmd = "-boundary" & vbCr & "a" & vbCr & "o" & vbCr & "p" & vbCr & "i" & vbCr & "y" & vbCr & "b" & vbCr & "n" & _
vbCr & strObjHdl & vbCr & vbCr & Pt1(0) & "," & Pt1(1) & vbCr & vbCr
'strObjHdl="(handent """ & objB.Handle & """)" & vbCr & "(handent """ & objPL.Handle & """)" & vbCr
End If
'Debug.Print strCmd
ThisDrawing.SendCommand strCmd
lcount = 1
End If
Else
If VarType(Pt1) <> vbEmpty Then
If UBound(Pt1) >= 1 Then
strCmd = "-boundary" & vbCr & "a" & vbCr & "b" & vbCr & "n" & vbCr & strObjHdl & vbCr & vbCr & Pt1(0) & "," & Pt1(1) & vbCr & vbCr
End If
'Debug.Print strCmd
ThisDrawing.SendCommand strCmd
End If
End If
End Sub
Private Sub Boundary() '测试Boundary用
On Error GoTo err1
Dim ptAs Variant
Dim objDoc As AcadDocument
Set objDoc = ThisDrawing
pt = objDoc.Utility.GetPoint(, "请指定封闭区间内一点：")
Dim objCls As New clsDocumentEvent
Set objCls.Document = objDoc '关联Document对象和clsDocumentEvent对象
objCls.EvalCmd = "-boundary"'传递要用sendcommand执行的cad命令
MyBoundary pt, "" 'sendcommand 执行cad命令
objCls.WaitForEvalCmdComplete'等待cad命令执行完
objCls.ClearInvalidHandle '清除某些命令的临时产物，有些cad命令在执行过程中，会产生临时的cad对象，最后系统又会把它们删掉，所以要剔除这样的对象句柄
'从objCls.colEntityHandle集合中提取执行cad命令生成的对象．
Dim objEnt As AcadEntity, i As Long, objNewPl() As AcadLWPolyline, lngPl_count As Long
If objCls.colEntityHandle.Count >= 1 Then
lngPl_count = 0
For i = 1 To objCls.colEntityHandle.Count
Set objEnt = objDoc.HandleToObject(objCls.colEntityHandle.Item(i))
If objEnt.ObjectName = "AcDbPolyline" Then
ReDim objNewPl(lngPl_count)
Set objNewPl(lngPl_count) = objEnt
'Debug.Print objNewPl(lngPl_count).Coordinate(0)(0), objNewPl( _
lngPl_count).Coordinate(0)(1)
lngPl_count = lngPl_count + 1
End If
Next i
End If
Set objCls = Nothing
Dim objColor As AcadAcCmColor
Set objColor = objCad.GetInterfaceObject("AutoCAD.AcCmColor." & Left$(objCad.Version, 2))
objColor.ColorIndex = acGreen
If lngPl_count >= 1 Then
For i = 0 To UBound(objNewPl)
objNewPl(i).TrueColor = objColor
MsgBox "封闭区域面积为：" & objNewPl(i).Area
Next i
End If
Exit Sub
err1:
Debug.Print Err.Description
End Sub
Private Sub Command1_Click()
AppActivate objCad.Caption
Dim objPL1 As AcadLWPolyline, objPL2 As AcadLWPolyline
Dim blnESC As Boolean
SelectPl objPL1, blnESC
If blnESC Then Exit Sub
SelectPl objPL2, blnESC
If blnESC Then Exit Sub
MyExtend objPL1, objPL2
End Sub
Private Sub Command2_Click()
AppActivate objCad.Caption
Boundary
End Sub
Private Sub Form_Load()
ConnectAutoCAD
End Sub
Private Sub SelectPl(returnObj As AcadLWPolyline, blnESC As Boolean)
Dim basePnt As Variant
On Error Resume Next
RETRY:
ThisDrawing.Utility.GetEntity returnObj, basePnt, "请选择pl线："
' Debug.Print Err.Number, Err.Description
If Err.Number = -2147352567 Then
blnESC = True
Exit Sub
End If
If Err <> 0 Then
Err.Clear
GoTo RETRY
Else
returnObj.Highlight True
End If
End Sub
最后，把完整vb6工程上传：
虽然不咋喜欢用SendCommand 但为大神点赞 回帖是一种美德！感谢楼主的无私分享 谢谢 请教版主，写了一个VBA的命令是想通过VBA调用CAD的的arraypath沿路径阵列的命令。在VBA编辑器下运行时，一切正常；但是用CAD的VBARUN，运行test过程的时候，在第二次“SendCommand”就出现“运行时错误执行环境无效”，请帮忙诊断一下问题的原因 本帖最后由 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
页:
[1]