如上图所示，试过了很多遍
钢板 "SW-3D-边界框长度@@@"X"SW-3D-边界框宽度@@@"X"SW-3D-边界框厚度@@@"
这段在SOLIDWORKS2016中是可以使用的，但是在solidworks2018里就无法出来结果。
求知道的朋友告知一下这里如何适应2018的。
作者: azhen001 时间: 2019-11-25 16:26
没有人遇到过吗？作者: nayven 时间: 2019-11-25 16:26
没有人遇到过吗？作者: kawayijoe 时间: 2019-11-25 17:00
在solidworks2018中使用下面这段才能生效solidworks网，必须顶一下
钢板 "SW-3D-边界框长度@@""X"SW-3D-边界框宽度@@""X"SW-3D-边界框厚度@@""作者: torance 时间: 2019-11-25 17:01
custPrOPMgr.Add "名称", "文字", "钢板""SW-3D-边界框长度@@@""X""SW-3D-边界框宽度@@@""X""SW-3D-边界框厚度@@@"""
但是这段代码不知道如何修正才能自动添加上面那段属性作者: jwyjwy 时间: 2019-11-25 17:01
custPrOPMgr.Add "名称", "文字", "钢板""SW-3D-边界框长度@@@""X""SW-3D-边界框宽度@@@""X""SW-3D-边界框厚度@@@"""
但是这段代码不知道如何修正才能自动添加上面那段属性作者: doudoule1981 时间: 2019-11-25 20:18
如果用宏程序，可用下面一句：
注意：swFeat.name：为特征名；
FileName：文件名
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作者: zzz021 时间: 2019-11-26 09:19
来学习学习作者: zzky760 时间: 2019-11-26 09:19
来学习学习作者: moja1453 时间: 2019-11-26 09:45
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 复制代码
修改后，提示运行时13错误，调试了之后还是没有解决，请大神帮忙看看问题出在哪里？作者: asdfg0914 时间: 2019-11-26 09:45
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 复制代码
修改后，提示运行时13错误，调试了之后还是没有解决，请大神帮忙看看问题出在哪里？作者: yoyoo1978 时间: 2019-11-26 11:37
'?ú????????и??嵥??????д?Щ???????????????????????????????Щ?й???????
'?硰????????и??嵥???????????????"????"???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, " ") '???????????????????????
End If
End If
'Debug.Print swFeat.GetTypeName2
Set swFeat = swFeat.GetNextFeature
Loop
bRet = swModel.ForceRebuild3(False)
MsgBox "???"
End Sub 复制代码
这是我编写的一个给焊件填写属性的宏程序，你可参考一下：作者: mydym520 时间: 2019-11-26 11:37
'?ú????????и??嵥??????д?Щ???????????????????????????????Щ?й???????
'?硰????????и??嵥???????????????"????"???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, " ") '???????????????????????
End If
End If
'Debug.Print swFeat.GetTypeName2
Set swFeat = swFeat.GetNextFeature
Loop
bRet = swModel.ForceRebuild3(False)
MsgBox "???"
End Sub 复制代码
这是我编写的一个给焊件填写属性的宏程序，你可参考一下：作者: w2626146 时间: 2019-11-26 11:40
好好的文件，怎么成了乱码？作者: yunfeiyang518 时间: 2019-11-26 11:40
好好的文件，怎么成了乱码？作者: ringfinger 时间: 2019-11-26 11:46
'该宏可为焊件切割清单属性填写一些通过其它方式获取的属性（也就是和其它一些有关联），
'如“名称”和切割清单某个项目名称相同；"单重"和“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, " ") '将数组转变为用空格隔开的字符串
End If
End If
'Debug.Print swFeat.GetTypeName2
Set swFeat = swFeat.GetNextFeature
Loop
bRet = swModel.ForceRebuild3(False)
MsgBox "完成"
End Sub 复制代码
转到记事本，重新复制一下，又好了！作者: moon1189 时间: 2019-11-26 11:46
'该宏可为焊件切割清单属性填写一些通过其它方式获取的属性（也就是和其它一些有关联），
'如“名称”和切割清单某个项目名称相同；"单重"和“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, " ") '将数组转变为用空格隔开的字符串
End If
End If
'Debug.Print swFeat.GetTypeName2
Set swFeat = swFeat.GetNextFeature
Loop
bRet = swModel.ForceRebuild3(False)
MsgBox "完成"
End Sub 复制代码
转到记事本，重新复制一下，又好了！作者: kingwuyi 时间: 2019-11-26 14:16
