填充阵列不能选择为驱动特征

cax27

   经典图书

线性阵列可以用于驱动特征，能实现目标需求。

****************************************
而填充阵列不能选择为驱动特征。

请问，各位有什么办法将钢管填充圆盘内的圆孔？
aa.zip (307.91 KB, 下载次数: 127)

2016-1-21 07:29 上传

点击文件名下载附件
下载积分: 金币 -1

466488712

楼主的sw版本可真经典。。。。

keenhsy

   经典图书

直接选择 填充整理不是可以吗

以心相交

楼主的问题，可能需要老古董级别的才能顺利交流啦.
俺新手小白路过，表示看不懂，都没见过这号版本SW。

Andreaf安德莉亚

   经典案例图书

SW2006对计算机要求低，用Sw2006做系列“换热器”，比高版本好多了。
用高版本SW完成图示换热器，尽可能用简化方法，其结果文件特别大（近G算文件大小）。
用Sw2006，文件越大，根本无法运行。只能用Sw最简单的功能，尽量缩小文件size。

天堂海洋

换热器布管有好多方法，方法不对文件size有很大的差别。
用Solidworks的API完成换热器布管，比高版本内置功能相比，文件Size要小。

jp830728

   经典案例图书

城空巷陌

是啊，在win7大行其道，win10蒸蒸日上，硬件白菜价之时，还有楼主这样省钱大爷，不知企业之幸甚，还是国之不幸

7777777by

此图是本人在Solidworks官网的API板块发的帖。
解决问题是统计全孔和半孔的数据。

How to count hole number include half hole | SOLIDWORKS Forums
https://forum.solidworks.com/thread/108191
我的提出的关键码是

     Set SwLoop = swFace.GetFirstLoop

      Do While Not SwLoop Is Nothing

        If Not SwLoop.IsOuter Then

            vEdges = SwLoop.GetEdges

            If UBound(vEdges) = 0 Then

                Dim swEdge As SldWorks.Edge

                Set swEdge = vEdges(0)

                Dim swCurve As SldWorks.Curve

                Set swCurve = swEdge.GetCurve

                'If swCurve.IsCircle Then

                    totalHolesCount = totalHolesCount + 1

                'End If

            End If

        End If

老外给我提出的优化代码，与我的代码没什么区别，只是代码编制习惯。

Private Sub ll()
   Dim Xls As Excel.Application, Rng As Range
      Set Xls = GetObject(, "Excel.Application")
      Set Rng = Xls.Cells(3, 1)
   Dim yDict As New Dictionary, xx(), yy(), oArr
   Dim SwApp As SldWorks.SldWorks, SwModel As ModelDoc2
      Set SwApp = Application.SldWorks
      Set SwModel = SwApp.ActiveDoc
   Dim SwSelMgr As SelectionMgr
      Set SwSelMgr = SwModel.SelectionManager
   Dim SwFeat As Feature, Total As Integer
      Set SwFeat = SwSelMgr.GetSelectedObject5(1)
   Dim fCount, vFace, SwFace As Face2
   Dim SwEdgePt, SwEdge As Edge, vEdge
   Dim SwSketch As Sketch, SwCurve As Curve
      ''
      vFace = SwFeat.GetFaces
      fCount = SwFeat.GetFaceCount
      ReDim xx(fCount), yy(fCount)
      For ii = 0 To UBound(vFace)
         Set SwFace = vFace(ii)
         With SwFace
            vEdge = .GetEdges
            Set SwEdge = vEdge(0)
            With SwEdge
                Set SwCurve = .GetCurve
                ss = SwCurve.CircleParams
                xx(ii) = Round(ss(0) * 1000, 2)
                yy(ii) = Round(ss(2) * 1000, 1)
                Rng(ii, 1) = xx(ii)
                Rng(ii, 2) = yy(ii)
                yDict(yy(ii)) = ""
            End With
         End With
      Next ii
      oArr = Bubble_Sort(yDict.Keys, "ASC")
   Dim yCount()
   ReDim yCount(UBound(oArr), 1)
      For ii = 0 To UBound(oArr)
          'Debug.Print Xls.WorksheetFunction.CountIf(yy, oArr(ii))
          cc = 0
          For jj = 0 To UBound(yy)
             If oArr(ii) = yy(jj) Then
                cc = cc + 1
             End If
          Next jj
          yCount(ii, 0) = oArr(ii)
          yCount(ii, 1) = cc
          Total = Total + cc
      Next ii
      Debug.Print Total
      Stop
