本帖最后由 ning58 于 2016-1-24 09:03 编辑
管板插入换热管，用高版本的驱动特征方法实现，文件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
|
发表于 2016-1-22 09:05:25
发表于 2016-1-31 09:02:34
