|
- 由于平时需要在工程图中填写页码(底图张次),于是在闷大“【遍历宏】在总装配內零件的自定义属性写入配套数量”一贴的基础上修改为写入页码,页码是都填写出来,可是它不一定按总装设计树的顺序编号,有点随机,以下代码不知道能否修改一下,使得页码按总装设计树的顺序编号?请教各位大侠!
复制代码- Dim TopDocPathOnly As String
- Dim PartsCollect() As String '遍历清单(阵列)
- Dim InCollectCount As Double '遍历清单长度
- Dim CustomInfoQTY As String
- '*******************************************************
- Dim Page_Qty As String
- Dim Page_Pre As String
- Dim swApp As SldWorks.SldWorks
- Dim swModelDoc As SldWorks.ModelDoc2
- Dim swConfig As SldWorks.Configuration
- Dim CustPrOPMgr As SldWorks.CustomPropertyManager
- Sub main()
- Answer = MsgBox("① 本程序将遍历装配体填写“页码”属性,请确认顶层装配体已保存!" & Chr(13) & "② 不在顶层装配体目录或子目录、压缩、轻化、虚拟、封套、不包括在BOM中的零部件不作处理。", vbOKCancel + 48)
- If Answer = vbOK Then
- Set swApp = Application.SldWorks 'SW对象
- Set TopDoc = swApp.ActiveDoc '顶层装配体对象
- If TopDoc.GetType <> 2 Then Exit Sub '如果不是装配体则退出
- TopDocPathSplit = Split(TopDoc.GetPathName, "") '分割
- TopDocName = TopDocPathSplit(UBound(TopDocPathSplit)) '顶层装配体文件名称
- TopDocName = Left(TopDocName, Len(TopDocName) - 7) '顶层装配体文件名称(排除.SLDASM)
- TopDocPathOnly = Mid(TopDoc.GetPathName, 1, InStrRev(TopDoc.GetPathName, "", -1)) '顶层装配体的完整目录
- TopConfString = TopDoc.GetActiveConfiguration.Name '顶层装配体配置名称
- CustomInfoQTY = "配套数量" '可根据需要改为其它
- Page_Qty = 1 '页码递增基数
- InCollectCount = 1 '遍历清单长度基数
- ReDim PartsCollect(InCollectCount) '定义阵列项数
- Else: Exit Sub
- End If
- '*******************************************************
- Page_Pre = InputBox("输入页码前缀再按“确定”,无前缀请按任意键。")
- Set TopCustPropMgr = TopDoc.Extension.CustomPropertyManager("")
- TopCustPropMgr.Delete ("页码")
- TopCustPropMgr.Add2 "页码", swCustomInfoText, Page_Pre & "" & "1" '指定顶层装配体的页码为“1”
- '*******************************************************
- SubAsm TopDoc, TopConfString '遍历
- Beep '响铃
- End Sub
- Function SubAsm(AsmDoc, ConfString)
- Set Configuration = AsmDoc.GetConfigurationByName(ConfString)
- Set RootComponent = Configuration.GetRootComponent
- Components = RootComponent.GetChildren
- For Each Child In Components
- Set ChildModel = Child.GetModelDoc
- If Not (ChildModel Is Nothing) Then '排除压缩及轻化
- ChildConfString = Child.ReferencedConfiguration '零件配置名称
- ChildType = ChildModel.GetType
- ChildPathSplit = Split(Child.GetPathName, "") '分割
- ChildName = ChildPathSplit(UBound(ChildPathSplit)) '零件文件名称
- ChildPathOnly = Mid(Child.GetPathName, 1, InStrRev(Child.GetPathName, "", -1)) '零件的完整目录
- If ChildPathOnly = Replace(ChildPathOnly, TopDocPathOnly, "") Then SamePath = False Else SamePath = True '零件是否在顶层装配体目录或子目录中
- If SamePath And (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then '跳过:不在顶层装配体目录或子目录 及 不包括在BOM中 及 封套
- 'If (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then '跳过:不包括在BOM中 及 封套
- UNIT_OF_MEASURE_Name = ChildModel.CustomInfo2("", "UNIT_OF_MEASURE") '备用量属性名称
- UNIT_OF_MEASURE = ChildModel.CustomInfo2("", UNIT_OF_MEASURE_Name) '备用量
- If (UNIT_OF_MEASURE = 0) Or (UNIT_OF_MEASURE = "") Then UNIT_OF_MEASURE = 1 '备用量除错
- inCollect = False '重置判断变量
- For Each PartinCollect In PartsCollect '判断是否已在遍历清单内
- If "" & "@" & ChildName = PartinCollect Then inCollect = True
- Next
- If inCollect Then '已在遍历清单内
- ' ht_Qty = ChildModel.CustomInfo2("", CustomInfoQTY) + 1 * UNIT_OF_MEASURE
- ' ChildModel.DeleteCustomInfo2 "", CustomInfoQTY
- ' ChildModel.AddCustomInfo3 "", CustomInfoQTY, 30, ht_Qty
- Else '不在遍历清单内(首次处理)
- ' ChildModel.DeleteCustomInfo2 "", CustomInfoQTY
- ' ChildModel.AddCustomInfo3 "", CustomInfoQTY, 30, UNIT_OF_MEASURE
- InCollectCount = InCollectCount + 1 '遍历清单长度基数+1
- ReDim Preserve PartsCollect(InCollectCount) '重新定义阵列项数(保留内含数据)
- PartsCollect(InCollectCount - 1) = "" & "@" & ChildName '加入到遍历清单中
- '*******************************************************
- Set CustPropMgr = ChildModel.Extension.CustomPropertyManager("")
- Page_Qty = Page_Qty + 1
- ChildModel.DeleteCustomInfo2 "", ("页码")
- ChildModel.AddCustomInfo3 "", ("页码"), 30, Page_Pre & Page_Qty
- '*******************************************************
- ChildModel.SketchManager.Insert3DSketch True '插入3D草图,从而激活零件的“需存盘标签”
- ChildModel.SketchManager.Insert3DSketch True '离开3D草图
- End If
- If ChildType = 2 Then
- SubAsm ChildModel, ChildConfString '如果是装配体则向下遍历
- End If
- End If
- End If
- Next
- End Function
复制代码
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看,没有帐号?注册
x
|