请教用CopyObjects方法产生的块炸碎后插入点偏移的问题

hunterah

在我的程序中先将用CopyObjects方法产生的块插入图纸中，再用EXPLODE炸碎块，然后用DELETE方法删除块，结果炸碎后的对象偏移了我块插入点很远的位置，没办法只好用sendcommand办法手工解决（炸碎后插入点不变），求教版主如何解决？现贴程序中部分内容：

Set blkrefobj = ThisDrawing.ModelSpace.InsertBlock(inspt, "tempblock", smin, smin, smin, 0)
    
   '以下这段用来调整插入后图块的位置

    Dim topt(0 To 2) As Double
    topt(0) = inspt(0) + ((d(0) - e(0) * smin) / 2)
    topt(1) = inspt(1) + ((d(1) - e(1) * smin) / 2)
    topt(2) = 0
   
    blkrefobj.Move inspt, topt    
    blkrefobj.Update

    
    ActiveDocument.Utility.Prompt "接下来请选择插入的图块!炸碎后可进行文字高度调整和旋转角度的工作!"
    
    ThisDrawing.SendCommand "_explode" + Chr(13)  '没办法此处只好手工解决炸碎后插入点偏移的问题
   
    'blkrefobj.Explode
   
    'blkrefobj.Delete
   
    Application.Update

wyj7485

应该是定义块插入点出了问题

hunterah

能指出问题出在哪吗？有没有解决办法？

wyj7485

把程序完整贴上来看看

hunterah

比较乱还属测试阶段不过基本功能可完成，重点看后面。程序的功能是按矩形框大小调整比例。

Public blnCancelled As Boolean
Public s As Double
Public smin As Double
Public sfit As Double
Public sx As Double
Public sy As Double

Sub adjust_scale()

    On Error Resume Next
    ThisDrawing.PurgeAll
   
    Dim ss As AcadSelectionSet
    Dim pt(0 To 2) As Double
    Dim i As Integer
       
    If ThisDrawing.SelectionSets.Count <> 0 Then
       For i = 0 To ThisDrawing.SelectionSets.Count - 1
           ThisDrawing.SelectionSets.Item(i).Delete
       Next
    End If
   
    Set ss = ThisDrawing.SelectionSets.Add("ssss")
    ActiveDocument.Utility.Prompt "确认你选择的不包括图块,否则程序有可能出错!您最好退出此命令炸碎图块后重新操作!"
    ss.SelectOnScreen
   
    If ss.Count <> 0 Then
    ReDim retval(0 To ss.Count - 1) As AcadEntity
   
    For i = 0 To ss.Count - 1
        Set retval(i) = ss.Item(i)
    Next
   
    Dim entObj As AcadEntity
    Dim minext As Variant, maxext As Variant
    Dim a(0 To 2), b(0 To 2) As Double       'a()为右上脚坐标,b()为左下脚坐标
 
    Set entObj = ss.Item(0)
    entObj.GetBoundingBox minext, maxext
 
    a(0) = maxext(0)
    a(1) = maxext(1)
    a(2) = maxext(2)
 
    b(0) = minext(0)
    b(1) = minext(1)
    b(2) = minext(2)
 
    For i = 1 To ss.Count - 1
      
       Set entObj = ss.Item(i)
       entObj.GetBoundingBox minext, maxext
    
       If a(0) < maxext(0) Then
          a(0) = maxext(0)
       End If
     
       If a(1) < maxext(1) Then
          a(1) = maxext(1)
       End If
      
       If b(0) > minext(0) Then
          b(0) = minext(0)
       End If
      
       If b(1) > minext(1) Then
          b(1) = minext(1)
       End If
    
     Next
   
    pt(0) = b(0)
    pt(1) = b(1)
    pt(2) = b(2)
   
    Dim bk As AcadBlock
    Set bk = ThisDrawing.Blocks.Add(pt, "tempblock")
      
    ThisDrawing.CopyObjects retval, bk
    Erase retval
   
    Dim c1 As Variant
    Dim c2 As Variant
    Dim cssize As Integer
   
    cssize = ThisDrawing.Application.Preferences.Display.cursorsize
    ThisDrawing.Application.Preferences.Display.cursorsize = 100
    