End Sub
''
''
''
Function Bubble_Sort(Ary, objOrder As String)
   Dim aryUBound, i, j
   aryUBound = UBound(Ary)
   For ii = 0 To aryUBound
     Ary(ii) = Val(Round(Ary(ii), 2))
   Next ii
   For i = 0 To aryUBound
     For j = i + 1 To aryUBound
       Select Case UCase(objOrder)
         Case "DESC"
           If Ary(i) < Ary(j) Then
             Swap Ary(i), Ary(j)
           End If
         Case &quot;ASC&quot;
           If Ary(i) > Ary(j) Then
             Swap Ary(i), Ary(j)
           End If
       End Select
     Next
   Next
   Bubble_Sort = Ary
End Function
''
Function Swap(a, B)
   Dim tmp
   tmp = a
   a = B
   B = tmp
End Function

qxuelang

   经典图书

真正的高手对于挑衅都是一笑而过的

nisaan1

管板插入换热管，用高版本的驱动特征方法实现，文件size特别大，搞不好就按G算。
用下面代码生成低版本文件，不到20M。
Private Sub ll()
   Dim Xls As Excel.Application, Rng As Range
      Set Xls = GetObject(, &quot;Excel.Application&quot;)
      Set Rng = Xls.Cells(3, 1).CurrentRegion
      Debug.Print Rng.Address, Rng.Parent.Name
   Dim xx, yy, zz As Double
   Dim SwApp As SldWorks.SldWorks, SwModel As ModelDoc2, SwAssy As AssemblyDoc
      Set SwApp = Application.SldWorks
      Set SwModel = SwApp.ActiveDoc
      Set SwAssy = SwModel
      For ii = 1 To Rng.Rows.Count
         xx = Rng(ii, 1) / 1000
         yy = Rng(ii, 2) / 1000
         zz = -0.75
         SwAssy.AddComponent &quot;D:JB4716JB4716换热管.SLDPRT&quot;, xx, zz, yy ', zz
      Next ii
