求解答插入块后炸开问题。解决了1个还有1个问题

hunterah

的程序主要功能是通过在屏幕上选择两个点定义矩形区域，将选中的图元按比例缩放限制在这个定义的矩形区域内。程序具体如下：

Sub adjust_scale()

    Dim ss As AcadSelectionSet
    Dim pt(0 To 2) As Double
    Dim i As Integer
   
    ThisDrawing.PurgeAll
   
    pt(0) = 0
    pt(1) = 0
    pt(2) = 0
   
    Dim bk As AcadBlock
   
    Set bk = ThisDrawing.Blocks.Add(pt, "tempblock")
   
    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")
   
    ss.SelectOnScreen
   
      
    ReDim retval(0 To ss.Count - 1) As AcadEntity
    For i = 0 To ss.Count - 1
        Set retval(i) = ss.Item(i)
    Next
   
       
    ThisDrawing.CopyObjects retval, bk
    Erase retval
   
    Dim c1 As Variant
    Dim c2 As Variant
   
    c1 = ThisDrawing.Utility.GetPoint(, "选择边界点1:")
    c2 = ThisDrawing.Utility.GetPoint(, "选择边界点2:")
   
    Dim d(1) As Double
   
    d(0) = VBA.Abs(c1(0) - c2(0))
    d(1) = VBA.Abs(c1(1) - c2(1))
   
      
    Dim entobj As AcadEntity
    Dim minext As Variant, maxext As Variant
    Dim a(2), b(2) As Double
 
    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
      
     Dim e(1) As Double
      
     e(0) = VBA.Abs(b(0) - a(0))
     e(1) = VBA.Abs(b(1) - a(1))
      
    ss.Erase
       
    Dim inspt(2) As Double
    Dim blkrefobj As AcadBlockReference
   
    inspt(0) = 0: inspt(1) = 0: inspt(2) = 0
   
   
    Dim s As Double
    Dim smin As Double
    
    smin = d(1) / e(1)
    
    If smin > d(0) / e(0) Then
       smin = d(0) / e(0)
    End If
  
    s = smin
   
    Set blkrefobj = ThisDrawing.ModelSpace.InsertBlock(inspt, "tempblock", s, s, 1, 0)
   
    blkrefobj.Update
   
    blkrefobj.Explode   '运行此句总是出错，哪位大虾能帮助解决？
    
    blkrefobj.Delete
   
    Application.Update
   
    ThisDrawing.PurgeAll
   
    'Application.ZoomExtents
  
   
End Sub

另外，敢问斑竹块的插入点和显示位置有什么关系，怎么设置才对？

hunterah

1

mccad

与插入点有关，你定义的插入点是原点。

可以将插入点定义在块的左下角。这样就可以与区域对应。

hunterah

感谢你的解答，我修改后的程序如下，插入点问题解决了，就是调试运行中执行blkrefobj.Explode   '运行此句总是出错，提示“输入无效”，请问是何原因？

Sub adjust_scale()

    Dim ss As AcadSelectionSet
    Dim pt(0 To 2) As Double
    Dim i As Integer
   
    ThisDrawing.PurgeAll
   
    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")
   
    ss.SelectOnScreen
   
      
    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(2), b(2) As Double
 
    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
   
    ss.Erase
   
   
    Dim c1 As Variant
    Dim c2 As Variant
   
    c1 = ThisDrawing.Utility.GetPoint(, "选择边界点1:")
    c2 = ThisDrawing.Utility.GetPoint(, "选择边界点2:")
   
    Dim d(1) As Double
   
    d(0) = VBA.Abs(c1(0) - c2(0))
    d(1) = VBA.Abs(c1(1) - c2(1))
   
    Dim e(1) As Double
      
    e(0) = VBA.Abs(b(0) - a(0))
    e(1) = VBA.Abs(b(1) - a(1))
    
       
    Dim inspt(2) As Double
    Dim blkrefobj As AcadBlockReference
   
    inspt(0) = b(0): inspt(1) = b(1): inspt(2) = b(2)
   
   
    Dim s As Double
    Dim smin As Double
    
    smin = d(1) / e(1)
    
    If smin > d(0) / e(0) Then
       smin = d(0) / e(0)
    End If
  
    s = smin
   
    Set blkrefobj = ThisDrawing.ModelSpace.InsertBlock(inspt, "tempblock", s, s, 1, 0)
   
    blkrefobj.Update
   
    blkrefobj.Explode  '运行此句总是出错，提示“输入无效”
    
    blkrefobj.Delete
   
    Application.Update
   
    ThisDrawing.PurgeAll
   
    'Application.ZoomExtents
  
   
End Sub

兰州人

我发的帖子比"求解答插入块问题。解决了1个还有1个问题"要早.可是你回答了他的问题.

我买的"Auto CAD VBA 二次开发教程"

运行14.4 使用ADODC控件示例程序出现以下错误

"无法装载这个对象，因为它不适用这台计算机。"

希望尽快解答，问题详见我发的帖子.

932516

兰州也有搞CAD开发的同人,倍感亲切

QQ:391652714

hunterah

解答问题也需要时间,我问的问题可能比较浅容易解答,希望兰州人见谅.另外,如果你能解决我的问题,本人也将感激不禁.毕竟来这里是互相切磋的.

mccad

因为通过VBA使用XY不同比例插入的块，是不能用VBA的方法炸开的。

你可以使用SendCommand来完成。

hunterah

VBA会有这样的限制?

我也曾用过sendcommand语句,不过不是太会用.

我写的是:

ThisDrawing.SendCommand "_explode" + Chr(13)   执行此句时提示选择图元.

不知道如何自动将插入的图块作为选择集传递到explode命令中,只能在命令执行时根据提示再人工选择插入的图块.而我不想有这样的交互过程.

能根据我的程序给一个具体的代码吗?

68651521

跟上实体的句柄 就不会有交互了