【遍历宏】在总装配內零件的自定义属性写入页码

1. 由于平时需要在工程图中填写页码（底图张次），于是在闷大“【遍历宏】在总装配內零件的自定义属性写入配套数量”一贴的基础上修改为写入页码，页码是都填写出来，可是它不一定按总装设计树的顺序编号，有点随机，以下代码不知道能否修改一下，使得页码按总装设计树的顺序编号？请教各位大侠！

复制代码

1. Dim TopDocPathOnly As String
   
2. Dim PartsCollect() As String    '遍历清单（阵列）
   
3. Dim InCollectCount As Double    '遍历清单长度
   
4. Dim CustomInfoQTY  As String
   
5. 
   
6. '*******************************************************
   
7. Dim Page_Qty           As String
   
8. Dim Page_Pre           As String
   
9. Dim swApp              As SldWorks.SldWorks
   
10. Dim swModelDoc         As SldWorks.ModelDoc2
    
11. Dim swConfig           As SldWorks.Configuration
    
12. Dim CustPrOPMgr        As SldWorks.CustomPropertyManager
    
13. 
    
14. Sub main()
    
15. 
    
16. Answer = MsgBox("① 本程序将遍历装配体填写“页码”属性，请确认顶层装配体已保存！" & Chr(13) & "② 不在顶层装配体目录或子目录、压缩、轻化、虚拟、封套、不包括在BOM中的零部件不作处理。", vbOKCancel + 48)
    
17. If Answer = vbOK Then
    
18.   Set swApp = Application.SldWorks        'SW对象
    
19.   Set TopDoc = swApp.ActiveDoc            '顶层装配体对象
    
20.   If TopDoc.GetType <> 2 Then Exit Sub    '如果不是装配体则退出
    
21.   TopDocPathSplit = Split(TopDoc.GetPathName, "")         '分割
    
22.   TopDocName = TopDocPathSplit(UBound(TopDocPathSplit))    '顶层装配体文件名称
    
23.   TopDocName = Left(TopDocName, Len(TopDocName) - 7)       '顶层装配体文件名称（排除.SLDASM）
    
24.   TopDocPathOnly = Mid(TopDoc.GetPathName, 1, InStrRev(TopDoc.GetPathName, "", -1))    '顶层装配体的完整目录
    
25.   TopConfString = TopDoc.GetActiveConfiguration.Name       '顶层装配体配置名称
    
26.   CustomInfoQTY = "配套数量"                               '可根据需要改为其它
    
27.   Page_Qty = 1                            '页码递增基数
    
28.   InCollectCount = 1                      '遍历清单长度基数
    
29.   ReDim PartsCollect(InCollectCount)      '定义阵列项数
    
30. Else: Exit Sub
    
31. End If
    
32. 
    
33. '*******************************************************
    
34. Page_Pre = InputBox("输入页码前缀再按“确定”，无前缀请按任意键。")
    
35. Set TopCustPropMgr = TopDoc.Extension.CustomPropertyManager("")
    
36. TopCustPropMgr.Delete ("页码")
    
37. TopCustPropMgr.Add2 "页码", swCustomInfoText, Page_Pre & "" & "1"             '指定顶层装配体的页码为“1”
    
38. '*******************************************************
    
39. 
    
40. SubAsm TopDoc, TopConfString     '遍历
    
41. 
    
42. Beep    '响铃
    
43. 
    
44. End Sub
    
45. 
    
46. Function SubAsm(AsmDoc, ConfString)
    
47. 
    
48. Set Configuration = AsmDoc.GetConfigurationByName(ConfString)
    
49. Set RootComponent = Configuration.GetRootComponent
    
50. Components = RootComponent.GetChildren
    
51. For Each Child In Components
    
52.     Set ChildModel = Child.GetModelDoc
    
53.     If Not (ChildModel Is Nothing) Then    '排除压缩及轻化
    
54.         ChildConfString = Child.ReferencedConfiguration    '零件配置名称
    
55.         ChildType = ChildModel.GetType
    
56.         ChildPathSplit = Split(Child.GetPathName, "")     '分割
    
57.         ChildName = ChildPathSplit(UBound(ChildPathSplit)) '零件文件名称
    
58. 
    
