社区 › VBA/VB/ActiveX/API 编程技术 › VB控制AUTOCAD求三个面域并集求助

逆风的香 发表于 2013-9-30 12:25:54

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 发表于 2020-7-3 14:48:12

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

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

逆风的香 发表于 2013-10-1 15:54:17

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

woaishuijia 发表于 2013-10-1 17:25:24

本帖最后由 woaishuijia 于 2013-10-1 17:26 编辑

你的并集方法用错了RoundRoomObja.Boolean acUnion, RoundRoomObjb这一行是把 RoundRoomObjb 并到 RoundRoomObja 上,运行的结果的 RoundRoomObja 被改变, RoundRoomObjb 没了.你下面一行RoundRoomObjb.Boolean acUnion, RoundRoomObjc自然是错的了
正确的方法是RoundRoomObja.Boolean acUnion, RoundRoomObjb
RoundRoomObja.Boolean acUnion, RoundRoomObjc而且后面的RoundRoomObjb.Update
RoundRoomObjc.Update也没有意义

逆风的香 发表于 2013-10-1 21:37:12

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

逆风的香 发表于 2013-10-2 08:04:41

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

逆风的香 发表于 2013-10-2 08:08:12

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

逆风的香 发表于 2013-10-2 10:58:28

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

逆风的香 发表于 2013-10-2 15:06:58

很简单就解决了！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 发表于 2013-10-2 16:24:56

本以为你这段代码是试验用的,只针对特殊情况.原来你在做面域这一步就理解错了
下面详细剖析一下你这段代码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 IfOn Error Resume Next 这一行是为下面的创建选择集及条件语句服务的,这本没有问题,但这一段执行后,后面的语句依然按On Error Resume Next 无条件向下执行,就把你后面的创建面域及布尔运算代码中存在的错误掩盖了.如果在上面的代码下面加一行On Error GoTo 0可能会帮助你在调试中更早地发现代码中的问题.
另外,用过的 Err 值建议及时清理.就是在 End If 前增加一行Err.Clear当然,在这个小程序中看似不必,但在大一些的程序中就有用处了,可以避免不必要的错误.
还有,一个选择集用过后,也要及时删除.不要过分依赖错误陷井.
就是在从选择集中提取图元后应增加一行ssetObj.Delete继续看下面一段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)
regions = acadApp.ActiveDocument.ModelSpace.AddRegion(curvers)
Set RoundRoomObja = regions(0)
Set RoundRoomObjb = regions(1)
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 方法新建面域.

下面的代码是在你的基础上修改的,供参考Private Sub Command14_Click()
    Dim RoomObjects(0 To 2) As AcadRegion
    Dim curvers() As AcadEntity
    Dim ssetObj As AcadSelectionSet
    On Error Resume Next
    Set ssetObj = acadApp.ActiveDocument.SelectionSets.Add("example")
    If Err Then
      Set ssetObj = acadApp.ActiveDocument.SelectionSets.Item("example")
      ssetObj.Clear
      Err.Clear
    End If
    Dim FT(6) As Integer, FD(6) As Variant, E As AcadEntity, I As Integer, J As Integer, K As Integer
    FT(0) = -4: FD(0) = "<OR"
    FT(1) = 0: FD(1) = "Circle"
    FT(2) = 0: FD(2) = "Ellipse"
    FT(3) = 0: FD(3) = "LWPolyline"
    FT(4) = 0: FD(4) = "SPLine"
    FT(5) = 0: FD(5) = "Region"
    FT(6) = -4: FD(6) = "OR>"
    ssetObj.SelectOnScreen FT, FD
    For Each E In ssetObj
      If E.ObjectName = "AcDbRegion" Then
            Set RoomObjects(I) = E
            I = I + 1
      Else
            ReDim Preserve curvers(J)
            Set curvers(J) = E
            J = J + 1
      End If
    Next
    ssetObj.Delete
    Dim regions As Variant
    If I < 3 Then
      regions = acadApp.ActiveDocument.ModelSpace.AddRegion(curvers)
      If Err Then
            MsgBox "边界错误", vbCritical, "AutoCAD"
            Exit Sub
      End If
    End If
    For J = I To 2
      Set RoomObjects(J) = regions(J - I)
    Next
    For I = 1 To 2
      RoomObjects(0).Boolean acUnion, RoomObjects(I)
    Next
    acadApp.ActiveDocument.Regen True
    ZoomExtents
End Sub其中第3行,声明数组改为动态数组,目的是使数组元素数与实际构成新建面域边界的图元数量一致.
第10行,增加 err.clear,清除错误,为后面可能的新建面域函数的错误信息做准备.
第13到20行,增加选择集过滤器,限制用户选择的图元种类.
第21到30行,遍历选择集,把现有面域存进面域对象数组,把非面域对象存进边界对象数组.
第31行,删除用过的选择集.
第33到39行,当选择集中存在边界对象时,新建面域.当用户选择的边界对象不符合创建面域的要求时,第34行会出错,发送信息并退出过程.

逆风的香 发表于 2013-10-2 17:19:25

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

查看完整版本: VB控制AUTOCAD求三个面域并集求助