VB控制AUTOCAD求三个面域并集求助

逆风的香

请教大家一个问题，我想求三个面域组成的隔热型材的并集，在CAD中计算很容易，但我现在想通过VB控制AutoCAD去求三
个面域的并集（按钮：“隔热型材求并集”），我编写了VB源代码，但怎么也实现不了，求各位兄弟帮忙！我附上设计的
源程序及CAD断面图纸！我求隔热型材并集主要是想通过VB求隔热型材的惯性矩，谢谢大家！QQ：515127998
进入autocad的VB源代码
Dim varBmk As Variant
Dim acadApp As New AcadApplication
Dim acadDocs As AcadDocuments
Dim acadDoc As AcadDocument
Private Sub Command1_Click()
On Error Resume Next
Set acadApp = GetObject(, "autocad.application")   '若AutoCad 已启动 , 则直接得到
If Err Then
   Err.Clear
   Set acadApp = CreateObject("autocad.application")   '若AutoCad未启动，则运行它
   If Err Then
     MsgBox Err.Description
     Exit Sub
   End If
End If
acadApp.Visible = True  '使AutoCad可见
Set acadDoc = acadApp.ActiveDocument   '设acaddoc为当前图形文件
Set mospace = acadDoc.ModelSpace  '设mospace为当前图形文件的模型空间
Set acadDocs = acadApp.Documents
AppActivate acadApp.Caption
acadApp.Documents.Add
End Sub
求并集部分VB源代码
Private Sub Command14_Click()
Dim obj_region() As Object
Dim RoomObjects(0 To 2) As Object
Dim curvers(0 To 2) As Object
Dim ssetObj As AcadSelectionSet
On Error Resume Next
Set ssetObj = acadApp.ActiveDocument.SelectionSets.Add("example")
If Err.Number <> 0 Then
    Set ssetObj = acadApp.ActiveDocument.SelectionSets.Item("example")
    ssetObj.Clear
End If
ssetObj.SelectOnScreen
Set RoomObjects(0) = ssetObj(0)
Set curvers(0) = RoomObjects(0)
Set RoomObjects(1) = ssetObj(1)
Set curvers(1) = RoomObjects(1)
Set RoomObjects(2) = ssetObj(2)
Set curvers(2) = RoomObjects(2)
Dim regions As Variant
regions = acadApp.ActiveDocument.ModelSpace.AddRegion(curvers)
Dim RoundRoomObja As AcadRegion
Dim RoundRoomObjb As AcadRegion
Dim RoundRoomObjc As AcadRegion
Set RoundRoomObja = regions(0)
Set RoundRoomObjb = regions(1)
Set RoundRoomObjc = regions(2)
RoundRoomObja.Boolean acUnion, RoundRoomObjb
RoundRoomObjb.Boolean acUnion, RoundRoomObjc
RoundRoomObja.Update
RoundRoomObjb.Update
RoundRoomObjc.Update
acadApp.ActiveDocument.Regen True
ZoomExtents
End Sub

kuangben8

woaishuijia 发表于 2013-10-2 16:24
本以为你这段代码是试验用的,只针对特殊情况.原来你在做面域这一步就理解错了
下面详细剖析一下你这段代码 ...

老师太热心了！感谢老师的答疑解惑。

逆风的香

麻烦大家了！源代码和图我都上传了！琢磨了几天这个问题了！其实直接在autocad中求三个面域的并集很简单，但在VB控制AUTOCAD求并集咋就这么难呢！我现在是必须在VB控制AUTOCAD求并集才行，因为我要求并集后的惯性矩！这关不过我通过VB求隔热型材惯性矩就实现不了！

woaishuijia

你的并集方法用错了

1. RoundRoomObja.Boolean acUnion, RoundRoomObjb

复制代码

这一行是把 RoundRoomObjb 并到 RoundRoomObja 上,运行的结果的 RoundRoomObja 被改变, RoundRoomObjb 没了.你下面一行

1. RoundRoomObjb.Boolean acUnion, RoundRoomObjc

复制代码

自然是错的了
正确的方法是

1. RoundRoomObja.Boolean acUnion, RoundRoomObjb
   
2. RoundRoomObja.Boolean acUnion, RoundRoomObjc

复制代码

而且后面的

1. RoundRoomObjb.Update
   
2. RoundRoomObjc.Update

复制代码

也没有意义

逆风的香

我按您提示的代码作了修改！但结果还是让我郁闷！运算后面域没有任何变化，根本就没有并集！我到底错在哪里了呢！还需要您指导！为这事我都紧张了好几天！

逆风的香

我今早演示了一下，把代码稍作修改
RoundRoomObja.Update
RoomObjects(0).Delete
RoomObjects(1).Delete
RoomObjects(2).Delete
我用三个实心圆去演示，程序运行后求得的是真实的并集，看来您的思路是完全正确的，离解决问题就差很小一步了，我认为肯定是我关于面域实体的定义哪个地方有问题！欢迎您再指点！我真心感激您！我觉得自己在没有目标的情况下探索还不如有朋友指点！

逆风的香

只要是非实心的面域还实现不了！

