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

qxzch

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

qxzch

gdzsh

大鹿

大鹿

qxzch

qxzch

gdzsh

gdzsh