宏--所选草图拉伸成形到所选实体

pyczt · 发表于 2016-8-11 23:44:52

' ******************************************************************************
'PYCZT原创作品
'条件:在特征中预先一个草图和在实体或曲面实体文件夹中选择一个实件
'结果:增加一个凸台-拉伸特征,由所选草图拉伸到所选实体
' ******************************************************************************
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim part As SldWorks.PartDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim selsketch As SldWorks.Sketch
Dim swFeat As SldWorks.Feature
Dim SketchName As String
Dim swBody As SldWorks.Body2
Dim ngetSel As Integer
Dim ntype As Long
Dim i As Integer
Dim bodyname As String
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set part = swApp.ActiveDoc
Set swSelMgr = part.SelectionManager '定义选择管理器
ngetSel = swSelMgr.GetSelectedObjectCount2(0) '选择数量
Debug.Print "GetSelectedObjectCount = " & ngetSel
If ngetSel <> 2 Then
MsgBox "应选择草图和成形到实体二项"
Exit Sub
End If
For i = 1 To ngetSel
ntype = swSelMgr.GetSelectedObjectType3(i, 0)
Debug.Print "ntype" & i; "= " & ntype
Select Case ntype
Case swSelSKETCHES '草图9
Dim featType As String
Set swFeat = swSelMgr.GetSelectedObject5(i)
Set selsketch = swFeat.GetSpecificFeature '获取特定功能类型的接口
SketchName = swFeat.GetNameForSelection(featType)
Debug.Print "SketchName草图名 " & "= " & SketchName
Case swSelSOLIDBODIES '实体76
Set swBody = swSelMgr.GetSelectedObject5(i)
bodyname = swBody.Name
Debug.Print "BodyName实体名 " & "= " & bodyname
Case swSelSURFACEBODIES '曲面实体75
Set swBody = swSelMgr.GetSelectedObject5(i)
bodyname = swBody.Name
Debug.Print "SurfacebodyName曲面实体名 " & "= " & bodyname
Case swSelFACES '面2
Set swBody = swSelMgr.GetSelectedObject5(i).GetBody '由面得到实体
bodyname = swBody.Name
Debug.Print "FaceGetbodyName面的实体名 " & "= " & bodyname
Case swSelEXTSKETCHSEGS '草图线条24
Dim selsegment As ISketchSegment
Set selsegment = swSelMgr.GetSelectedObject5(i)
Set selsketch = selsegment.GetSketch '由草图线条得到草图
Set swFeat = selsketch
SketchName = swFeat.Name
Debug.Print "SketchName草图名 " & "= " & SketchName
End Select
Next i
part.ClearSelection2 True
'以下判断草图合法性
Dim nRetVal As Long
Dim nOpenCount As Long
Dim nClosedCount As Long
nRetVal = selsketch.CheckFeatureUse(swSketchCheckFeature_BOSSEXTRUDE, nOpenCount, nClosedCount)
Debug.Print " nRetVal = " & nRetVal
'SW2012出现再次判定时会出错,与上次判定不一样现象,困惑
Debug.Print " OpenCount = " & nOpenCount
Debug.Print " ClosedCount = " & nClosedCount
Debug.Print
If nRetVal <> 0 Then '选择草图中局部范围
Dim mySelectData As SldWorks.SelectData
Dim myFeature2 As SldWorks.Feature
Dim regionCount As Long
Dim vSkRegions As Variant
Dim skRegion As SketchRegion
Dim Ri As Integer
Set mySelectData = swSelMgr.CreateSelectData
Set myFeature2 = part.FeatureByName(SketchName)
Set selsketch = myFeature2.GetSpecificFeature2()
If Not selsketch Is Nothing Then
regionCount = selsketch.GetSketchRegionCount()
Debug.Print regionCount & " regions in sketch " & myFeature2.Name
vSkRegions = selsketch.GetSketchRegions()
For Ri = LBound(vSkRegions) To UBound(vSkRegions)
Set skRegion = vSkRegions(Ri)
If Not skRegion Is Nothing Then
Debug.Print " region " & Ri & ":"
boolstatus = skRegion.Select2(True, mySelectData) '选择草图中局部范围
If boolstatus = 0 Then
Debug.Print "Selection of region failed局部范围选择失败."
Exit Sub
End If
End If
Next Ri
End If
Else
boolstatus = part.Extension.SelectByID2(SketchName, "SKETCH", 0, 0, 0, False, 0, Nothing, 0) '选草图
End If
Dim myFeature As SldWorks.Feature '定义要增加的拉伸特征
Set myFeature = part.FeatureManager.FeatureExtrusion2(True, False, False, _
0, 0, 0.1, 0, False, False, False, False, 1.74532925199433E-02, 1.74532925199433E-02, False, False, False, False, True, True, True, 0, 0, False) '增加拉伸特征
Debug.Print
Debug.Print myFeature.Name & " [" & myFeature.GetTypeName & "]" '特征名
Dim swExtrusionData As ExtrudeFeatureData2 '定义拉伸特征参数
Set swExtrusionData = myFeature.GetDefinition '取得特征参数
boolstatus = swExtrusionData.AccessSelections(part, Nothing) '获取访问特征参数,此条必须!
swExtrusionData.SetEndCondition True, swEndCondUpToBody '改终止条件为成形到实体7
swExtrusionData.SetEndConditionReference True, swBody '实体附值
boolstatus = myFeature.ModifyDefinition(swExtrusionData, part, Nothing) '修改参数重建
If boolstatus = False Then '错误说明实体方向不对
boolstatus = swExtrusionData.AccessSelections(part, Nothing) '获取访问特征参数,此条必须!
swExtrusionData.ReverseDirection = Not swExtrusionData.ReverseDirection '反向
boolstatus = myFeature.ModifyDefinition(swExtrusionData, part, Nothing) '修改参数重建
End If
swExtrusionData.ReleaseSelectionAccess '释放特征参数
part.Rebuild (1) '重建以免合并结果未更新错误
part.ClearSelection2 True '清除选择
End Sub