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

cqszgs · 发表于 2003-12-16 09:26:00

我用VBA将一个DWG文件插入当前文件中，代码如下：
插入结果是MText也被炸开称为Text，但是PLine等却没有被炸开，请问是不是CAD的bug？
我用的是2000中文版。
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 · 发表于 2003-12-16 09:58:00

呵呵，奇怪了，居然跟用Explode命令的效果不同？
实在不行的话就用thisdrawing.sendcommand "Explode last "
来代替block.Explode咯

cqszgs · 发表于 2003-12-16 10:17:00

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

cqszgs · 发表于 2003-12-16 15:41:00

刚刚实际应用时发现一点小问题：当被插入的文件中有图层被关闭时用"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 · 发表于 2003-12-17 15:11:00

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

copy


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

cqszgs · 发表于 2003-12-18 11:40:00

谢谢老大！
我认为直接用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

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

发表回复

精选推荐