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

hunterah 发表于 2006-7-7 17:20:00

本帖最后由作者于 2006-7-9 10:31:03 编辑 的程序主要功能是通过在屏幕上选择两个点定义矩形区域，将选中的图元按比例缩放限制在这个定义的矩形区域内。程序具体如下：
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 发表于 2006-7-7 23:08:00

本帖最后由作者于 2006-7-7 23:53:39 编辑 1

mccad 发表于 2006-7-8 07:18:00

与插入点有关，你定义的插入点是原点。
可以将插入点定义在块的左下角。这样就可以与区域对应。

hunterah 发表于 2006-7-8 18:00:00

感谢你的解答，我修改后的程序如下，插入点问题解决了，就是调试运行中执行<A name=22525>blkrefobj.Explode   '运行此句总是出错，提示“输入无效”，请问是何原因？</A>
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

兰州人 发表于 2006-7-9 08:43:00

我发的帖子比"求解答插入块问题。解决了1个还有1个问题"要早.可是你回答了他的问题.
我买的"Auto CAD VBA 二次开发教程"
运行14.4 使用ADODC控件示例程序出现以下错误
"无法装载这个对象，因为它不适用这台计算机。"
希望尽快解答，问题详见我发的帖子.

932516 发表于 2006-7-9 09:17:00

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

hunterah 发表于 2006-7-9 10:24:00

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

mccad 发表于 2006-7-9 13:47:00

因为通过VBA使用XY不同比例插入的块，是不能用VBA的方法炸开的。
你可以使用SendCommand来完成。

hunterah 发表于 2006-7-9 17:57:00

VBA会有这样的限制?
我也曾用过sendcommand语句,不过不是太会用.
我写的是:
ThisDrawing.SendCommand "_explode" + Chr(13)   执行此句时提示选择图元.
不知道如何自动将插入的图块作为选择集传递到explode命令中,只能在命令执行时根据提示再人工选择插入的图块.而我不想有这样的交互过程.
能根据我的程序给一个具体的代码吗?

68651521 发表于 2006-7-10 11:37:00

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

页: [1] 2

明经CAD社区's Archiver

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