End Sub
''''
Sub a1()
    Dim SwApp As SldWorks.SldWorks, SwModel As ModelDoc2
       Set SwApp = Application.SldWorks
       Set SwModel = SwApp.ActiveDoc
    Dim SwSelMgr As SelectionMgr, SwFeat As Feature
       Set SwFeat = SwModel.FeatureByName(&quot;TPattern1&quot;)
       Debug.Print SwFeat.Name
       Set SwSelMgr = SwModel.SelectionManager
    Dim SwTableFeatData As TablePatternFeatureData
       Set SwTableFeatData = SwFeat.GetDefinition
    Dim vBasePt, vPt, vPt1, Pt() As Double, bPt(2) As Double
       vPt = Array(-0.032, -0.06, 0, -0.064, 0, 0, 0, 0.064, 0)
    With SwTableFeatData
      tmp = .AccessSelections(SwModel, Nothing)
      'Debug.Print tmp
      vBasePt = .GetBasePoint
      vPt1 = .PointArray
      ReDim Pt(UBound(vPt) + UBound(vPt1) + 1) As Double
      For ii = 0 To UBound(vPt1)
         Pt(ii) = vPt1(ii)
      Next ii
      For ii = 0 To UBound(vPt)
         Pt(ii + UBound(vPt1) + 1) = vPt(ii)
      Next ii
       .PointArray = Pt
      .ReleaseSelectionAccess
    End With
    SwFeat.ModifyDefinition SwTableFeatData, SwModel, Nothing
    Stop
End Sub
*****************************
Private Sub GetFillPatternNum()
    Dim Xls As Excel.Application, Rng As Range
       Set Xls = GetObject(, &quot;Excel.Application&quot;)
       Set Rng = Xls.Selection
    Dim SwApp As SldWorks.SldWorks, SwModel As ModelDoc2
       Set SwApp = Application.SldWorks
       Set SwModel = SwApp.ActiveDoc
    Dim SwSelMgr As SelectionMgr
       Set SwSelMgr = SwModel.SelectionManager
    Dim SwFeat As Feature, tmp
    Dim FillPatternData As CircularPatternFeatureData
    Dim Xx(), Yy(), yDict As New Dictionary
    Dim vFace, fCount, yCount()
       ''
       For ii = Rng.Rows.Count To 1 Step -1
           SwModel.ShowConfiguration Rng(ii, 1)
             ''
             tmp = SwModel.Extension.SelectByID2(&quot;FillPattern&quot;, &quot;BODYFEATURE&quot;, 0, 0, 0, False, 0, Nothing, 0)
             Set SwFeat = SwSelMgr.GetSelectedObject5(1)
             ''
             vFace = SwFeat.GetFaces
             fCount = SwFeat.GetFaceCount
             ''
             Rng(ii, 2) = fCount
             ''
             ReDim Xx(fCount), Yy(fCount)
             For jj = 0 To UBound(vFace)
                 Set SwFace = vFace(jj)
                 ''
                 With SwFace
                     vEdge = .GetEdges
                     Set SwEdge = vEdge(0)
                     ''
                     With SwEdge
                         Set SwCurve = .GetCurve
                         sS = SwCurve.CircleParams
                         Xx(jj) = Round(sS(0) * 1000, 2)
                         Yy(jj) = Round(sS(2) * 1000, 1)
                         yDict(Yy(jj)) = &quot;&quot;
                     End With
                 End With
             Next jj
             ''Stop
             ''
             oArr = Bubble_Sort(yDict.Keys, &quot;ASC&quot;)
             ''
             ReDim yCount(UBound(oArr), 1)
             For ii1 = 0 To UBound(oArr)
                 'Debug.Print Xls.WorksheetFunction.CountIf(yy, oArr(ii))
                 Cc = 0
                 For jj = 0 To UBound(Yy)
                    If oArr(ii1) = Yy(jj) Then
                        Cc = Cc + 1
                    End If
                 Next jj
                 yCount(ii1, 0) = oArr(ii1)
                 yCount(ii1, 1) = Cc
                 Total = Total + Cc
             Next ii1
             ''
             For jj = 0 To UBound(yCount)
                 Rng(ii, 4 + jj) = yCount(jj, 1)
                 If ii = Rng.Rows.Count Then
                    Rng(0, 4 + jj) = yCount(jj, 0)
                 End If
             Next jj
       Next ii
End Sub
Function Bubble_Sort(Ary, objOrder As String)
   Dim aryUBound, i, j
   aryUBound = UBound(Ary)
   For ii = 0 To aryUBound
     Ary(ii) = Val(Round(Ary(ii), 2))
   Next ii
   For i = 0 To aryUBound
     For j = i + 1 To aryUBound
       Select Case UCase(objOrder)
         Case &quot;DESC&quot;
           If Ary(i) < Ary(j) Then
             Swap Ary(i), Ary(j)
           End If
         Case &quot;ASC&quot;
           If Ary(i) > Ary(j) Then
             Swap Ary(i), Ary(j)
           End If
       End Select
     Next
   Next
   Bubble_Sort = Ary
End Function
''
Function Swap(a, B)
   Dim tmp
   tmp = a
   a = B
   B = tmp
End Function
Macro1.zip (16.71 KB, 下载次数: 130)

2017-6-19 07:59 上传

点击文件名下载附件
下载积分: 金币 -1

jajayus

SW玩手最常用的口头禅是，SW太吃计算机资源了。
计算机硬件的内在要16G以上，要是按高配计算机建立管板模型。Size随便就是1G。
Sw2006根本无法打开1G的sldprt文件。

用高配计算机实现，需要开6687个孔，相当吃资源，Size接近1G。
Dn400        37        37
Dn500        61        24
Dn600        109        48
Dn700        151        42
Dn800        199        48
Dn900        253        54
Dn1000        313        60
Dn1100        379        66
Dn1200        451        72
Dn1300        517        66
Dn1400        637        120
Dn1500        721        84
Dn1600        835        114
Dn1700        955        120
Dn1800        1069        114
               
        6687        1069
而用Sw2006实现管板的sldprt文件，减少Size最简单方法，是用API来精简开孔数→开孔数为1069。
少开孔5618个孔。

Function RngPtArr(Rng As Range)
   Dim Arr() As Double, oRow As Integer
      ReDim Arr(Rng.Rows.Count * 3 - 1) As Double
      ''
      
      For ii = 1 To Rng.Rows.Count
         Arr(oRow) = Rng(ii + 1, 1) / 1000
         Arr(oRow + 1) = Rng(ii + 1, 2) / 1000
         Arr(oRow + 2) = 0
         oRow = oRow + 3
      Next ii
      RngPtArr = Arr
End Function
Sub TablePatternPointArr()
    Dim Xls As Excel.Application, Rng As Range
       Set Xls = GetObject(, &quot;Excel.Application&quot;)
       Set Rng = Xls.Selection
   
    Dim SwApp As SldWorks.SldWorks, SwModel As ModelDoc2
       Set SwApp = Application.SldWorks
       Set SwModel = SwApp.ActiveDoc
    Dim SwSelMgr As SelectionMgr, SwFeat As Feature
      
       Set SwSelMgr = SwModel.SelectionManager
    Dim SwTableFeatData As TablePatternFeatureData, PtArr, PtArrRng As Range
      
    Dim vBasePt, vPt, vPt1, Pt() As Double, bPt(2) As Double
       For ii = 1 To Rng.Rows.Count
          Set SwFeat = SwModel.FeatureByName(Rng(ii, 1) & &quot;Tab&quot;)
         
          Set SwTableFeatData = SwFeat.GetDefinition
          Set PtArrRng = Xls.Range(Rng(ii, 4))
          'Debug.Print PtArrRng.Address,
          PtArr = RngPtArr(PtArrRng)
         
          With SwTableFeatData
             .AccessSelections SwModel, Nothing
             .PointArray = PtArr
             Debug.Print SwFeat.Name
             .ReleaseSelectionAccess
          End With
          SwFeat.ModifyDefinition SwTableFeatData, SwModel, Nothing
          'Stop
       Next ii
   

End Sub

复制代码

Function InsTabDrivenPattern(SwModel As ModelDoc2, FileName, FeatName, CoordName, BodyArr)
   Dim SwFeat As Feature, SwFeatMgr As FeatureManager
   Set SwFeatMgr = SwModel.FeatureManager
   With SwModel.Extension
     .SelectByID2 CoordName, &quot;COORDSYS&quot;, 0, 0, 0, False, 16, Nothing, 0
     For ii = 0 To UBound(BodyArr)
       .SelectByID2 BodyArr(ii), &quot;BODYFEATURE&quot;, 0, 0, 0, True, 4, Nothing, 0
     Next ii
   End With
   ''
   Set SwFeat = SwFeatMgr.InsertTableDrivenPattern(FileName, Nothing, True, True)
   SwFeat.Name = FeatName
   'SwFeat.Select True
   'SwModel.EditSuppress2
End Function
‘‘’’
''
Private Sub del20160126()
   Dim T: T = Timer
   Dim BodyArr: BodyArr = Array(&quot;CutHole&quot;)
   Dim Xls As Excel.Application, Rng As Range
      Set Xls = GetObject(, &quot;Excel.Application&quot;)
      Set Rng = Xls.Selection
      ''
   Dim SwApp As SldWorks.SldWorks, SwModel As ModelDoc2
      Set SwApp = Application.SldWorks
      Set SwModel = SwApp.ActiveDoc
      ''
      FileName = &quot;D:A.SldPTab&quot;
      For ii = 1 To Rng.Rows.Count
         SwModel.ShowConfiguration2 Rng(ii, 1)
         
         InsTabDrivenPattern SwModel, FileName, Rng(ii, 1) & &quot;Tab&quot;, &quot;CoordinateSystem&quot;, BodyArr
         Debug.Print Rng(ii, 1),
         PrintTiming T
      Next ii
      PrintTiming T
      SwModel.Save
      Timing T
End Sub

复制代码

tgfandtcz

那就你自娱自乐吧，看看哪家还使用着06版的公司，会掏钱购买楼主的思想
当今哪个公司如果在计算机硬件还死抠的话，早就死透了。