设为首页收藏本站
开启辅助访问

SolidWorks机械工程师网——最大的SolidWorks学习平台

 找回密码
 立即注册

QQ登录

只需一步，快速开始

SolidWorks机械工程师网——最大的SolidWorks学习平台»学习社区 › Solidworks基础建模区 › SolidWorks特征建模 › 填充阵列不能选择为驱动特征

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

查看数: 453 | 评论数: 12 | 收藏 0
关灯 | 提示：支持键盘翻页<-左 右->
帖子模式
    组图打开中，请稍候......
cax27
发布时间: 2016-1-21 07:29

正文摘要:

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

回复

tgfandtcz 发表于 2016-1-25 13:48:43
那就你自娱自乐吧，看看哪家还使用着06版的公司，会掏钱购买楼主的思想
当今哪个公司如果在计算机硬件还死抠的话，早就死透了。
jajayus 发表于 2016-1-25 13:25:24
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

复制代码
nisaan1 发表于 2016-1-25 00:36:27


管板插入换热管，用高版本的驱动特征方法实现，文件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)
qxuelang 发表于 2016-1-25 00:22:43
真正的高手对于挑衅都是一笑而过的
7777777by 发表于 2016-1-24 22:09:22
此图是本人在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(, &quot;Excel.Application&quot;)
      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)) = &quot;&quot;
            End With
         End With
      Next ii
      oArr = Bubble_Sort(yDict.Keys, &quot;ASC&quot;)
   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 &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
城空巷陌 发表于 2016-1-24 07:44:19
是啊，在win7大行其道，win10蒸蒸日上，硬件白菜价之时，还有楼主这样省钱大爷，不知企业之幸甚，还是国之不幸
jp830728 发表于 2016-1-23 22:28:41
天堂海洋 发表于 2016-1-23 02:21:46


换热器布管有好多方法，方法不对文件size有很大的差别。
用Solidworks的API完成换热器布管，比高版本内置功能相比，文件Size要小。
Andreaf安德莉亚 发表于 2016-1-22 17:10:16
SW2006对计算机要求低，用Sw2006做系列“换热器”，比高版本好多了。
用高版本SW完成图示换热器，尽可能用简化方法，其结果文件特别大（近G算文件大小）。
用Sw2006，文件越大，根本无法运行。只能用Sw最简单的功能，尽量缩小文件size。
以心相交 发表于 2016-1-22 15:28:31
楼主的问题，可能需要老古董级别的才能顺利交流啦.
俺新手小白路过，表示看不懂，都没见过这号版本SW。
keenhsy 发表于 2016-1-22 01:06:18

直接选择 填充整理不是可以吗
466488712 发表于 2016-1-22 00:57:22
楼主的sw版本可真经典。。。。

SOLIDWORKS 2023 机械设计从入门到精通

手机版|小黑屋| GMT+8, 2025-5-23 20:25 , Processed in 0.207646 second(s), 28 queries , Memcache On.

SolidWorks机械工程师网 ( 鲁ICP备14025122号-2 ) 鲁公网安备 37028502190335号

声明：本网言论纯属发表者个人意见，与本网立场无关。
如涉版权，可发邮件： admin@swbbsc.com

快速回复 返回顶部 返回列表