求解答插入块后炸开问题。解决了1个还有1个问题
的程序主要功能是通过在屏幕上选择两个点定义矩形区域，将选中的图元按比例缩放限制在这个定义的矩形区域内。程序具体如下：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.Count0 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)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
另外，敢问斑竹块的插入点和显示位置有什么关系，怎么设置才对？
1
与插入点有关，你定义的插入点是原点。
可以将插入点定义在块的左下角。这样就可以与区域对应。
感谢你的解答，我修改后的程序如下，插入点问题解决了，就是调试运行中执行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.Count0 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)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控件示例程序出现以下错误
"无法装载这个对象，因为它不适用这台计算机。"
希望尽快解答，问题详见我发的帖子.
兰州也有搞CAD开发的同人,倍感亲切
QQ:391652714
解答问题也需要时间,我问的问题可能比较浅容易解答,希望兰州人见谅.另外,如果你能解决我的问题,本人也将感激不禁.毕竟来这里是互相切磋的.
因为通过VBA使用XY不同比例插入的块，是不能用VBA的方法炸开的。
你可以使用SendCommand来完成。
VBA会有这样的限制?
我也曾用过sendcommand语句,不过不是太会用.
我写的是:
ThisDrawing.SendCommand "_explode" + Chr(13) 执行此句时提示选择图元.
不知道如何自动将插入的图块作为选择集传递到explode命令中,只能在命令执行时根据提示再人工选择插入的图块.而我不想有这样的交互过程.
能根据我的程序给一个具体的代码吗?
跟上实体的句柄 就不会有交互了
页:
[1]