59.         ChildPathOnly = Mid(Child.GetPathName, 1, InStrRev(Child.GetPathName, "", -1))  '零件的完整目录
    
60.         If ChildPathOnly = Replace(ChildPathOnly, TopDocPathOnly, "") Then SamePath = False Else SamePath = True    '零件是否在顶层装配体目录或子目录中
    
61. 
    
62.         If SamePath And (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then       '跳过：不在顶层装配体目录或子目录 及 不包括在BOM中 及 封套
    
63.         'If (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then                    '跳过：不包括在BOM中 及 封套
    
64.             UNIT_OF_MEASURE_Name = ChildModel.CustomInfo2("", "UNIT_OF_MEASURE")         '备用量属性名称
    
65.             UNIT_OF_MEASURE = ChildModel.CustomInfo2("", UNIT_OF_MEASURE_Name)           '备用量
    
66.             If (UNIT_OF_MEASURE = 0) Or (UNIT_OF_MEASURE = "") Then UNIT_OF_MEASURE = 1  '备用量除错
    
67.             inCollect = False    '重置判断变量
    
68.             For Each PartinCollect In PartsCollect    '判断是否已在遍历清单内
    
69.                 If "" & "@" & ChildName = PartinCollect Then inCollect = True
    
70.             Next
    
71.             If inCollect Then    '已在遍历清单内
    
72. '                ht_Qty = ChildModel.CustomInfo2("", CustomInfoQTY) + 1 * UNIT_OF_MEASURE
    
73. '                ChildModel.DeleteCustomInfo2 "", CustomInfoQTY
    
74. '                ChildModel.AddCustomInfo3 "", CustomInfoQTY, 30, ht_Qty
    
75.             Else                 '不在遍历清单内（首次处理）
    
76. '                ChildModel.DeleteCustomInfo2 "", CustomInfoQTY
    
77. '                ChildModel.AddCustomInfo3 "", CustomInfoQTY, 30, UNIT_OF_MEASURE
    
78.                 InCollectCount = InCollectCount + 1            '遍历清单长度基数+1
    
79.                 ReDim Preserve PartsCollect(InCollectCount)    '重新定义阵列项数（保留内含数据）
    
80.                 PartsCollect(InCollectCount - 1) = "" & "@" & ChildName    '加入到遍历清单中
    
81. 
    
82.                 '*******************************************************
    
83.                 Set CustPropMgr = ChildModel.Extension.CustomPropertyManager("")
    
84.                 Page_Qty = Page_Qty + 1
    
85.                 ChildModel.DeleteCustomInfo2 "", ("页码")
    
86.                 ChildModel.AddCustomInfo3 "", ("页码"), 30, Page_Pre & Page_Qty
    
87.                 '*******************************************************
    
88. 
    
89.                 ChildModel.SketchManager.Insert3DSketch True     '插入3D草图，从而激活零件的“需存盘标签”
    
90.                 ChildModel.SketchManager.Insert3DSketch True     '离开3D草图
    
91. 
    
92.             End If
    
93.             If ChildType = 2 Then
    
94.                 SubAsm ChildModel, ChildConfString               '如果是装配体则向下遍历
    
95.             End If
    
96. 
    
97.         End If
    
98.     End If
    
99. Next
    
100. 
     
101. End Function

复制代码

顶起来，很实用的宏 复制代码运行报错

gdzsh 发表于 2018-2-24 15:26
顶起来，很实用的宏 复制代码运行报错

请问报了什么错？

qxzch 发表于 2018-2-24 18:38
请问报了什么错？

上传报错附件

gdzsh 发表于 2018-2-26 13:44
上传报错附件

俺好象看到脏话

页码是工程图的东东吧，怎么要写到零件属性？

gdzsh 发表于 2018-2-26 13:44
上传报错附件

奇怪！我这里运行正常啊，SW2017。

大鹿 发表于 2018-2-26 14:20
页码是工程图的东东吧，怎么要写到零件属性？

如附图明细栏最后一列所示，需要列出每个零部件的底图张次，就像普通自定义属性一样写在模型文件中的。

qxzch 发表于 2018-2-26 21:27
奇怪！我这里运行正常啊，SW2017。

我也是SW2017啊

大鹿 发表于 2018-2-26 14:18
俺好象看到脏话

我怎么没有发现有一点脏话的意思啊？