[讨论]Bug??炸开插入文件块后MText也被炸开。
我用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 呵呵，奇怪了，居然跟用Explode命令的效果不同？
实在不行的话就用thisdrawing.sendcommand "Explode last"
来代替block.Explode咯 谢谢回复！
看来我只有用sendcommand代替了。 刚刚实际应用时发现一点小问题：当被插入的文件中有图层被关闭时用"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 以下函数可解决该问题，该函数使用了大家比较少认识的CopyObjects方法来直接将图块中的对象复制到当前的空间中并按照插入点的位置移动到图块插入的位置。
Sub BlkExp()
Dim ent As AcadEntity
Dim pnt As Variant
On Error Resume Next
Do
ThisDrawing.Utility.GetEntity ent, pnt, "选择要分解的图块参照对象:"
If Err <> 0 Then
Err.Clear
Else
If ent.ObjectName = "AcDbBlockReference" Then Exit Do
End If
Loop
MsgBox "选定的图块被分解后共有" & UBound(BlockRefExplode(ent)) & "个图元。", , "明经通道VBA示例"
End Sub
' 该函数用于代替ActiveX方法中图块的Explode方法， _
因为原先的Explode方法带有BUG， _
分解带MText时连MText都被分解成Text。
Function BlockRefExplode(BlockRef As AcadBlockReference) As Variant
Dim Space As AcadBlock
Dim BlockName As String
Dim InsertPoint As Variant
Dim OriginPoint(2) As Double
Dim Block As AcadBlock
BlockName = BlockRef.Name
InsertPoint = BlockRef.InsertionPoint
Set Space = ThisDrawing.ObjectIdToObject(BlockRef.OwnerID)
Set Block = ThisDrawing.Blocks(BlockName)
Dim BlkEnt() As AcadEntity
ReDim BlkEnt(Block.Count - 1)
Dim i As Long
For i = 0 To Block.Count - 1
Set BlkEnt(i) = Block(i)
Next
Dim SpaceCount As Long
SpaceCount = Space.Count
ThisDrawing.CopyObjects BlkEnt, Space
Dim TotalCount As Long
TotalCount = Space.Count - SpaceCount
Dim BlkRefEnt() As AcadEntity
ReDim BlkRefEnt(TotalCount)
For i = 0 To TotalCount - 1
Space(i + SpaceCount).Move OriginPoint, InsertPoint
Set BlkRefEnt(i) = Space(i + SpaceCount)
Next
BlockRef.Delete
BlockRefExplode = BlkRefEnt
End Function
谢谢老大！
我认为直接用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
页:
[1]