逆风的香

我还试验了一下！三个实体矩形（直接绘制没有面域）的求并集没问题，但如果这三个矩形面域后再求并集就有并集不了了！

逆风的香

很简单就解决了！woaishuijia帮了我大忙！我自己考虑了一上午！终于现在解决了！源代码如下
Private Sub Command14_Click()
Dim obj_region() As Object
Dim RoomObjects(0 To 2) As Object
Dim curvers(0 To 2) As Object
Dim ssetObj As AcadSelectionSet
On Error Resume Next
Set ssetObj = acadApp.ActiveDocument.SelectionSets.Add("example")
If Err.Number <> 0 Then
    Set ssetObj = acadApp.ActiveDocument.SelectionSets.Item("example")
    ssetObj.Clear
End If
ssetObj.SelectOnScreen
ssetObj(0).Boolean acUnion, ssetObj(1)
ssetObj(0).Boolean acUnion, ssetObj(2)
ssetObj(0).Update
ssetObj(1).Delete
ssetObj(2).Delete
acadApp.ActiveDocument.Regen True
ssetObj.Delete
ZoomExtents
End Sub简单问题有时需要费好大的劲去考虑！

woaishuijia

本以为你这段代码是试验用的,只针对特殊情况.原来你在做面域这一步就理解错了
下面详细剖析一下你这段代码

1. On Error Resume Next
   
2. Set ssetObj = acadApp.ActiveDocument.SelectionSets.Add("example")
   
3. If Err.Number <> 0 Then
   
4.     Set ssetObj = acadApp.ActiveDocument.SelectionSets.Item("example")
   
5.     ssetObj.Clear
   
6. End If

复制代码

On Error Resume Next 这一行是为下面的创建选择集及条件语句服务的,这本没有问题,但这一段执行后,后面的语句依然按On Error Resume Next 无条件向下执行,就把你后面的创建面域及布尔运算代码中存在的错误掩盖了.如果在上面的代码下面加一行

1. On Error GoTo 0

复制代码

可能会帮助你在调试中更早地发现代码中的问题.
另外,用过的 Err 值建议及时清理.就是在 End If 前增加一行

1. Err.Clear

复制代码

当然,在这个小程序中看似不必,但在大一些的程序中就有用处了,可以避免不必要的错误.
还有,一个选择集用过后,也要及时删除.不要过分依赖错误陷井.
就是在从选择集中提取图元后应增加一行

1. ssetObj.Delete

复制代码

继续看下面一段

1. ssetObj.SelectOnScreen
   
2. Set RoomObjects(0) = ssetObj(0)
   
3. Set curvers(0) = RoomObjects(0)
   
4. Set RoomObjects(1) = ssetObj(1)
   
5. Set curvers(1) = RoomObjects(1)
   
6. Set RoomObjects(2) = ssetObj(2)
   
7. Set curvers(2) = RoomObjects(2)
   
8. regions = acadApp.ActiveDocument.ModelSpace.AddRegion(curvers)
   
9. Set RoundRoomObja = regions(0)
   
10. Set RoundRoomObjb = regions(1)
    
11. Set RoundRoomObjc = regions(2)

复制代码

第1行从屏幕选择没问题
第2行到第7行,昨天让我有些费解,看不懂你为什么要给 RoomObjects(0 To 2) 这个数组赋值, 因为这个数组变量在后面的代码中并没有出现.今天看了你的回帖,我想我懂你的心思了.你是不是打算当用户在屏幕上选择时,选择的图元中既可能有现有的面域,也可能有构成面域边界的直线或曲线,然后创建面域时,现有的面域和根据边界新建的面域都返回到变体变量 regions 中,再全体并集?
如果我猜得不错的话,你代码的问题就找到了.
AddRegion 方法的参数是一个图元对象数组,该数组中的图元只能是Line、Arc、Circle、Elliptical Arc、LightweightPolyline 和Spline.这些图元必须是共面的,首尾相连的构成封闭图形,且不许自交.
从你这段代码看,你共选择了3个图元(因为你的数组只有3个元素),要做成3个面域,你就只能选择3个圆或椭圆或封闭多段线(比如矩形)或二维封闭样条曲线才行.
如果你打算在可供选择的图元中增加现有的面域,就只能在选择后,遍历选择集元素,查看其类型,找出现有的面域,赋值给特定的变量后再把其它图元赋值给边界对象数组.然后再用 AddRegion 方法新建面域.

下面的代码是在你的基础上修改的,供参考

2. Private Sub Command14_Click()
   
3.     Dim RoomObjects(0 To 2) As AcadRegion
   
4.     Dim curvers() As AcadEntity
   
5.     Dim ssetObj As AcadSelectionSet
   
6.     On Error Resume Next
   
7.     Set ssetObj = acadApp.ActiveDocument.SelectionSets.Add("example")
   
8.     If Err Then
   
9.         Set ssetObj = acadApp.ActiveDocument.SelectionSets.Item("example")
   
10.         ssetObj.Clear
    
11.         Err.Clear
    
12.     End If
    
13.     Dim FT(6) As Integer, FD(6) As Variant, E As AcadEntity, I As Integer, J As Integer, K As Integer
    
