[讨论]Bug??炸开插入文件块后MText也被炸开。

cqszgs

我用VBA将一个DWG文件插入当前文件中，代码如下：
插入结果是MText也被炸开称为Text，但是PLine等却没有被炸开，请问是不是CAD的bug？
我用的是AutoCAD2000中文版。

Public Sub insertFile()
  Dim insertPoint(0 To 2) As Double
  Dim block As AcadBlockReference
  Dim FileToInsert As String
  insertPoint(0) = 0
  insertPoint(1) = 0
  insertPoint(2) = 0
  
  FileToInsert = "C:\MText.dwg"
  Set block = ThisDrawing.ModelSpace.InsertBlock(insertPoint, FileToInsert, 1, 1, 1, 0)
  block.Explode
  'block.Delete
End Sub

topirol

呵呵，奇怪了，居然跟用Explode命令的效果不同？

实在不行的话就用thisdrawing.sendcommand "Explode last  "
来代替block.Explode咯

cqszgs

谢谢回复！
看来我只有用sendcommand代替了。

cqszgs

刚刚实际应用时发现一点小问题：当被插入的文件中有图层被关闭时用"Explode last  "时不会炸开图形，修改为直接使用句柄作为Explode的参数即可。完整代码如下：


Public Sub insertFile()
  Dim insertPoint(0 To 2) As Double
  Dim block As AcadBlockReference
  Dim FileToInsert As String
  insertPoint(0) = 0
  insertPoint(1) = 0
  insertPoint(2) = 0
  
  FileToInsert = "C:\MText.dwg"
  Set block = ThisDrawing.ModelSpace.InsertBlock(insertPoint, FileToInsert, 1, 1, 1, 0)
  'block.Explode
  'block.Delete
'  ThisDrawing.SendCommand "explode " & axEnt2lspEnt(block) & "  "
   ThisDrawing.SendCommand "explode last  "

End Sub
Public Function axEnt2lspEnt(entObj As AcadEntity) As String
    Dim entHandle As String
    entHandle = entObj.Handle
    axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function

mccad

以下函数可解决该问题，该函数使用了大家比较少认识的CopyObjects方法来直接将图块中的对象复制到当前的空间中并按照插入点的位置移动到图块插入的位置。

2. Sub BlkExp()
   
3.     Dim ent As AcadEntity
   
4.     Dim pnt As Variant
   
5.     On Error Resume Next
   
6.     Do
   
7.         ThisDrawing.Utility.GetEntity ent, pnt, "选择要分解的图块参照对象:"
   
8.         If Err <> 0 Then
   
9.             Err.Clear
   
10.         Else
    
11.             If ent.ObjectName = "AcDbBlockReference" Then Exit Do
    
12.         End If
    
13.     Loop
    
14.     MsgBox "选定的图块被分解后共有" & UBound(BlockRefExplode(ent)) & "个图元。", , "明经通道VBA示例"
    
15. End Sub
    
16. 
    
17. ' 该函数用于代替ActiveX方法中图块的Explode方法， _
    
18.   因为原先的Explode方法带有BUG， _
    
19.   分解带MText时连MText都被分解成Text。
    
20.   
    
21. Function BlockRefExplode(BlockRef As AcadBlockReference) As Variant
    
22. 
    
23.     Dim Space As AcadBlock
    
24.     Dim BlockName As String
    
25.     Dim InsertPoint As Variant
    
26.     Dim OriginPoint(2) As Double
    
27.     Dim Block As AcadBlock
    
28. 
    
29.     BlockName = BlockRef.Name
    
30.     InsertPoint = BlockRef.InsertionPoint
    
31.     Set Space = ThisDrawing.ObjectIdToObject(BlockRef.OwnerID)
    
32.     Set Block = ThisDrawing.Blocks(BlockName)
    
33. 
    
34.     Dim BlkEnt() As AcadEntity
    
35.     ReDim BlkEnt(Block.Count - 1)
    
36.     Dim i As Long
    
37.     For i = 0 To Block.Count - 1
    
38.         Set BlkEnt(i) = Block(i)
    
