运行：“生成AUTOCAD程序对象按钮”，再点取：“计算隔热型材截面特性”至“请选择断热条一侧的面域部分!”按：“确定”后选择一侧面域，点取“请选择断热条另一侧的面域部分!” 按：“确定”后选择另一侧面域，再利用选择集将三个面域求并集。
现在提取的截面特性第一个面域，第二个面域都正确,求并集后的截面特性提取错误，在求并集过程中如果先选择第一个面域，求并集后提取的截面特性就为第一个面域的，反之，在求并集过程中如果先选择第二个面域，求并集后提取的截面特性就为第二个面域的，实际我们求并集后需提取的截面特性为求并集后的截面特性。但不希望在求完并集后再次单选择求并集后的截面去提取并集后截面特性。
源代码如下：
公共变量设置： Public Ix0 As Double, Iy0 As Double Public Ix1 As Double, Iy1 As Double Public Ix2 As Double, Iy2 As Double Public Wx10 As Double, Wx20 As Double Public Wx11 As Double, Wx21 As Double Public Wx12 As Double, Wx22 As Double Public Wy10 As Double, Wy20 As Double Public Wy11 As Double, Wy21 As Double Public Wy12 As Double, Wy22 As Double Public Sx0 As Double, Sy0 As Double Public Sx1 As Double, Sy1 As Double Public Sx2 As Double, Sy2 As Double Public A0 As Double, A1 As Double, A2 AsDouble 计算部分源代码： Private Sub Command15_Click() '选择对像 Form1.Hide Dim MyEnty As AcadEntity, basPoint AsVariant Dim MySel As AcadSelectionSet Dim MinPoAs Variant, MaxPo As Variant Dim LeftPo(2) As Double, RightPo(2) AsDouble Call formTotop(acadApp.hwnd) '提示用户选择 On Error Resume Next ReSele: MsgBox "请选择断热条一侧的面域部分!", vbOKOnly, "说明" ‘选择第一个面域 acadDoc.Utility.GetEntity MyEnty, basPoint,"选择对象:" If Err.Number <> 0 Then If CheckKey(VK_ESCAPE) = True Or CheckKey(VK_MRight) = True Then Me.Show Exit Sub Else GoTo ReSele End If End If If Not (MyEnty Is Nothing) Then If MyEnty.ObjectName = "AcDbRegion" Then '计算特性 Call Xcdm(acadDoc, MyEnty) ‘提取第一个面域的截面特性 A0 = Round(SS * 100, 3) 第一个面域的截面特性输入公共变量中 Ix0 = Round(IIx, 3) Iy0 = Round(IIy, 3) Wx10 = Round(WWx1, 3) Wx20 = Round(WWx2, 3) Wy10 = Round(WWy1, 3) Wy20 = Round(WWy2, 3) If SSx1≤SSx2 Then Sx0 = Round(SSx1, 3) Else Sx0 = Round(SSx2, 3) End If If SSy1≤SSy2 Then Sy0 = Round(SSy1, 3) Else Sy0 = Round(SSy2, 3) End If Else MsgBox "当前选择对像不是一个面域,请重新选择!",vbOKOnly, "运行提示" End If End If MsgBox "请选择断热条另一侧的面域部分!", vbOKOnly, "说明" ‘选择第二个面域 acadDoc.Utility.GetEntity MyEnty, basPoint,"选择对象:" If Err.Number <> 0 Then If CheckKey(VK_ESCAPE) = True Or CheckKey(VK_MRight) = True Then Me.Show Exit Sub Else GoTo ReSele End If End If If Not (MyEnty Is Nothing) Then If MyEnty.ObjectName = "AcDbRegion" Then '计算特性 Call Xcdm(acadDoc, MyEnty) ‘提取第二个面域的截面特性 A1 = Round(SS * 100, 3) 第一个面域的截面特性输入公共变量中 Ix1 = Round(IIx, 3) Iy1 = Round(IIy, 3) Wx11 = Round(WWx1, 3) Wx21 = Round(WWx2, 3) Wy11 = Round(WWy1, 3) Wy21 = Round(WWy2, 3) If SSx1≤SSx2 Then Sx1 = Round(SSx1, 3) Else Sx1 = Round(SSx2, 3) End If If SSy1≤SSy2 Then Sy1 = Round(SSy1, 3) Else Sy1 = Round(SSy2, 3) End If Else MsgBox "当前选择对像不是一个面域,请重新选择!",vbOKOnly, "运行提示" End If End If MsgBox "请选择断热条及铝合金的全部面域部分!", vbOKOnly, "说明" ‘将第一、二个面域及隔热条求并集 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, JAs 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 ZoomExtents If Err.Number <> 0 Then If CheckKey(VK_ESCAPE) = True Or CheckKey(VK_MRight) = True Then Me.Show Exit Sub Else GoTo ReSele End If End If If Not (MyEnty Is Nothing) Then If MyEnty.ObjectName = "AcDbRegion" Then '计算特性 Call Xcdm(acadDoc, MyEnty) 提取求并集后的截面特性 A2 = Round(SS * 100, 3) 求并集后面域的截面特性输入公共变量中 Ix2 = Round(IIx, 3) Iy2 = Round(IIy, 3) Wx12 = Round(WWx1, 3) Wx22 = Round(WWx2, 3) Wy12 = Round(WWy1, 3) Wy22 = Round(WWy2, 3) If SSx1≤SSx2 Then Sx2 = Round(SSx1, 3) Else Sx2 = Round(SSx2, 3) End If If SSy1≤SSy2 Then Sy2 = Round(SSy1, 3) Else Sy2 = Round(SSy2, 3) End If Else MsgBox "当前选择对像不是一个面域,请重新选择!",vbOKOnly, "运行提示" End If End If 通过文本栏输出提取的截面特性（可以提取第一个面域特性，第二个面域特性及求并集后的面域特性） Text9.Text = A1 Text1.Text = Ix1 Text2.Text = Iy1 Text3.Text = Wx11 Text4.Text = Wx21 Text5.Text = Wy11 Text6.Text = Wy21 If SSx1≤SSx2 Then Text7.Text = Sx1 Else Text7.Text = Sx1 End If If SSy1≤SSy2 Then Text8.Text = Sy1 Else Text8.Text = Sy1 End If Form1.Show End Sub | 
楼主
显身卡
发表于 2020-7-3 14:48:12