有关在solidworks2018中使用3D边界框链接焊接钢板的外廊尺寸问题 - iCAx开思网

Option Explicit
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim thisFeat As SldWorks.Feature
Dim thisSubFeat As SldWorks.Feature
Dim cutFolder As Object
Dim BodyCount As Integer
Dim fn As String
Dim pn As String
Dim custPrOPMgr As SldWorks.CustomPropertyManager
Dim propNames As Variant
Dim vName As Variant
Dim propName As String
Dim Value As String
Dim resolvedValue As String
Dim TotalW As Double
Dim Parts As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim swFeat As Feature
Dim FileName As String
Sub main()
Set swApp = Application.SldWorks
Set Parts = swApp.ActiveDoc
Set thisFeat = Parts.FirstFeature
boolstatus = Parts.Extension.SelectByID2("实体", "BDYFOLDER", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = Parts.Extension.SelectByID2("实体", "BDYFOLDER", 0, 0, 0, False, 0, Nothing, 0)
Parts.ClearSelection2 True
boolstatus = Parts.Extension.SelectByID2("实体", "BDYFOLDER", 0, 0, 0, False, 0, Nothing, 0)
Parts.Extension.Create3DBoundingBox
Do While Not thisFeat Is Nothing
If thisFeat.GetTypeName = "SolidBodyFolder" Then
thisFeat.GetSpecificFeature2.UpdateCutList
End If
Set thisSubFeat = thisFeat.GetFirstSubFeature
Do While Not thisSubFeat Is Nothing
If thisSubFeat.GetTypeName = "CutListFolder" Then
Set cutFolder = thisSubFeat.GetSpecificFeature2
End If
If Not cutFolder Is Nothing Then
BodyCount = cutFolder.GetBodyCount
If BodyCount > 0 Then
Set custPrOPMgr = thisSubFeat.CustomPropertyManager
If Not custPrOPMgr Is Nothing Then
custPrOPMgr.Delete "Total Weight"
custPrOPMgr.Delete "总重"
custPrOPMgr.Delete "Weight"
custPrOPMgr.Delete "材料"
fn = thisSubFeat.Name
pn = Parts.GetTitle
custPrOPMgr.Add "单重", "文字", Chr(34) & "SW-Mass@@@" & fn & "@" & pn & Chr(34)
custPrOPMgr.Add "重量", "文字", Chr(34) & "SW-Mass@@@" & fn & "@" & pn & Chr(34)
custPrOPMgr.Add "材料", "文字", Chr(34) & "SW-Material@@@" & fn & "@" & pn & Chr(34)
propNames = custPrOPMgr.GetNames
If Not IsEmpty(propNames) Then
For Each vName In propNames
propName = vName
custPrOPMgr.Get2 propName, Value, resolvedValue
If propName = "重量" Then TotalW = resolvedValue
Next vName
End If
custPrOPMgr.Add "总重", "文字", Format(BodyCount * TotalW, "0.00")
custPrOPMgr.Add3 "名称", "文字", "钢板""""SW-3D-边界框长度@@@" & swFeat.Name & "@" & FileName & ".SLDPRT""" & "x""" & "SW-3D-边界框宽度@@@" & swFeat.Name & "@" & FileName & ".SLDPRT""" & "x""" & "SW-3D-边界框厚度@@@" & swFeat.Name & "@" & FileName & ".SLDPRT""", swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
End If
End If
End If
Set thisSubFeat = thisSubFeat.GetNextSubFeature
Loop
Set thisFeat = thisFeat.GetNextFeature
Loop
End Sub

复制代码

'?ú????????и??嵥??????д?Щ???????????????????????????????Щ?й???????
'?硰????????и??嵥???????????????"????"???SW-Mass???????
'?硰?????????QUANTITY???????"????"???SW-Mass???????
'???????????????????????????????????????????ò?????д??????????????
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swFeat As SldWorks.Feature
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim names As Variant '???????????????
Dim bRet As Boolean
Dim evalval As String
Dim featureName As String
Dim boolstatus As Boolean
Dim opt As Long
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelDocExt = swModel.Extension
' ????????????
Set swFeat = swModel.FirstFeature
Dim FileName As String
Dim name As String '????????
Dim textexp As String
Dim evalval As String
FileName = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "") + 1)
Do While Not swFeat Is Nothing
If swFeat Is Nothing Then
Exit Do
End If
featureName = swFeat.name
If swFeat.GetTypeName2 = "CutListFolder" Then
boolstatus = swModelDocExt.SelectByID2(featureName, "SUBWELDFOLDER", 0, 0, 0, False, 0, Nothing, 0)
Set swCustPropMgr = swFeat.CustomPropertyManager
names = swCustPropMgr.GetNames
name = Join(names, " ") '???????????????????????
swCustPropMgr.Add3 "????", swCustomInfoType_e.swCustomInfoText, _
"""SW-CutListItemName@@@" & swFeat.name & "@" & FileName & """", swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
swCustPropMgr.Get2 "DESCRIPTION", textexp, evalval
swCustPropMgr.Add3 "????", swCustomInfoType_e.swCustomInfoText, _
"""SW-Mass@@@" & swFeat.name & "@" & FileName & """", swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
swCustPropMgr.Get2 "QUANTITY", textexp, evalval
swCustPropMgr.Add3 "????", swCustomInfoType_e.swCustomInfoText, _
textexp, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
swCustPropMgr.Add3 "????????", swCustomInfoType_e.swCustomInfoText, _
"$PRP:""SW-File Name""", swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
If InStr(1, name, "????") <= 0 Then '?ж????????
swCustPropMgr.Add3 "????", swCustomInfoType_e.swCustomInfoText, _
"""SW-Material@@@" & swFeat.name & "@" & FileName & """", swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
swModelDocExt.Create3DBoundingBox '????????
swCustPropMgr.Add3 "???", swCustomInfoType_e.swCustomInfoText, _
"""SW-3D-??????@@@" & swFeat.name & "@" & FileName & ".SLDPRT""" _
& "x""" & "SW-3D-??????@@@" & swFeat.name & "@" & FileName & ".SLDPRT""" _
& "x""" & "SW-3D-??????@@@" & swFeat.name & "@" & FileName & ".SLDPRT""", _
swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
Else
swCustPropMgr.Get2 "DESCRIPTION", textexp, evalval '???????????DESCRIPTION?????
swCustPropMgr.Add3 "????", swCustomInfoType_e.swCustomInfoText, _
textexp, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd '???????DESCRIPTION???????д???????????????
End If
End If
' Debug.Print swFeat.GetTypeName2
Set swFeat = swFeat.GetNextFeature
Loop
bRet = swModel.ForceRebuild3(False)
MsgBox "???"
End Sub

