iCAx开思网
标题: 填充阵列不能选择为驱动特征 [打印本页]
作者: ning58 时间: 2016-1-21 07:29
标题: 填充阵列不能选择为驱动特征
本帖最后由 ning58 于 2016-1-21 07:50 编辑
线性阵列可以用于驱动特征，能实现目标需求。
[attach]1229849[/attach]
****************************************
而填充阵列不能选择为驱动特征。
[attach]1229848[/attach]
请问，各位有什么办法将钢管填充圆盘内的圆孔？
作者: 楠柠檬、 时间: 2016-1-21 08:07
楼主的sw版本可真经典。。。。
作者: wxg263 时间: 2016-1-21 08:37
[attach]1229851[/attach] 直接选择 填充整理不是可以吗
作者: 無奈之人 时间: 2016-1-21 18:05
楼主的问题，可能需要老古董级别的才能顺利交流啦.
俺新手小白路过，表示看不懂，都没见过这号版本SW。
作者: ning58 时间: 2016-1-21 22:29
本帖最后由 ning58 于 2016-1-21 22:44 编辑
SW2006对计算机要求低，用Sw2006做系列“换热器”，比高版本好多了。
用高版本SW完成图示换热器，尽可能用简化方法，其结果文件特别大（近G算文件大小）。
用Sw2006，文件越大，根本无法运行。只能用Sw最简单的功能，尽量缩小文件size。
[attach]1229877[/attach]
作者: ning58 时间: 2016-1-21 22:52
本帖最后由 ning58 于 2016-1-21 22:56 编辑
[attach]1229878[/attach]
换热器布管有好多方法，方法不对文件size有很大的差别。
用Solidworks的API完成换热器布管，比高版本内置功能相比，文件Size要小。
作者: foreverroc 时间: 2016-1-21 23:11
作者: 营口人 时间: 2016-1-22 06:10
是啊，在win7大行其道，win10蒸蒸日上，硬件白菜价之时，还有楼主这样省钱大爷，不知企业之幸甚，还是国之不幸
作者: ning58 时间: 2016-1-22 07:54
本帖最后由 ning58 于 2016-1-22 08:47 编辑
此图是本人在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 "ASC"
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-22 08:17
真正的高手对于挑衅都是一笑而过的
作者: ning58 时间: 2016-1-22 09:05
本帖最后由 ning58 于 2016-1-24 09:03 编辑
[attach]1229879[/attach]
管板插入换热管，用高版本的驱动特征方法实现，文件size特别大，搞不好就按G算。
用下面代码生成低版本文件，不到20M。
Private Sub ll()
Dim Xls As Excel.Application, Rng As Range
Set Xls = GetObject(, "Excel.Application")
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 "D:\JB4716\JB4716\换热管.SLDPRT", 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("TPattern1")
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(, "Excel.Application")
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("FillPattern", "BODYFEATURE", 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)) = ""
End With
End With
Next jj
''Stop
''
oArr = Bubble_Sort(yDict.Keys, "ASC")
''
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 "DESC"
If Ary(i) < Ary(j) Then
Swap Ary(i), Ary(j)
End If
Case "ASC"
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
作者: ning58 时间: 2016-1-27 07:11
SW玩手最常用的口头禅是，SW太吃计算机资源了。
计算机硬件的内在要16G以上，要是按高配计算机建立管板模型。Size随便就是1G。
Sw2006根本无法打开1G的sldprt文件。
[attach]1230029[/attach]
用高配计算机实现，需要开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(, "Excel.Application")
- 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) & "Tab")
-
- 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, "COORDSYS", 0, 0, 0, False, 16, Nothing, 0
- For ii = 0 To UBound(BodyArr)
- .SelectByID2 BodyArr(ii), "BODYFEATURE", 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("CutHole")
- Dim Xls As Excel.Application, Rng As Range
- Set Xls = GetObject(, "Excel.Application")
- Set Rng = Xls.Selection
- ''
- Dim SwApp As SldWorks.SldWorks, SwModel As ModelDoc2
- Set SwApp = Application.SldWorks
- Set SwModel = SwApp.ActiveDoc
- ''
- FileName = "D:\A.SldPTab"
- For ii = 1 To Rng.Rows.Count
- SwModel.ShowConfiguration2 Rng(ii, 1)
-
- InsTabDrivenPattern SwModel, FileName, Rng(ii, 1) & "Tab", "CoordinateSystem", BodyArr
- Debug.Print Rng(ii, 1),
- PrintTiming T
- Next ii
- PrintTiming T
- SwModel.Save
- Timing T
- End Sub
作者: 营口人 时间: 2016-1-31 09:02
那就你自娱自乐吧，看看哪家还使用着06版的公司，会掏钱购买楼主的思想
当今哪个公司如果在计算机硬件还死抠的话，早就死透了。
| 欢迎光临 iCAx开思网 (https://www.icax.org/) |
Powered by Discuz! X3.3 |