标题: 宏--拉伸切除特征定义修改为给定深度 [打印本页] 作者: fuminghai 时间: 2018-4-27 11:22 标题: 宏--拉伸切除特征定义修改为给定深度 ' ******************************************************************************
'镜向阵列时,由于拉伸切除特征中定义是拉伸到某点或到某线或到某面,出现报错。通过宏将定义改为给定深度，避免报错 04/25/2018 by PYCZT
'预选:选择一个拉伸或切除特征
'结果:根据特征的定义进行计算出给定深度,并修改定义
' ******************************************************************************
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swFeat As SldWorks.Feature
Dim SwSketch As SldWorks.Sketch
Dim swExtrusionData As ExtrudeFeatureData2 '定义拉伸切除特征参数
Dim boolstatus As Boolean
Dim Forward As Boolean
Dim EndCondvalue(1) As Integer
Dim SwEndConRef As Object
Dim FromEntity As Object
Dim FromEntityType As Long
Dim Sketchplane As SldWorks.Entity
Dim nEntType As Long
Dim vPoint1, vPoint2, vPoint3, vPoint4 As Variant
Dim EndCondition1, EndCondition2 As Long
Dim Depth As Double
Sub main()
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager
Set swFeat = swSelMgr.GetSelectedObject5(1)
Debug.Print swFeat.Name & " [" & swFeat.GetTypeName & "]" '特征名
Set SwSketch = swFeat.GetFirstSubFeature.GetSpecificFeature2 'GetChildren
Debug.Print "Sketch Name = 草图名称为 " + SwSketch.Name
Set swExtrusionData = swFeat.GetDefinition '取得特征参数
boolstatus = swExtrusionData.AccessSelections(swModel, Nothing) '获取访问特征参数,此条必须!
Dim Ref1 As Object
Dim Type1 As Long
Dim Ref2 As Object
Dim Type2 As Long
Dim DirectNumValue As Long
DirectNumValue = swExtrusionData.GetDirectionReference(Ref1, Type1, Ref2, Type2)
Debug.Print " DirectNumValue = " & DirectNumValue
If DirectNumValue >= 1 Then
MsgBox "暂不支持存在方向参考,执行退出"
Exit Sub
End If
Forward = True '方向初值
For I = 0 To 1
EndCondvalue(I) = swExtrusionData.GetEndCondition(Forward)
Debug.Print "第" & I & " 终止条件为EndConditionvalue " & EndCondvalue(I)
Select Case EndCondvalue(I)
Case 0
Debug.Print "swEndCondBlind 给定深度"
Case 1
Debug.Print "swEndCondThroughAll完全贯穿"
Case 2
Debug.Print "swEndCondThroughNext成形到下个面"
Case 3
Debug.Print "swEndCondUpToVertex成形到顶点 "
Case 4
Debug.Print "swEndCondUpToSurface成形到一面 "
Case 5
Debug.Print "swEndCondOffsetFromSurface成形到离指定面指定的距离"
Case 6
Debug.Print "'swEndCondMidPlane两侧对称"
Case 7
Debug.Print "'swEndCondUpToBody成形到实体"
End Select
If EndCondvalue(I) = 0 Or EndCondvalue(I) = 1 Or EndCondvalue(I) = 2 Or EndCondvalue(I) = 5 Or EndCondvalue(I) = 6 Or EndCondvalue(I) = 7 Then
Debug.Print "终止条件已是拉伸或切除深度或其它不合适项,无需转换"
GoTo nextdo
End If
Dim ReferenceType As Long
Set SwEndConRef = swExtrusionData.GetEndConditionReference(Forward, ReferenceType) '获得终止对象
' Dim EndConRefValue As String
' EndConRefValue = swModel.GetEntityName(SwEndConRef)
' Debug.Print " SwEndConRefName = " & EndConRefValue
终止到点改为给定深度.rar
(16.89 KB, 下载次数: 174)