复制代码

'该宏可为焊件切割清单属性填写一些通过其它方式获取的属性（也就是和其它一些有关联），
'如“名称”和切割清单某个项目名称相同；"单重"和“SW-Mass”相同；
'如“数量”和“QUANTITY”相同；
'对于板材件，增加一项“备注”，并获取平板的边界框参数，将该参数填写进“备注”项目中
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swFeat As SldWorks.Feature
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim names As Variant '属性名称数组变体
Dim bRet As Boolean
Dim evalval As String
Dim featureName As String
Dim boolstatus As Boolean
Dim opt As Long
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelDocExt = swModel.Extension
' 获取第一个特征
Set swFeat = swModel.FirstFeature
Dim FileName As String
Dim name As String '属性名称
Dim textexp As String
Dim evalval As String
FileName = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "") + 1)
Do While Not swFeat Is Nothing
If swFeat Is Nothing Then
Exit Do
End If
featureName = swFeat.name
If swFeat.GetTypeName2 = "CutListFolder" Then
boolstatus = swModelDocExt.SelectByID2(featureName, "SUBWELDFOLDER", 0, 0, 0, False, 0, Nothing, 0)
Set swCustPropMgr = swFeat.CustomPropertyManager
names = swCustPropMgr.GetNames
name = Join(names, " ") '将数组转变为用空格隔开的字符串
swCustPropMgr.Add3 "名称", swCustomInfoType_e.swCustomInfoText, _
"""SW-CutListItemName@@@" & swFeat.name & "@" & FileName & """", swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
swCustPropMgr.Get2 "DESCRIPTION", textexp, evalval
swCustPropMgr.Add3 "单重", swCustomInfoType_e.swCustomInfoText, _
"""SW-Mass@@@" & swFeat.name & "@" & FileName & """", swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
swCustPropMgr.Get2 "QUANTITY", textexp, evalval
swCustPropMgr.Add3 "数量", swCustomInfoType_e.swCustomInfoText, _
textexp, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
swCustPropMgr.Add3 "所属装配号", swCustomInfoType_e.swCustomInfoText, _
"$PRP:""SW-File Name""", swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
If InStr(1, name, "长度") <= 0 Then '判断是否为板材
swCustPropMgr.Add3 "材料", swCustomInfoType_e.swCustomInfoText, _
"""SW-Material@@@" & swFeat.name & "@" & FileName & """", swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
swModelDocExt.Create3DBoundingBox '创建边界框
swCustPropMgr.Add3 "备注", swCustomInfoType_e.swCustomInfoText, _
"""SW-3D-边界框长度@@@" & swFeat.name & "@" & FileName & ".SLDPRT""" _
& "x""" & "SW-3D-边界框宽度@@@" & swFeat.name & "@" & FileName & ".SLDPRT""" _
& "x""" & "SW-3D-边界框厚度@@@" & swFeat.name & "@" & FileName & ".SLDPRT""", _
swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
Else
swCustPropMgr.Get2 "DESCRIPTION", textexp, evalval '如果为型材，获取DESCRIPTION属性值
swCustPropMgr.Add3 "材料", swCustomInfoType_e.swCustomInfoText, _
textexp, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd '将获取的DESCRIPTION属性值填写到“材料”属性中
End If
End If
' Debug.Print swFeat.GetTypeName2
Set swFeat = swFeat.GetNextFeature
Loop
bRet = swModel.ForceRebuild3(False)
MsgBox "完成"
End Sub

复制代码