SolidWorks机械工程师网，顶一下。

活到老学到老

很不错，找到组织了！

很不错，顶一下！

求教怎么写入配置清单中，十分感谢

很不错，顶一下！

tg000057 发表于 2021-1-20 09:49
Sub main()
Dim thisFeat As SldWorks.Feature                                                       ...

可以在加上有多少个攻丝孔？多少个沉孔吗？

很不错，找到组织了！

活到老学到老！

能不能把外部切割长度和内部切割长度相加吗

楼主很专业，写得很好！

谢谢各位大佬的分享    第一次接触到修改程序

拉丝毛刺 发表于 2021-1-19 10:24
我刚才研究了一下，新建宏把里面的都删掉才可以运行，展开长度和宽度可以添加到自定义属性，现在我想添加 ...

Sub main()
Dim thisFeat As SldWorks.Feature                                                         '
Dim thisSubFeat As SldWorks.Feature
Dim cutFolder As Object
Dim BodyCount As Integer
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 bjkcd As Double
'Dim bjkkd As Double


Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set thisFeat = Part.FirstFeature
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
propNames = custPropMgr.GetNames '获取切割清单属性的数据全部名称并放入数组
If Not IsEmpty(propNames) Then
For Each vName In propNames
propName = vName
custPropMgr.Get2 propName, Value, resolvedValue '获取全部属性名称 ，数值和评估的值
If propName = "边界框长度" Then bjkcd = resolvedValue '判断是否是自己所需要的数据，如果是就获取
If propName = "边界框宽度" Then bjkkd = resolvedValue
If propName = "切割长度-内部" Then qgcdnb = resolvedValue
If propName = "切割长度-外部" Then qgcdwb = resolvedValue
If propName = "切除" Then qc = resolvedValue
If propName = "折弯" Then zw = resolvedValue
If propName = "钣金厚度" Then bjhd = resolvedValue




Next vName
End If
End If
End If
End If
Set thisSubFeat = thisSubFeat.GetNextSubFeature
Loop
Set thisFeat = thisFeat.GetNextFeature
Loop
blnretval = Part.DeleteCustomInfo2("", "边界框长度") '删除属性栏上摘要信息的数据
blnretval = Part.DeleteCustomInfo2("", "边界框宽度")
blnretval = Part.DeleteCustomInfo2("", "切割长度-内部")
blnretval = Part.DeleteCustomInfo2("", "切割长度-外部")
blnretval = Part.DeleteCustomInfo2("", "穿孔数")
blnretval = Part.DeleteCustomInfo2("", "折弯刀数")
blnretval = Part.DeleteCustomInfo2("", "钣金厚度")


blnretval = Part.AddCustomInfo3("", "开料长度", swCustomInfoText, bjkcd) '添加数据到摘要信息
blnretval = Part.AddCustomInfo3("", "开料宽度", swCustomInfoText, bjkkd)
blnretval = Part.AddCustomInfo3("", "切割长度-内部", swCustomInfoText, qgcdnb)
blnretval = Part.AddCustomInfo3("", "切割长度-外部", swCustomInfoText, qgcdwb)
blnretval = Part.AddCustomInfo3("", "穿孔数", swCustomInfoText, qc)
blnretval = Part.AddCustomInfo3("", "折弯刀数", swCustomInfoText, zw)
blnretval = Part.AddCustomInfo3("", "板厚", swCustomInfoText, bjhd)


End Sub

拉丝毛刺 发表于 2021-1-18 16:29
是的，自定义属性里没有变化

昨天回复几个贴都没通过，不知道怎么回事，
你这个是开始和结束语注意一下，要把新建宏时原有的语句全部删除了，要复制代码进去，最后加一行结束语，这一行我复制漏了：end sub

拉丝毛刺 发表于 2021-1-18 16:29
是的，自定义属性里没有变化

嗯，是我的问题，少了最后的结束语，新建宏原来就有几行的，都不要。因为Sub main()会重复。就执行不了了。最后一行加上 end sub
按这下面的也行


Sub main()
Dim thisFeat As SldWorks.Feature                                                         '
Dim thisSubFeat As SldWorks.Feature
Dim cutFolder As Object
Dim BodyCount As Integer
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 bjkcd As Double
Dim bjkkd As Double
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set thisFeat = Part.FirstFeature
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
propNames = custPropMgr.GetNames '获取切割清单属性的数据全部名称并放入数组
If Not IsEmpty(propNames) Then
For Each vName In propNames
propName = vName
custPropMgr.Get2 propName, Value, resolvedValue '获取全部属性名称 ，数值和评估的值
If propName = "边界框长度" Then bjkcd = resolvedValue '判断是否是自己所需要的数据，如果是就获取
If propName = "边界框宽度" Then bjkkd = resolvedValue
Next vName
End If
End If
End If
End If
Set thisSubFeat = thisSubFeat.GetNextSubFeature
Loop
Set thisFeat = thisFeat.GetNextFeature
Loop
blnretval = Part.DeleteCustomInfo2("", "边界框长度") '删除属性栏上摘要信息的数据
blnretval = Part.DeleteCustomInfo2("", "边界框宽度")
blnretval = Part.AddCustomInfo3("", "开料长度", swCustomInfoText, bjkcd) '添加数据到摘要信息
blnretval = Part.AddCustomInfo3("", "开料宽度", swCustomInfoText, bjkkd)
end sub

tg000057 发表于 2021-1-18 16:17
没有反映，是什么情况，是切割清单的参数没到导到自定义属性里吗？

是的，自定义属性里没有变化

拉丝毛刺 发表于 2021-1-18 15:26
这是修改后的，可是运行没有反应，请问是什么原因

没有反映，是什么情况，是切割清单的参数没到导到自定义属性里吗？