c1get:
    c1 = ThisDrawing.Utility.GetPoint(, "选择边界点1:")
    If c1(0) = nil Then GoTo c1get
     
c2get:
    'On Error Resume Next
    c2 = ThisDrawing.Utility.GetCorner(c1, "选择边界点2:")       
    If c2(0) = nil Then GoTo c1get
   
    ThisDrawing.Application.Preferences.Display.cursorsize = cssize
   
    Dim d(0 To 1) As Double
    d(0) = VBA.Abs(c1(0) - c2(0))  '选取范围水平距离
    d(1) = VBA.Abs(c1(1) - c2(1))  '选取范围垂直距离
   
    Dim e(0 To 1) As Double
    e(0) = VBA.Abs(b(0) - a(0))    '选取集合水平距离
    e(1) = VBA.Abs(b(1) - a(1))    '选取集合垂直距离
       
    Dim inspt(0 To 2) As Double
    Dim blkrefobj As AcadBlockReference
   
    If c2(0) < c1(0) Then
       c1(0) = c2(0)
    End If
   
    If c2(1) < c1(1) Then
       c1(1) = c2(1)
    End If
   
    inspt(0) = c1(0): inspt(1) = c1(1): inspt(2) = c1(2)
   
    sx = d(0) / e(0)
    sy = d(1) / e(1)
   
    smin = sy
    If sy > sx Then
       smin = sx
    End If
  
    sfit = CInt(100 * smin) / 100
    sx = smin
    sy = smin
   
    blnCancelled = False
           
    If blnCancelled = False Then
   
    Dim sc As Double
    sc = ThisDrawing.Utility.GetReal("请输入缩放比例" & "(回车使用默认值" & (CInt(100 * smin) / 100) & "):")
    If sc <> nil Then smin = VBA.Abs(sc)
   
    ss.Erase
   
    Set blkrefobj = ThisDrawing.ModelSpace.InsertBlock(inspt, "tempblock", smin, smin, smin, 0)
   
    Dim topt(0 To 2) As Double
    topt(0) = inspt(0) + ((d(0) - e(0) * smin) / 2)
    topt(1) = inspt(1) + ((d(1) - e(1) * smin) / 2)
    topt(2) = 0
   
    blkrefobj.Move inspt, topt
   
    blkrefobj.Update
   
    ActiveDocument.Utility.Prompt "接下来请选择插入的图块!炸碎后可进行文字高度调整和旋转角度的工作!"
    
    ThisDrawing.SendCommand "_explode" + Chr(13)
   
    'blkrefobj.Explode
   
    'blkrefobj.Delete
   
    Application.Update
       
    End If
   

    End If
   
errhandle:
 
    If ThisDrawing.SelectionSets.Count <> 0 Then
       For i = 0 To ThisDrawing.SelectionSets.Count - 1
           ThisDrawing.SelectionSets.Item(i).Delete
       Next
    End If
   
    ThisDrawing.PurgeAll    
   

End Sub

hunterah

侠之大者能帮忙解答吗？

 

wyj7485

是分解的问题,当以不等的X,Y,Z比例系数插入时,分解后的图象与原图形不同,如果都是1:1则不会出现此问题

wyj7485

用以下语句代替ThisDrawing.SendCommand "_explode" + Chr(13)

Dim Handle1
Handle1 = blkrefobj.Handle
ThisDrawing.SendCommand "_explode" & vbCr & "(handent " & Chr(34) & Handle1 & Chr(34) & ")" & vbCr & vbCr

就不用手动干预了

hunterah

谢谢楼上的答复，程序中插入比例X/Y/Z轴都是相等的（均为smin），我也曾注意到不等时炸碎出现的问题。楼上提供的方法帮我解决了大问题，再次表示谢意，希望今后能多得到您的指教。