14.     FT(0) = -4: FD(0) = "<OR"
    
15.     FT(1) = 0: FD(1) = "Circle"
    
16.     FT(2) = 0: FD(2) = "Ellipse"
    
17.     FT(3) = 0: FD(3) = "LWPolyline"
    
18.     FT(4) = 0: FD(4) = "SPLine"
    
19.     FT(5) = 0: FD(5) = "Region"
    
20.     FT(6) = -4: FD(6) = "OR>"
    
21.     ssetObj.SelectOnScreen FT, FD
    
22.     For Each E In ssetObj
    
23.         If E.ObjectName = "AcDbRegion" Then
    
24.             Set RoomObjects(I) = E
    
25.             I = I + 1
    
26.         Else
    
27.             ReDim Preserve curvers(J)
    
28.             Set curvers(J) = E
    
29.             J = J + 1
    
30.         End If
    
31.     Next
    
32.     ssetObj.Delete
    
33.     Dim regions As Variant
    
34.     If I < 3 Then
    
35.         regions = acadApp.ActiveDocument.ModelSpace.AddRegion(curvers)
    
36.         If Err Then
    
37.             MsgBox "边界错误", vbCritical, "AutoCAD"
    
38.             Exit Sub
    
39.         End If
    
40.     End If
    
41.     For J = I To 2
    
42.         Set RoomObjects(J) = regions(J - I)
    
43.     Next
    
44.     For I = 1 To 2
    
45.         RoomObjects(0).Boolean acUnion, RoomObjects(I)
    
46.     Next
    
47.     acadApp.ActiveDocument.Regen True
    
48.     ZoomExtents
    
49. End Sub

Private Sub Command14_Click()<br />     Dim RoomObjects(0 To 2) As AcadRegion<br />     Dim curvers() As AcadEntity<br />     Dim ssetObj As AcadSelectionSet<br />     On Error Resume Next<br />     Set ssetObj = acadApp.ActiveDocument.SelectionSets.Add("example")<br />     If Err Then<br />         Set ssetObj = acadApp.ActiveDocument.SelectionSets.Item("example")<br />         ssetObj.Clear<br />         Err.Clear<br />     End If<br />     Dim FT(6) As Integer, FD(6) As Variant, E As AcadEntity, I As Integer, J As Integer, K As Integer<br />     FT(0) = -4: FD(0) = "<OR"<br />     FT(1) = 0: FD(1) = "Circle"<br />     FT(2) = 0: FD(2) = "Ellipse"<br />     FT(3) = 0: FD(3) = "LWPolyline"<br />     FT(4) = 0: FD(4) = "SPLine"<br />     FT(5) = 0: FD(5) = "Region"<br />     FT(6) = -4: FD(6) = "OR>"<br />     ssetObj.SelectOnScreen FT, FD<br />     For Each E In ssetObj<br />         If E.ObjectName = "AcDbRegion" Then<br />             Set RoomObjects(I) = E<br />             I = I + 1<br />         Else<br />             ReDim Preserve curvers(J)<br />             Set curvers(J) = E<br />             J = J + 1<br />         End If<br />     Next<br />     ssetObj.Delete<br />     Dim regions As Variant<br />     If I < 3 Then<br />         regions = acadApp.ActiveDocument.ModelSpace.AddRegion(curvers)<br />         If Err Then<br />             MsgBox "边界错误", vbCritical, "AutoCAD"<br />             Exit Sub<br />         End If<br />     End If<br />     For J = I To 2<br />         Set RoomObjects(J) = regions(J - I)<br />     Next<br />     For I = 1 To 2<br />         RoomObjects(0).Boolean acUnion, RoomObjects(I)<br />     Next<br />     acadApp.ActiveDocument.Regen True<br />     ZoomExtents<br /> End Sub

其中第3行,声明数组改为动态数组,目的是使数组元素数与实际构成新建面域边界的图元数量一致.
第10行,增加 err.clear,清除错误,为后面可能的新建面域函数的错误信息做准备.
第13到20行,增加选择集过滤器,限制用户选择的图元种类.
第21到30行,遍历选择集,把现有面域存进面域对象数组,把非面域对象存进边界对象数组.
第31行,删除用过的选择集.
第33到39行,当选择集中存在边界对象时,新建面域.当用户选择的边界对象不符合创建面域的要求时,第34行会出错,发送信息并退出过程.

逆风的香

我这是在为自己编写的一个幕墙门窗计算软件（用VISUAL BASIC)而编写的，隔热铝合金型材惯性矩计算方面需要这方面的源代码！我自己以前读书时（二十年前）只学过8086及Z80汇编语言方面的编程，visual basic 与AUTOCAD二次开发方面完全是个新手，也是最近几个月学的，但幕墙计算方面必须要精通这方面的编程，我只有苦着脑袋去想！幸亏遇到您！我把隔热型材惯性矩计算方面的源代码编好后麻烦您帮审核一下！我实在知道得太少！不胜感激！我的QQ:515127998，我想在QQ中加您！孤独探索远不如有您这样热心朋友的支持！