39.     Next
    
40. 
    
41.     Dim SpaceCount As Long
    
42.     SpaceCount = Space.Count
    
43.     ThisDrawing.CopyObjects BlkEnt, Space
    
44.    
    
45.     Dim TotalCount As Long
    
46.     TotalCount = Space.Count - SpaceCount
    
47.    
    
48.     Dim BlkRefEnt() As AcadEntity
    
49.     ReDim BlkRefEnt(TotalCount)
    
50.     For i = 0 To TotalCount - 1
    
51.         Space(i + SpaceCount).Move OriginPoint, InsertPoint
    
52.         Set BlkRefEnt(i) = Space(i + SpaceCount)
    
53.     Next
    
54. 
    
55.     BlockRef.Delete
    
56.     BlockRefExplode = BlkRefEnt
    
57. End Function
    

Sub BlkExp()<br />     Dim ent As AcadEntity<br />     Dim pnt As Variant<br />     On Error Resume Next<br />     Do<br />         ThisDrawing.Utility.GetEntity ent, pnt, "选择要分解的图块参照对象:"<br />         If Err <> 0 Then<br />             Err.Clear<br />         Else<br />             If ent.ObjectName = "AcDbBlockReference" Then Exit Do<br />         End If<br />     Loop<br />     MsgBox "选定的图块被分解后共有" & UBound(BlockRefExplode(ent)) & "个图元。", , "明经通道VBA示例"<br /> End Sub<br /> <br /> ' 该函数用于代替ActiveX方法中图块的Explode方法， _<br />   因为原先的Explode方法带有BUG， _<br />   分解带MText时连MText都被分解成Text。<br />   <br /> Function BlockRefExplode(BlockRef As AcadBlockReference) As Variant<br /> <br />     Dim Space As AcadBlock<br />     Dim BlockName As String<br />     Dim InsertPoint As Variant<br />     Dim OriginPoint(2) As Double<br />     Dim Block As AcadBlock<br /> <br />     BlockName = BlockRef.Name<br />     InsertPoint = BlockRef.InsertionPoint<br />     Set Space = ThisDrawing.ObjectIdToObject(BlockRef.OwnerID)<br />     Set Block = ThisDrawing.Blocks(BlockName)<br /> <br />     Dim BlkEnt() As AcadEntity<br />     ReDim BlkEnt(Block.Count - 1)<br />     Dim i As Long<br />     For i = 0 To Block.Count - 1<br />         Set BlkEnt(i) = Block(i)<br />     Next<br /> <br />     Dim SpaceCount As Long<br />     SpaceCount = Space.Count<br />     ThisDrawing.CopyObjects BlkEnt, Space<br />     <br />     Dim TotalCount As Long<br />     TotalCount = Space.Count - SpaceCount<br />     <br />     Dim BlkRefEnt() As AcadEntity<br />     ReDim BlkRefEnt(TotalCount)<br />     For i = 0 To TotalCount - 1<br />         Space(i + SpaceCount).Move OriginPoint, InsertPoint<br />         Set BlkRefEnt(i) = Space(i + SpaceCount)<br />     Next<br /> <br />     BlockRef.Delete<br />     BlockRefExplode = BlkRefEnt<br /> End Function<br />

cqszgs

谢谢老大！
我认为直接用Sendcommand运行CAD的命令不是太好，但是有时候又不知道如何直接用VBA解决一些问题，下面的代码也是直接用CAD的Pedit命令将一些首尾相连的直线连接成一个PLine，老大可不可以转换为直接使用VBA函数实现同样功能？

'合并选择集中分离的线为PLine
Public Sub JoinLineToPline(sel As AcadSelectionSet)
   Dim strCommand As String
    strCommand = "_Pedit" & vbCr & axEnt2lspEnt(sel.Item(0)) & " Y J "
    Dim i As Integer
      For i = 0 To sel.Count - 1
        strCommand = strCommand + axEnt2lspEnt(sel.Item(i)) + vbCr
      Next
      strCommand = strCommand + vbCr + vbCr
      ThisDrawing.SendCommand strCommand
End Sub